leveleditor.lisp

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