1 ;;; Copyright 2009 Christoph Senjak
3 (in-package :uxul-world-leveleditor)
5 (defparameter *leveleditor-images* nil)
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)))
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)))
29 (defun numbered-image (img num)
30 "Annotate the image with a number."
31 (annotated-image img (format nil "~d" num)))
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|))
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)))
56 (defun config-button-image (button tkobject)
57 (ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject)))
59 (defun item-table-to-list (item-table)
60 "Special Function vor level-editor. Returns a list of lists of the
63 (maphash #'(lambda (key val)
65 (push (list (car key) (cdr key) val) ret)))
69 (defun level-editor (&optional (level nil) (width 16) (height 16))
71 (let ((item-table (make-hash-table :test 'equal)))
72 ;;initialize given level
74 (setf (gethash (cons (car item) (cadr item)) item-table) (caddr item)))
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 ">"
97 (left-button (make-instance 'ltk:button :text "<"
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))
141 (cbtn (aref btns i j)))
143 (setf cval (car cval)))
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))
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)))))
171 (redraw-button i j))))
173 (let ((current-upper-x (car current-upper-left))
174 (current-upper-y (cdr current-upper-left)))
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))
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))))
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 15)))
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 -15)))
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 15 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 -15 0)))
209 (ltk:grid empty-button 0 0)
210 (config-button-image empty-button empty)
211 (setf (ltk:command empty-button)
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)
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)
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)
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)
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)
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)
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)
248 (setf current-chosen-object 'uxul-world::leaf)))
250 (ltk:grid tulip-button 0 8)
251 (config-button-image tulip-button tulip)
252 (setf (ltk:command tulip-button)
254 (setf current-chosen-object 'uxul-world::tulip)))
256 (ltk:grid key-button 0 9)
257 (config-button-image key-button key)
258 (setf (ltk:command key-button)
260 (setf current-chosen-object 'uxul-world::key)))
262 (ltk:grid door-button 0 10)
263 (config-button-image door-button door)
264 (setf (ltk:command door-button)
266 (setf current-chosen-object 'uxul-world::door)))
268 (ltk:grid object-frame 0 0)
269 (ltk:pack objects-and-arrows)
274 (make-instance 'ltk:button
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))))
282 (item-table-to-list item-table)))
285 (defun get-base64-char-for-number (i)
286 (declare (type (integer 0 63) i))
287 (elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" i))
289 (defun base64-encode-threebytes (byte1 byte2 byte3)
290 (declare (type (unsigned-byte 8) byte1 byte2 byte3))
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))
299 (defun base64-encode-bytelist (bytelist &optional (ret ""))
303 (base64-encode-bytelist
307 (base64-encode-threebytes
311 ;;else (genau zwei elemente)
312 (concatenate 'string ret
313 (base64-encode-threebytes
318 ;;else (genau ein element)
319 (concatenate 'string ret
320 (base64-encode-threebytes
323 ;;else (kein element)
327 (defun base64-encode-byteseq (byteseq &optional (ret ""))
328 (case (length byteseq)
330 (1 (concatenate 'string ret
331 (base64-encode-threebytes
332 (elt byteseq 0) 0 0) "=="))
333 (2 (concatenate 'string ret
334 (base64-encode-threebytes
339 (t (base64-encode-byteseq
343 (base64-encode-threebytes
346 (elt byteseq 2)))))))