leveleditor.lisp

   1 ;;; Copyright 2009 Christoph Senjak
   2
   3 (in-package :uxul-world)
   4
   5 (defparameter *leveleditor-images* nil)
   6
   7 (defun stretched-base64-image (img)
   8   "Call ImageMagick to resize that file to 32x32."
   9   (lisp-magick:with-magick-wand (mywand)
  10     (lisp-magick::magick-read-image-blob mywand img)
  11     (lisp-magick::magick-resize-image mywand 32 32 #x00000000 1d0)
  12     (lisp-magick::magick-set-format mywand "gif")
  13     (base64-encode-byteseq (lisp-magick::magick-get-image-blob mywand))))
  14
  15 (defun prepare-base64-images (&optional (care-about-initialization *leveleditor-images*))
  16   (when (not care-about-initialization)
  17     (setf *leveleditor-images* (make-hash-table))
  18     (setf (gethash 'uxul *leveleditor-images*) (stretched-base64-image |uxul_small1|))
  19     (setf (gethash 'leaf *leveleditor-images*) (stretched-base64-image |leaf|))
  20     (setf (gethash 'nasobem *leveleditor-images*) (stretched-base64-image |nasobem|))
  21     (setf (gethash 'blue-nasobem *leveleditor-images*) (stretched-base64-image |blue_nasobem|))
  22     (setf (gethash 'burning-marshmallow *leveleditor-images*) (stretched-base64-image |burning_marshmallow_ld1|))
  23     (setf (gethash 'gray-stone *leveleditor-images*) (stretched-base64-image |gray_stone|))
  24     (setf (gethash 'brown-stone *leveleditor-images*) (stretched-base64-image |brown_stone|))
  25     (setf (gethash 'empty *leveleditor-images*) (stretched-base64-image |empty|))
  26     (setf (gethash 'tulip *leveleditor-images*) (stretched-base64-image |tulip|))))
  27
  28 (defun load-image-into-tk (png-base64)
  29   "return a tkobject with this image"
  30   (let ((name (ltk::create-name)))
  31     (ltk:format-wish "set ~A [ image create photo -data \"~A\" ]"
  32                      name png-base64)
  33     (make-instance 'ltk:tkobject :name name)))
  34
  35 (defun config-button-image (button tkobject)
  36   (ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject)))
  37
  38 (defun item-table-to-list (item-table)
  39   "Special Function vor level-editor. Returns a list of lists of the
  40 form (x y object)."
  41   (let ((ret nil))
  42     (maphash #'(lambda (key val)
  43                  (when val
  44                    (push (list (car key) (cdr key) val) ret)))
  45              item-table)
  46     ret))
  47
  48 (defun create-room-from-item-list (item-list)
  49   (let*
  50       ((player (make-instance 'player
  51                                 :active t
  52                                 :visible t
  53                                 :redraw t))
  54        (room (make-instance 'room :width 0 :height 0
  55                             :graphic-centralizer player
  56                             :key-listener player
  57                             :key-up-function #'(lambda (key) (on-key-up player key))
  58                             :key-down-function #'(lambda (key) (on-key-down player key)))))
  59   (dolist (item item-list)
  60     (let ((y (car item))
  61           (x (cadr item))
  62           (type (caddr item)))
  63       (cond
  64         ((eq type 'uxul)
  65          (setf (x player) (* 128 x))
  66          (setf (y player) (* 128 y))
  67          (add-object player room))
  68         ((eq type 'tulip)
  69          (add-object (make-instance 'tulip
  70                                     :x (* 128 x)
  71                                     :y (* 128 y)) room))
  72         ((eq type 'brown-stone)
  73          (add-object (make-instance 'stone
  74                                     :animation (make-animation 0 |brown_stone|)
  75                                     :x (* 128 x)
  76                                     :y (* 128 y)) room))
  77         ((eq type 'gray-stone)
  78          (add-object (make-instance 'stone
  79                                     :animation (make-animation 0 |gray_stone|)
  80                                     :x (* 128 x)
  81                                     :y (* 128 y)) room))
  82         ((eq type 'nasobem)
  83          (add-object (make-instance 'simple-enemy
  84                                     :x (* 128 x)
  85                                     :y (* 128 y)) room))
  86         ((eq type 'blue-nasobem)
  87          (add-object (make-instance 'flying-nasobem
  88                                     :x (* 128 x)
  89                                     :y (* 128 y)) room))
  90         (T
  91          (add-object (make-instance type
  92                                  :x (* 128 x)
  93                                  :y (* 128 y)) room)))))
  94   room))
  95
  96 (defun level-editor (&optional (level nil))
  97   (prepare-base64-images)
  98   (let ((item-table (make-hash-table :test 'equal)))
  99     ;;initialize given level
 100     (dolist (item level)
 101       (setf (gethash (cons (car item) (cadr item)) item-table) (caddr item)))
 102
 103     (ltk:with-ltk ()
 104       (let*
 105           ((uxul (load-image-into-tk (gethash 'uxul *leveleditor-images*)))
 106            (leaf (load-image-into-tk (gethash 'leaf *leveleditor-images*)))
 107            (nasobem (load-image-into-tk (gethash 'nasobem *leveleditor-images*)))
 108            (blue-nasobem (load-image-into-tk (gethash 'blue-nasobem *leveleditor-images*)))
 109            (burning-marshmallow (load-image-into-tk (gethash 'burning-marshmallow *leveleditor-images*)))
 110            (gray-stone (load-image-into-tk (gethash 'gray-stone *leveleditor-images*)))
 111            (brown-stone (load-image-into-tk (gethash 'brown-stone *leveleditor-images*)))
 112            (empty (load-image-into-tk (gethash 'empty *leveleditor-images*)))
 113            (tulip (load-image-into-tk (gethash 'tulip *leveleditor-images*)))
 114            (current-upper-left (cons 0 0))
 115            (current-chosen-object 'uxul)
 116            (objects-and-arrows (make-instance 'ltk:frame))
 117            (object-frame (make-instance 'ltk:frame :master objects-and-arrows))
 118            (arrow-frame (make-instance 'ltk:frame :master objects-and-arrows))
 119            (grid-frame (make-instance 'ltk:frame))
 120            (right-button (make-instance 'ltk:button :text ">"
 121                                         :master arrow-frame))
 122            (left-button (make-instance 'ltk:button :text "<"
 123                                        :master arrow-frame))
 124            (up-button (make-instance 'ltk:button :text "/\\"
 125                                      :master arrow-frame))
 126            (down-button (make-instance 'ltk:button :text "\\/"
 127                                        :master arrow-frame))
 128            (rright-button (make-instance 'ltk:button :text ">>"
 129                                         :master arrow-frame))
 130            (lleft-button (make-instance 'ltk:button :text "<<"
 131                                        :master arrow-frame))
 132            (uup-button (make-instance 'ltk:button :text "//\\\\"
 133                                      :master arrow-frame))
 134            (ddown-button (make-instance 'ltk:button :text "\\\\//"
 135                                        :master arrow-frame))
 136            (uxul-button (make-instance 'ltk:button :text ""
 137                                        :master object-frame))
 138            (nasobem-button (make-instance 'ltk:button :text ""
 139                                           :master object-frame))
 140            (blue-nasobem-button (make-instance 'ltk:button :text ""
 141                                                :master object-frame))
 142            (burning-marshmallow-button (make-instance 'ltk:button :text ""
 143                                                       :master object-frame))
 144            (gray-stone-button (make-instance 'ltk:button :text ""
 145                                              :master object-frame))
 146            (brown-stone-button (make-instance 'ltk:button :text ""
 147                                        :master object-frame))
 148            (empty-button (make-instance 'ltk:button :text ""
 149                                         :master object-frame))
 150            (tulip-button (make-instance 'ltk:button :text ""
 151                                         :master object-frame))
 152            (leaf-button (make-instance 'ltk:button :text ""
 153                                        :master object-frame))
 154            (btns (make-array '(16 16) :adjustable nil :element-type 'ltk:button)))
 155         (labels ((redraw-button (i j)
 156                    "Redraw Button (i, j)"
 157                    (let* ((current-upper-x (car current-upper-left))
 158                           (current-upper-y (cdr current-upper-left))
 159                           (cval (gethash (cons (+ i current-upper-x)
 160                                                (+ j current-upper-y))
 161                                         item-table nil))
 162                          (cbtn (aref btns i j)))
 163                      (if (listp cval)
 164                          (setf cval (car cval)))
 165                      (cond
 166                        ((eq cval 'leaf)
 167                         (config-button-image cbtn leaf))
 168                        ((eq cval 'nasobem)
 169                         (config-button-image cbtn nasobem))
 170                        ((eq cval 'blue-nasobem)
 171                         (config-button-image cbtn blue-nasobem))
 172                        ((eq cval 'burning-marshmallow)
 173                         (config-button-image cbtn burning-marshmallow))
 174                        ((eq cval 'gray-stone)
 175                         (config-button-image cbtn gray-stone))
 176                        ((eq cval 'brown-stone)
 177                         (config-button-image cbtn brown-stone))
 178                        ((eq cval nil)
 179                         (config-button-image cbtn empty))
 180                        ((eq cval 'tulip)
 181                         (config-button-image cbtn tulip))
 182                        ((eq cval 'uxul)
 183                         (config-button-image cbtn uxul)))))
 184                  (redraw-buttons ()
 185                    "Redraw all Buttons"
 186                      (dotimes (i 16)
 187                        (dotimes (j 16)
 188                          (redraw-button i j))))
 189                  (react (i j)
 190                    (let ((current-upper-x (car current-upper-left))
 191                          (current-upper-y (cdr current-upper-left)))
 192                      (cond
 193                        ((eq current-chosen-object 'burning-marshmallow)
 194                         (setf (gethash (cons (+ i current-upper-x)
 195                                              (+ j current-upper-y))
 196                                        item-table) 'burning-marshmallow))
 197                        (t
 198                         (setf (gethash (cons (+ i current-upper-x)
 199                                              (+ j current-upper-y))
 200                                        item-table) current-chosen-object)))
 201                      (redraw-button i j)))
 202                  (move-field-about (i j)
 203                    (let ((current-upper-y (car current-upper-left))
 204                          (current-upper-x (cdr current-upper-left)))
 205                      (setf current-upper-left (cons (+ i current-upper-y) (+ j current-upper-x))))
 206                    (redraw-buttons)))
 207           (ltk:pack grid-frame)
 208           (ltk:grid arrow-frame 0 1)
 209           (ltk:grid left-button 1 0)
 210           (setf (ltk:command left-button) #'(lambda () (move-field-about 0 1)))
 211           (ltk:grid lleft-button 2 0)
 212           (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 15)))
 213           (ltk:grid right-button 1 2)
 214           (setf (ltk:command right-button) #'(lambda () (move-field-about 0 -1)))
 215           (ltk:grid rright-button 0 2)
 216           (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 -15)))
 217           (ltk:grid up-button 0 1)
 218           (setf (ltk:command up-button) #'(lambda () (move-field-about 1 0)))
 219           (ltk:grid uup-button 0 0)
 220           (setf (ltk:command uup-button) #'(lambda () (move-field-about 15 0)))
 221           (ltk:grid down-button 2 1)
 222           (setf (ltk:command down-button) #'(lambda () (move-field-about -1 0)))
 223           (ltk:grid ddown-button 2 2)
 224           (setf (ltk:command ddown-button) #'(lambda () (move-field-about -15 0)))
 225
 226           (ltk:grid empty-button 0 0)
 227           (config-button-image empty-button empty)
 228           (setf (ltk:command empty-button)
 229                              #'(lambda ()
 230                                  (setf current-chosen-object nil)))
 231           (ltk:grid uxul-button 0 1)
 232           (config-button-image uxul-button uxul)
 233           (setf (ltk:command uxul-button)
 234                              #'(lambda ()
 235                                  (setf current-chosen-object 'uxul)))
 236           (ltk:grid nasobem-button 0 2)
 237           (config-button-image nasobem-button nasobem)
 238           (setf (ltk:command nasobem-button)
 239                              #'(lambda ()
 240                                  (setf current-chosen-object 'nasobem)))
 241           (ltk:grid blue-nasobem-button 0 3)
 242           (config-button-image blue-nasobem-button blue-nasobem)
 243           (setf (ltk:command blue-nasobem-button)
 244                              #'(lambda ()
 245                                  (setf current-chosen-object 'blue-nasobem)))
 246           (ltk:grid burning-marshmallow-button 0 4)
 247           (config-button-image burning-marshmallow-button burning-marshmallow)
 248           (setf (ltk:command burning-marshmallow-button)
 249                              #'(lambda ()
 250                                  (setf current-chosen-object 'burning-marshmallow)))
 251           (ltk:grid gray-stone-button 0 5)
 252           (config-button-image gray-stone-button gray-stone)
 253           (setf (ltk:command gray-stone-button)
 254                              #'(lambda ()
 255                                  (setf current-chosen-object 'gray-stone)))
 256           (ltk:grid brown-stone-button 0 6)
 257           (config-button-image brown-stone-button brown-stone)
 258           (setf (ltk:command brown-stone-button)
 259                              #'(lambda ()
 260                                  (setf current-chosen-object 'brown-stone)))
 261           (ltk:grid leaf-button 0 7)
 262           (config-button-image leaf-button leaf)
 263           (setf (ltk:command leaf-button)
 264                              #'(lambda ()
 265                                  (setf current-chosen-object 'leaf)))
 266
 267           (ltk:grid tulip-button 0 8)
 268           (config-button-image tulip-button tulip)
 269           (setf (ltk:command tulip-button)
 270                              #'(lambda ()
 271                                  (setf current-chosen-object 'tulip)))
 272
 273           (ltk:grid object-frame 0 0)
 274           (ltk:pack objects-and-arrows)
 275
 276           (dotimes (i 16)
 277             (dotimes (j 16)
 278               (let ((cbtn
 279                      (make-instance 'ltk:button
 280                                     :master grid-frame
 281                                     :text "")))
 282                 (setf (ltk:command cbtn) (let ((i i) (j j)) #'(lambda () (react i j))))
 283                 (config-button-image cbtn empty)
 284                 (setf (aref btns i j) cbtn)
 285                 (ltk:grid cbtn i j))))
 286           (redraw-buttons))))
 287     (item-table-to-list item-table)))
 288
 289
 290 (defun get-base64-char-for-number (i)
 291   (declare (type (integer 0 63) i))
 292   (elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" i))
 293
 294 (defun base64-encode-threebytes (byte1 byte2 byte3)
 295   (declare (type (unsigned-byte 8) byte1 byte2 byte3))
 296   (coerce
 297    (list
 298     (get-base64-char-for-number (logand #b111111 (ash byte1 -2)))
 299     (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte1 6) -2) (ash byte2 -4))))
 300     (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte2 4) -2) (ash byte3 -6))))
 301     (get-base64-char-for-number (logand #b111111 (ash (ash byte3 2) -2)))) 'string))
 302
 303
 304 (defun base64-encode-bytelist (bytelist &optional (ret ""))
 305   (if bytelist
 306       (if (cdr bytelist)
 307           (if (cddr bytelist)
 308               (base64-encode-bytelist
 309                (cdddr bytelist)
 310                (concatenate 'string
 311                             ret
 312                             (base64-encode-threebytes
 313                              (car bytelist)
 314                              (cadr bytelist)
 315                              (caddr bytelist))))
 316               ;;else (genau zwei elemente)
 317               (concatenate 'string ret
 318                            (base64-encode-threebytes
 319                             (car bytelist)
 320                             (cadr bytelist)
 321                             0)
 322                            "="))
 323           ;;else (genau ein element)
 324           (concatenate 'string ret
 325                        (base64-encode-threebytes
 326                         (car bytelist) 0 0)
 327                        "=="))
 328       ;;else (kein element)
 329       ret))
 330
 331
 332 (defun base64-encode-byteseq (byteseq &optional (ret ""))
 333   (case (length byteseq)
 334     (0 ret)
 335     (1 (concatenate 'string ret
 336                     (base64-encode-threebytes
 337                      (elt byteseq 0) 0 0) "=="))
 338     (2 (concatenate 'string ret
 339                     (base64-encode-threebytes
 340                      (elt byteseq 0)
 341                      (elt byteseq 1)
 342                      0)
 343                     "="))
 344     (t (base64-encode-byteseq
 345         (subseq byteseq 3)
 346         (concatenate 'string
 347                      ret
 348                      (base64-encode-threebytes
 349                       (elt byteseq 0)
 350                       (elt byteseq 1)
 351                       (elt byteseq 2)))))))