leveleditor.lisp

   1 ;;; Copyright 2009-2011 Christoph Senjak
   2
   3 (in-package :uxul-world-leveleditor)
   4
   5 (defparameter *leveleditor-images* nil)
   6
   7 (defun bmp-to-gif (inblob)
   8   "Convert BMP to Grayscale-Gif using skippy."
   9   (let*
  10       ((w (uxul-world::bmp-width inblob))
  11        (h (uxul-world::bmp-height inblob))
  12        (img (uxul-world::bmp-pixel-data inblob))
  13        (color-table (skippy:make-color-table))
  14        (colors
  15         (let
  16             ((v (make-array '(256) :adjustable nil)))
  17           (dotimes (i 256)
  18             (setf (elt v i)
  19                (skippy:ensure-color (skippy:rgb-color i i i)  color-table)))
  20           v))
  21        (grayscale (lambda (x)
  22                     ;; 0 becomes transparent
  23                     (cond
  24                       ((< (elt x 3) 128) 0)
  25                       (t (max 1
  26                               (round
  27                                (/ (+ (elt x 1) (elt x 2) (elt x 0)) 3)))))))
  28        (image-data
  29         (let ((id (skippy:make-image-data w h)))
  30           (dotimes (i w)
  31             (dotimes (j h)
  32               (setf (elt id (+ i (* w (- h j 1))))
  33                     (elt colors
  34                          (funcall grayscale
  35                                   (make-array '(4)
  36                                               :element-type '(unsigned-byte 8)
  37                                               :displaced-to img
  38                                               :displaced-index-offset
  39                                               (* 4 (+ i (* w j)))))))))
  40           id))
  41        (image (skippy:make-image :width w :height h
  42                                  :image-data image-data
  43                                  :transparency-index 0))
  44        (data-stream (skippy:make-data-stream
  45                      :height h :width w
  46                      :color-table color-table)))
  47     (skippy:add-image image data-stream)
  48     (flexi-streams:with-output-to-sequence (out)
  49       (skippy:write-data-stream data-stream out))))
  50
  51 (defun stretched-image (imgs)
  52   "Resize that image to 32x32 and convert it into a gif."
  53   (let*
  54       ((w (car imgs))
  55        (h (cadr imgs))
  56        (x (elt imgs 6))
  57        (y (elt imgs 7))
  58        (*spritesheet* uxul-world::*spritesheet*)
  59        (image (uxul-world::sub-image x y w h (car *spritesheet*)
  60                                      (cadr *spritesheet*)
  61                                      (cadr *spritesheet*))))
  62     (bmp-to-gif
  63      (uxul-world::resize-bmp-blob image 32 32))))
  64
  65 (defun annotated-image (img ann)
  66   "Add a (lower-left) annotation."
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;FIXME
  68 img
  69
  70 ;;   (lisp-magick:with-magick-wand (mywand)
  71 ;;     (lisp-magick::magick-read-image-blob mywand img)
  72 ;;     (lisp-magick:with-drawing-wand (dw)
  73 ;;       (lisp-magick:with-pixel-wand (pw :comp (255 255 255))
  74 ;;      (lisp-magick::draw-set-text-under-color dw pw))
  75 ;;       (lisp-magick:with-pixel-wand (pw :comp (255 0 0))
  76 ;;      (lisp-magick::draw-set-fill-color dw pw))
  77 ;;       (lisp-magick:draw-annotation dw (coerce 0 'double-float) (coerce 32 'double-float) ann)
  78 ;;       (lisp-magick:magick-draw-image mywand dw))
  79 ;;     (lisp-magick::magick-set-format mywand "gif")
  80 ;;     (lisp-magick::magick-get-image-blob mywand)))
  81 )
  82
  83 (defun numbered-image (img num)
  84   "Annotate the image with a number."
  85   (annotated-image img (format nil "~d" num)))
  86
  87 (defun prepare-images (&optional (care-about-initialization *leveleditor-images*))
  88   (when (not care-about-initialization)
  89     (setf *leveleditor-images* (make-hash-table))
  90     (uxul-world::init-files)
  91     (setf (gethash 'uxul-world::uxul *leveleditor-images*) (stretched-image uxul-world::|uxul_small1|))
  92     (setf (gethash 'uxul-world::leaf *leveleditor-images*) (stretched-image uxul-world::|leaf|))
  93     (setf (gethash 'uxul-world::nasobem *leveleditor-images*) (stretched-image uxul-world::|nasobem|))
  94     (setf (gethash 'uxul-world::blue-nasobem *leveleditor-images*) (stretched-image uxul-world::|blue_nasobem|))
  95     (setf (gethash 'uxul-world::burning-marshmallow *leveleditor-images*) (stretched-image uxul-world::|burning_marshmallow_ld1|))
  96     (setf (gethash 'uxul-world::gray-stone *leveleditor-images*) (stretched-image uxul-world::|gray_stone|))
  97     (setf (gethash 'uxul-world::brown-stone *leveleditor-images*) (stretched-image uxul-world::|brown_stone|))
  98     (setf (gethash 'uxul-world::empty *leveleditor-images*) (stretched-image uxul-world::|empty|))
  99     (setf (gethash 'uxul-world::tulip *leveleditor-images*) (stretched-image uxul-world::|tulip|))
 100     (setf (gethash 'uxul-world::door *leveleditor-images*) (stretched-image uxul-world::|door|))
 101     (setf (gethash 'uxul-world::key *leveleditor-images*) (stretched-image uxul-world::|key|))
 102     (setf (gethash 'uxul-world::anchor *leveleditor-images*) (stretched-image uxul-world::|anchor|))
 103 ))
 104
 105 (defun load-image-into-tk (png)
 106   "return a tkobject with this image"
 107   (let ((name (ltk::create-name)))
 108     (ltk:format-wish "set ~A [ image create photo -data \"~A\" ]"
 109                      name (base64-encode-byteseq png))
 110     (make-instance 'ltk:tkobject :name name)))
 111
 112 (defun config-button-image (button tkobject)
 113   (ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject)))
 114
 115 (defun item-table-to-list (item-table)
 116   "Special Function for level-editor. Returns a list of lists of the
 117 form (x y object arg1 arg2 ...)."
 118   (let ((ret nil))
 119     (maphash #'(lambda (key val)
 120                  (when val
 121                    (push (concatenate 'list (list (car key) (cdr key)) val)  ret)))
 122              item-table)
 123     ret))
 124
 125 (defun level-editor (&optional (level nil) (width 16) (height 16))
 126   ;; hack. swap "width" and "height". (too lazy to change it properly by now)
 127   (let ((nilpferd width))
 128     (setf width height)
 129     (setf height nilpferd))
 130
 131   (prepare-images)
 132   (let ((item-table (make-hash-table :test 'equal)))
 133     ;;initialize given level
 134     (dolist (item level)
 135       (setf (gethash (cons (car item) (cadr item)) item-table) (cddr item)))
 136     (ltk:with-ltk ()
 137       (let*
 138           ((uxul (load-image-into-tk (gethash 'uxul-world::uxul *leveleditor-images*)))
 139            (leaf (load-image-into-tk (gethash 'uxul-world::leaf *leveleditor-images*)))
 140            (nasobem (load-image-into-tk (gethash 'uxul-world::nasobem *leveleditor-images*)))
 141            (blue-nasobem (load-image-into-tk (gethash 'uxul-world::blue-nasobem *leveleditor-images*)))
 142            (burning-marshmallow (load-image-into-tk (gethash 'uxul-world::burning-marshmallow *leveleditor-images*)))
 143            (gray-stone (load-image-into-tk (gethash 'uxul-world::gray-stone *leveleditor-images*)))
 144            (brown-stone (load-image-into-tk (gethash 'uxul-world::brown-stone *leveleditor-images*)))
 145            (empty (load-image-into-tk (gethash 'uxul-world::empty *leveleditor-images*)))
 146            (tulip (load-image-into-tk (gethash 'uxul-world::tulip *leveleditor-images*)))
 147            (key (load-image-into-tk (gethash 'uxul-world::key *leveleditor-images*)))
 148            (door (load-image-into-tk (gethash 'uxul-world::door *leveleditor-images*)))
 149            (anchor (load-image-into-tk (gethash 'uxul-world::anchor *leveleditor-images*)))
 150            (anchors (make-hash-table :test 'equal))
 151            (current-upper-left (cons 0 0))
 152            (current-chosen-object 'uxul)
 153            (objects-and-arrows (make-instance 'ltk:frame))
 154            (grid-frame (make-instance 'ltk:frame))
 155            (object-frame (make-instance 'ltk:frame :master objects-and-arrows))
 156            (arrow-frame (make-instance 'ltk:frame :master objects-and-arrows))
 157            (right-button (make-instance 'ltk:button :text ">"
 158                                         :master arrow-frame))
 159            (left-button (make-instance 'ltk:button :text "<"
 160                                        :master arrow-frame))
 161            (up-button (make-instance 'ltk:button :text "/\\"
 162                                      :master arrow-frame))
 163            (down-button (make-instance 'ltk:button :text "\\/"
 164                                        :master arrow-frame))
 165            (rright-button (make-instance 'ltk:button :text ">>"
 166                                         :master arrow-frame))
 167            (lleft-button (make-instance 'ltk:button :text "<<"
 168                                        :master arrow-frame))
 169            (uup-button (make-instance 'ltk:button :text "//\\\\"
 170                                      :master arrow-frame))
 171            (ddown-button (make-instance 'ltk:button :text "\\\\//"
 172                                        :master arrow-frame))
 173            (argument1-entry (make-instance 'ltk:entry :text ""
 174                                            :master object-frame))
 175            (argument2-entry (make-instance 'ltk:entry :text ""
 176                                            :master object-frame))
 177            (uxul-button (make-instance 'ltk:button :text ""
 178                                        :master object-frame))
 179            (nasobem-button (make-instance 'ltk:button :text ""
 180                                           :master object-frame))
 181            (blue-nasobem-button (make-instance 'ltk:button :text ""
 182                                                :master object-frame))
 183            (burning-marshmallow-button (make-instance 'ltk:button :text ""
 184                                                       :master object-frame))
 185            (gray-stone-button (make-instance 'ltk:button :text ""
 186                                              :master object-frame))
 187            (brown-stone-button (make-instance 'ltk:button :text ""
 188                                        :master object-frame))
 189            (empty-button (make-instance 'ltk:button :text ""
 190                                         :master object-frame))
 191            (tulip-button (make-instance 'ltk:button :text ""
 192                                         :master object-frame))
 193            (leaf-button (make-instance 'ltk:button :text ""
 194                                        :master object-frame))
 195            (key-button (make-instance 'ltk:button :text ""
 196                                        :master object-frame))
 197            (door-button (make-instance 'ltk:button :text ""
 198                                        :master object-frame))
 199            (anchor-button (make-instance 'ltk:button :text ""
 200                                          :master object-frame))
 201            (info-button (make-instance 'ltk:button :text "Info"
 202                                        :master object-frame))
 203            (btns (make-array (list width height) :adjustable nil :element-type 'ltk:button)))
 204         (labels ((redraw-button (i j)
 205                    "Redraw Button (i, j)"
 206                    (let* ((current-upper-x (car current-upper-left))
 207                           (current-upper-y (cdr current-upper-left))
 208                           (cval (gethash (cons (+ i current-upper-x)
 209                                                (+ j current-upper-y))
 210                                         item-table nil))
 211                           (cval2 nil)
 212                          (cbtn (aref btns i j)))
 213                      (when (listp cval)
 214                        (setf cval2 cval)
 215                        (setf cval (car cval)))
 216                      (cond
 217                        ((eq cval 'uxul-world::leaf)
 218                         (config-button-image cbtn leaf))
 219                        ((eq cval 'uxul-world::nasobem)
 220                         (config-button-image cbtn nasobem))
 221                        ((eq cval 'uxul-world::blue-nasobem)
 222                         (config-button-image cbtn blue-nasobem))
 223                        ((eq cval 'uxul-world::burning-marshmallow)
 224                         (config-button-image cbtn burning-marshmallow))
 225                        ((eq cval 'uxul-world::gray-stone)
 226                         (config-button-image cbtn gray-stone))
 227                        ((eq cval 'uxul-world::brown-stone)
 228                         (config-button-image cbtn brown-stone))
 229                        ((eq cval nil)
 230                         (config-button-image cbtn empty))
 231                        ((eq cval 'uxul-world::tulip)
 232                         (config-button-image cbtn tulip))
 233                        ((eq cval 'uxul-world::door)
 234                         (config-button-image cbtn door))
 235                        ((eq cval 'uxul-world::key)
 236                         (config-button-image cbtn key))
 237                        ((eq cval 'uxul-world::anchor)
 238                         (config-button-image cbtn (gethash (cadr cval2) anchors)))
 239                        ((eq cval 'uxul-world::uxul)
 240                         (config-button-image cbtn uxul)))))
 241                  (redraw-buttons ()
 242                    "Redraw all Buttons"
 243                      (dotimes (i width)
 244                        (dotimes (j height)
 245                          (redraw-button i j))))
 246                  (react (i j)
 247                    (let ((current-upper-x (car current-upper-left))
 248                          (current-upper-y (cdr current-upper-left)))
 249                      (cond
 250                        ((eql current-chosen-object :info)
 251                         (let ((sym (gethash (cons (+ i current-upper-x)
 252                                           (+ j current-upper-y))
 253                                     item-table nil)))
 254                           (if sym
 255                               (ltk:do-msg
 256                                   (format nil (concatenate 'string
 257                                                            "Symbolname: \"" (symbol-name (car sym)) "\"~%"
 258                                                            "First argument: \"" (cadr sym) "\"~%"
 259                                                            "Second argument: \"" (caddr sym) "\"")))
 260                               (ltk:do-msg "There doesnt seem to be anything here."))
 261                           (return-from react)))
 262                        ((eql current-chosen-object 'uxul-world::anchor)
 263                         (cond
 264                           ((string= (ltk:text argument1-entry) "")
 265                            (ltk:do-msg "Please give an argument in the left textbox")
 266                            (return-from react))
 267                           ((gethash (ltk:text argument1-entry) anchors nil)
 268                            (ltk:do-msg "Warning: You already set an
 269                            anchor with the same dungeon-name. Make
 270                            sure that you remove one of them. Behavior
 271                            is not specified in this case and may
 272                            change."))
 273                           (t
 274                            (setf (gethash (ltk:text argument1-entry) anchors)
 275                                  (load-image-into-tk (annotated-image (gethash 'uxul-world::anchor *leveleditor-images*) (ltk:text argument1-entry))))))))
 276                      (setf (gethash (cons (+ i current-upper-x)
 277                                           (+ j current-upper-y))
 278                                     item-table)
 279                            (and current-chosen-object
 280                                 (list current-chosen-object (ltk:text argument1-entry) (ltk:text argument2-entry))))
 281                      (redraw-button i j)))
 282                  (move-field-about (i j)
 283                    (let ((current-upper-y (car current-upper-left))
 284                          (current-upper-x (cdr current-upper-left)))
 285                      (setf current-upper-left (cons (+ i current-upper-y) (+ j current-upper-x))))
 286                    (redraw-buttons)))
 287           (ltk:pack grid-frame)
 288           (ltk:grid arrow-frame 0 1)
 289           (ltk:grid left-button 1 0)
 290           (setf (ltk:command left-button) #'(lambda () (move-field-about 0 1)))
 291           (ltk:grid lleft-button 2 0)
 292           (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 (- width 1))))
 293           (ltk:grid right-button 1 2)
 294           (setf (ltk:command right-button) #'(lambda () (move-field-about 0 -1)))
 295           (ltk:grid rright-button 0 2)
 296           (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 (- 1 width))))
 297           (ltk:grid up-button 0 1)
 298           (setf (ltk:command up-button) #'(lambda () (move-field-about 1 0)))
 299           (ltk:grid uup-button 0 0)
 300           (setf (ltk:command uup-button) #'(lambda () (move-field-about (- width 1) 0)))
 301           (ltk:grid down-button 2 1)
 302           (setf (ltk:command down-button) #'(lambda () (move-field-about -1 0)))
 303           (ltk:grid ddown-button 2 2)
 304           (setf (ltk:command ddown-button) #'(lambda () (move-field-about (- 1 width) 0)))
 305
 306           (ltk:grid argument1-entry 1 0 :columnspan 4)
 307           (ltk:grid argument2-entry 1 5 :columnspan 4)
 308           (ltk:grid info-button 1 9 :columnspan 2)
 309           (setf (ltk:command info-button)
 310                 #'(lambda () (setf current-chosen-object :info)))
 311
 312           (ltk:grid empty-button 0 0)
 313           (config-button-image empty-button empty)
 314           (setf (ltk:command empty-button)
 315                              #'(lambda ()
 316                                  (setf current-chosen-object nil)))
 317           (ltk:grid uxul-button 0 1)
 318           (config-button-image uxul-button uxul)
 319           (setf (ltk:command uxul-button)
 320                              #'(lambda ()
 321                                  (setf current-chosen-object 'uxul-world::uxul)))
 322           (ltk:grid nasobem-button 0 2)
 323           (config-button-image nasobem-button nasobem)
 324           (setf (ltk:command nasobem-button)
 325                              #'(lambda ()
 326                                  (setf current-chosen-object 'uxul-world::nasobem)))
 327           (ltk:grid blue-nasobem-button 0 3)
 328           (config-button-image blue-nasobem-button blue-nasobem)
 329           (setf (ltk:command blue-nasobem-button)
 330                              #'(lambda ()
 331                                  (setf current-chosen-object 'uxul-world::blue-nasobem)))
 332           (ltk:grid burning-marshmallow-button 0 4)
 333           (config-button-image burning-marshmallow-button burning-marshmallow)
 334           (setf (ltk:command burning-marshmallow-button)
 335                              #'(lambda ()
 336                                  (setf current-chosen-object 'uxul-world::burning-marshmallow)))
 337           (ltk:grid gray-stone-button 0 5)
 338           (config-button-image gray-stone-button gray-stone)
 339           (setf (ltk:command gray-stone-button)
 340                              #'(lambda ()
 341                                  (setf current-chosen-object 'uxul-world::gray-stone)))
 342           (ltk:grid brown-stone-button 0 6)
 343           (config-button-image brown-stone-button brown-stone)
 344           (setf (ltk:command brown-stone-button)
 345                              #'(lambda ()
 346                                  (setf current-chosen-object 'uxul-world::brown-stone)))
 347           (ltk:grid leaf-button 0 7)
 348           (config-button-image leaf-button leaf)
 349           (setf (ltk:command leaf-button)
 350                              #'(lambda ()
 351                                  (setf current-chosen-object 'uxul-world::leaf)))
 352
 353           (ltk:grid tulip-button 0 8)
 354           (config-button-image tulip-button tulip)
 355           (setf (ltk:command tulip-button)
 356                              #'(lambda ()
 357                                  (setf current-chosen-object 'uxul-world::tulip)))
 358
 359           (ltk:grid key-button 0 9)
 360           (config-button-image key-button key)
 361           (setf (ltk:command key-button)
 362                              #'(lambda ()
 363                                  (setf current-chosen-object 'uxul-world::key)))
 364
 365           (ltk:grid door-button 0 10)
 366           (config-button-image door-button door)
 367           (setf (ltk:command door-button)
 368                              #'(lambda ()
 369                                  (setf current-chosen-object 'uxul-world::door)))
 370
 371           (ltk:grid anchor-button 0 11)
 372           (config-button-image anchor-button anchor)
 373           (setf (ltk:command anchor-button)
 374                              #'(lambda ()
 375                                  (setf current-chosen-object 'uxul-world::anchor)))
 376
 377           (ltk:grid object-frame 0 0)
 378           (ltk:pack objects-and-arrows)
 379
 380           (dotimes (i width)
 381             (dotimes (j height)
 382               (let ((cbtn
 383                      (make-instance 'ltk:button
 384                                     :master grid-frame
 385                                     :text "")))
 386                 (setf (ltk:command cbtn) (let ((i i) (j j)) #'(lambda () (react i j))))
 387                 (config-button-image cbtn empty)
 388                 (setf (aref btns i j) cbtn)
 389                 (ltk:grid cbtn i j))))
 390           (redraw-buttons))))
 391     (item-table-to-list item-table)))
 392
 393
 394 (defun get-base64-char-for-number (i)
 395   (declare (type (integer 0 63) i))
 396   (elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" i))
 397
 398 (defun base64-encode-threebytes (byte1 byte2 byte3)
 399   (declare (type (unsigned-byte 8) byte1 byte2 byte3))
 400   (coerce
 401    (list
 402     (get-base64-char-for-number (logand #b111111 (ash byte1 -2)))
 403     (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte1 6) -2) (ash byte2 -4))))
 404     (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte2 4) -2) (ash byte3 -6))))
 405     (get-base64-char-for-number (logand #b111111 (ash (ash byte3 2) -2)))) 'string))
 406
 407
 408 (defun base64-encode-bytelist (bytelist &optional (ret ""))
 409   (if bytelist
 410       (if (cdr bytelist)
 411           (if (cddr bytelist)
 412               (base64-encode-bytelist
 413                (cdddr bytelist)
 414                (concatenate 'string
 415                             ret
 416                             (base64-encode-threebytes
 417                              (car bytelist)
 418                              (cadr bytelist)
 419                              (caddr bytelist))))
 420               ;;else (genau zwei elemente)
 421               (concatenate 'string ret
 422                            (base64-encode-threebytes
 423                             (car bytelist)
 424                             (cadr bytelist)
 425                             0)
 426                            "="))
 427           ;;else (genau ein element)
 428           (concatenate 'string ret
 429                        (base64-encode-threebytes
 430                         (car bytelist) 0 0)
 431                        "=="))
 432       ;;else (kein element)
 433       ret))
 434
 435
 436 (defun base64-encode-byteseq (byteseq &optional (ret ""))
 437   (case (length byteseq)
 438     (0 ret)
 439     (1 (concatenate 'string ret
 440                     (base64-encode-threebytes
 441                      (elt byteseq 0) 0 0) "=="))
 442     (2 (concatenate 'string ret
 443                     (base64-encode-threebytes
 444                      (elt byteseq 0)
 445                      (elt byteseq 1)
 446                      0)
 447                     "="))
 448     (t (base64-encode-byteseq
 449         (subseq byteseq 3)
 450         (concatenate 'string
 451                      ret
 452                      (base64-encode-threebytes
 453                       (elt byteseq 0)
 454                       (elt byteseq 1)
 455                       (elt byteseq 2)))))))