1 ;;; Copyright 2009 Christoph Senjak
3 (in-package :uxul-world-leveleditor)
5 (defparameter *leveleditor-images* nil)
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))))
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|))))
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\" ]"
33 (make-instance 'ltk:tkobject :name name)))
35 (defun config-button-image (button tkobject)
36 (ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject)))
38 (defun item-table-to-list (item-table)
39 "Special Function vor level-editor. Returns a list of lists of the
42 (maphash #'(lambda (key val)
44 (push (list (car key) (cdr key) val) ret)))
48 (defun level-editor (&optional (level nil) (width 16) (height 16))
49 (declare (type '(integer 0 100) width height))
50 (prepare-base64-images)
51 (let ((item-table (make-hash-table :test 'equal)))
52 ;;initialize given level
54 (setf (gethash (cons (car item) (cadr item)) item-table) (caddr item)))
58 ((uxul (load-image-into-tk (gethash 'uxul-world::uxul *leveleditor-images*)))
59 (leaf (load-image-into-tk (gethash 'uxul-world::leaf *leveleditor-images*)))
60 (nasobem (load-image-into-tk (gethash 'uxul-world::nasobem *leveleditor-images*)))
61 (blue-nasobem (load-image-into-tk (gethash 'uxul-world::blue-nasobem *leveleditor-images*)))
62 (burning-marshmallow (load-image-into-tk (gethash 'uxul-world::burning-marshmallow *leveleditor-images*)))
63 (gray-stone (load-image-into-tk (gethash 'uxul-world::gray-stone *leveleditor-images*)))
64 (brown-stone (load-image-into-tk (gethash 'uxul-world::brown-stone *leveleditor-images*)))
65 (empty (load-image-into-tk (gethash 'uxul-world::empty *leveleditor-images*)))
66 (tulip (load-image-into-tk (gethash 'uxul-world::tulip *leveleditor-images*)))
67 (current-upper-left (cons 0 0))
68 (current-chosen-object 'uxul)
69 (objects-and-arrows (make-instance 'ltk:frame))
70 (object-frame (make-instance 'ltk:frame :master objects-and-arrows))
71 (arrow-frame (make-instance 'ltk:frame :master objects-and-arrows))
72 (grid-frame (make-instance 'ltk:frame))
73 (right-button (make-instance 'ltk:button :text ">"
75 (left-button (make-instance 'ltk:button :text "<"
77 (up-button (make-instance 'ltk:button :text "/\\"
79 (down-button (make-instance 'ltk:button :text "\\/"
81 (rright-button (make-instance 'ltk:button :text ">>"
83 (lleft-button (make-instance 'ltk:button :text "<<"
85 (uup-button (make-instance 'ltk:button :text "//\\\\"
87 (ddown-button (make-instance 'ltk:button :text "\\\\//"
89 (uxul-button (make-instance 'ltk:button :text ""
90 :master object-frame))
91 (nasobem-button (make-instance 'ltk:button :text ""
92 :master object-frame))
93 (blue-nasobem-button (make-instance 'ltk:button :text ""
94 :master object-frame))
95 (burning-marshmallow-button (make-instance 'ltk:button :text ""
96 :master object-frame))
97 (gray-stone-button (make-instance 'ltk:button :text ""
98 :master object-frame))
99 (brown-stone-button (make-instance 'ltk:button :text ""
100 :master object-frame))
101 (empty-button (make-instance 'ltk:button :text ""
102 :master object-frame))
103 (tulip-button (make-instance 'ltk:button :text ""
104 :master object-frame))
105 (leaf-button (make-instance 'ltk:button :text ""
106 :master object-frame))
107 (btns (make-array (list width height) :adjustable nil :element-type 'ltk:button)))
108 (labels ((redraw-button (i j)
109 "Redraw Button (i, j)"
110 (let* ((current-upper-x (car current-upper-left))
111 (current-upper-y (cdr current-upper-left))
112 (cval (gethash (cons (+ i current-upper-x)
113 (+ j current-upper-y))
115 (cbtn (aref btns i j)))
117 (setf cval (car cval)))
119 ((eq cval 'uxul-world::leaf)
120 (config-button-image cbtn leaf))
121 ((eq cval 'uxul-world::nasobem)
122 (config-button-image cbtn nasobem))
123 ((eq cval 'uxul-world::blue-nasobem)
124 (config-button-image cbtn blue-nasobem))
125 ((eq cval 'uxul-world::burning-marshmallow)
126 (config-button-image cbtn burning-marshmallow))
127 ((eq cval 'uxul-world::gray-stone)
128 (config-button-image cbtn gray-stone))
129 ((eq cval 'uxul-world::brown-stone)
130 (config-button-image cbtn brown-stone))
132 (config-button-image cbtn empty))
133 ((eq cval 'uxul-world::tulip)
134 (config-button-image cbtn tulip))
135 ((eq cval 'uxul-world::uxul)
136 (config-button-image cbtn uxul)))))
141 (redraw-button i j))))
143 (let ((current-upper-x (car current-upper-left))
144 (current-upper-y (cdr current-upper-left)))
146 ((eq current-chosen-object 'burning-marshmallow)
147 (setf (gethash (cons (+ i current-upper-x)
148 (+ j current-upper-y))
149 item-table) 'burning-marshmallow))
151 (setf (gethash (cons (+ i current-upper-x)
152 (+ j current-upper-y))
153 item-table) current-chosen-object)))
154 (redraw-button i j)))
155 (move-field-about (i j)
156 (let ((current-upper-y (car current-upper-left))
157 (current-upper-x (cdr current-upper-left)))
158 (setf current-upper-left (cons (+ i current-upper-y) (+ j current-upper-x))))
160 (ltk:pack grid-frame)
161 (ltk:grid arrow-frame 0 1)
162 (ltk:grid left-button 1 0)
163 (setf (ltk:command left-button) #'(lambda () (move-field-about 0 1)))
164 (ltk:grid lleft-button 2 0)
165 (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 15)))
166 (ltk:grid right-button 1 2)
167 (setf (ltk:command right-button) #'(lambda () (move-field-about 0 -1)))
168 (ltk:grid rright-button 0 2)
169 (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 -15)))
170 (ltk:grid up-button 0 1)
171 (setf (ltk:command up-button) #'(lambda () (move-field-about 1 0)))
172 (ltk:grid uup-button 0 0)
173 (setf (ltk:command uup-button) #'(lambda () (move-field-about 15 0)))
174 (ltk:grid down-button 2 1)
175 (setf (ltk:command down-button) #'(lambda () (move-field-about -1 0)))
176 (ltk:grid ddown-button 2 2)
177 (setf (ltk:command ddown-button) #'(lambda () (move-field-about -15 0)))
179 (ltk:grid empty-button 0 0)
180 (config-button-image empty-button empty)
181 (setf (ltk:command empty-button)
183 (setf current-chosen-object nil)))
184 (ltk:grid uxul-button 0 1)
185 (config-button-image uxul-button uxul)
186 (setf (ltk:command uxul-button)
188 (setf current-chosen-object 'uxul-world::uxul)))
189 (ltk:grid nasobem-button 0 2)
190 (config-button-image nasobem-button nasobem)
191 (setf (ltk:command nasobem-button)
193 (setf current-chosen-object 'uxul-world::nasobem)))
194 (ltk:grid blue-nasobem-button 0 3)
195 (config-button-image blue-nasobem-button blue-nasobem)
196 (setf (ltk:command blue-nasobem-button)
198 (setf current-chosen-object 'uxul-world::blue-nasobem)))
199 (ltk:grid burning-marshmallow-button 0 4)
200 (config-button-image burning-marshmallow-button burning-marshmallow)
201 (setf (ltk:command burning-marshmallow-button)
203 (setf current-chosen-object 'uxul-world::burning-marshmallow)))
204 (ltk:grid gray-stone-button 0 5)
205 (config-button-image gray-stone-button gray-stone)
206 (setf (ltk:command gray-stone-button)
208 (setf current-chosen-object 'uxul-world::gray-stone)))
209 (ltk:grid brown-stone-button 0 6)
210 (config-button-image brown-stone-button brown-stone)
211 (setf (ltk:command brown-stone-button)
213 (setf current-chosen-object 'uxul-world::brown-stone)))
214 (ltk:grid leaf-button 0 7)
215 (config-button-image leaf-button leaf)
216 (setf (ltk:command leaf-button)
218 (setf current-chosen-object 'uxul-world::leaf)))
220 (ltk:grid tulip-button 0 8)
221 (config-button-image tulip-button tulip)
222 (setf (ltk:command tulip-button)
224 (setf current-chosen-object 'uxul-world::tulip)))
226 (ltk:grid object-frame 0 0)
227 (ltk:pack objects-and-arrows)
232 (make-instance 'ltk:button
235 (setf (ltk:command cbtn) (let ((i i) (j j)) #'(lambda () (react i j))))
236 (config-button-image cbtn empty)
237 (setf (aref btns i j) cbtn)
238 (ltk:grid cbtn i j))))
240 (item-table-to-list item-table)))
243 (defun get-base64-char-for-number (i)
244 (declare (type (integer 0 63) i))
245 (elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" i))
247 (defun base64-encode-threebytes (byte1 byte2 byte3)
248 (declare (type (unsigned-byte 8) byte1 byte2 byte3))
251 (get-base64-char-for-number (logand #b111111 (ash byte1 -2)))
252 (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte1 6) -2) (ash byte2 -4))))
253 (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte2 4) -2) (ash byte3 -6))))
254 (get-base64-char-for-number (logand #b111111 (ash (ash byte3 2) -2)))) 'string))
257 (defun base64-encode-bytelist (bytelist &optional (ret ""))
261 (base64-encode-bytelist
265 (base64-encode-threebytes
269 ;;else (genau zwei elemente)
270 (concatenate 'string ret
271 (base64-encode-threebytes
276 ;;else (genau ein element)
277 (concatenate 'string ret
278 (base64-encode-threebytes
281 ;;else (kein element)
285 (defun base64-encode-byteseq (byteseq &optional (ret ""))
286 (case (length byteseq)
288 (1 (concatenate 'string ret
289 (base64-encode-threebytes
290 (elt byteseq 0) 0 0) "=="))
291 (2 (concatenate 'string ret
292 (base64-encode-threebytes
297 (t (base64-encode-byteseq
301 (base64-encode-threebytes
304 (elt byteseq 2)))))))