leveleditor.lisp

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