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