(defparameter *leveleditor-images* nil)
-(defun stretched-base64-image (img)
+(defun stretched-image (img)
"Call ImageMagick to resize that file to 32x32."
(lisp-magick:with-magick-wand (mywand)
(lisp-magick::magick-read-image-blob mywand img)
(lisp-magick::magick-resize-image mywand 32 32 #x00000000 1d0)
(lisp-magick::magick-set-format mywand "gif")
- (base64-encode-byteseq (lisp-magick::magick-get-image-blob mywand))))
+ (lisp-magick::magick-get-image-blob mywand)))
-(defun prepare-base64-images (&optional (care-about-initialization *leveleditor-images*))
+(defun annotated-image (img ann)
+ "Add a (lower-left) annotation."
+ (lisp-magick:with-magick-wand (mywand)
+ (lisp-magick::magick-read-image-blob mywand img)
+ (lisp-magick:with-drawing-wand (dw)
+ (lisp-magick:with-pixel-wand (pw :comp (255 255 255))
+ (lisp-magick::draw-set-text-under-color dw pw))
+ (lisp-magick:with-pixel-wand (pw :comp (255 0 0))
+ (lisp-magick::draw-set-fill-color dw pw))
+ (lisp-magick:draw-annotation dw (coerce 0 'double-float) (coerce 32 'double-float) ann)
+ (lisp-magick:magick-draw-image mywand dw))
+ (lisp-magick::magick-set-format mywand "gif")
+ (lisp-magick::magick-get-image-blob mywand)))
+
+(defun numbered-image (img num)
+ "Annotate the image with a number."
+ (annotated-image img (format nil "~d" num)))
+
+(defun prepare-images (&optional (care-about-initialization *leveleditor-images*))
(when (not care-about-initialization)
(setf *leveleditor-images* (make-hash-table))
- (setf (gethash 'uxul-world::uxul *leveleditor-images*) (stretched-base64-image uxul-world::|uxul_small1|))
- (setf (gethash 'uxul-world::leaf *leveleditor-images*) (stretched-base64-image uxul-world::|leaf|))
- (setf (gethash 'uxul-world::nasobem *leveleditor-images*) (stretched-base64-image uxul-world::|nasobem|))
- (setf (gethash 'uxul-world::blue-nasobem *leveleditor-images*) (stretched-base64-image uxul-world::|blue_nasobem|))
- (setf (gethash 'uxul-world::burning-marshmallow *leveleditor-images*) (stretched-base64-image uxul-world::|burning_marshmallow_ld1|))
- (setf (gethash 'uxul-world::gray-stone *leveleditor-images*) (stretched-base64-image uxul-world::|gray_stone|))
- (setf (gethash 'uxul-world::brown-stone *leveleditor-images*) (stretched-base64-image uxul-world::|brown_stone|))
- (setf (gethash 'uxul-world::empty *leveleditor-images*) (stretched-base64-image uxul-world::|empty|))
- (setf (gethash 'uxul-world::tulip *leveleditor-images*) (stretched-base64-image uxul-world::|tulip|))))
+ (setf (gethash 'uxul-world::uxul *leveleditor-images*) (stretched-image uxul-world::|uxul_small1|))
+ (setf (gethash 'uxul-world::leaf *leveleditor-images*) (stretched-image uxul-world::|leaf|))
+ (setf (gethash 'uxul-world::nasobem *leveleditor-images*) (stretched-image uxul-world::|nasobem|))
+ (setf (gethash 'uxul-world::blue-nasobem *leveleditor-images*) (stretched-image uxul-world::|blue_nasobem|))
+ (setf (gethash 'uxul-world::burning-marshmallow *leveleditor-images*) (stretched-image uxul-world::|burning_marshmallow_ld1|))
+ (setf (gethash 'uxul-world::gray-stone *leveleditor-images*) (stretched-image uxul-world::|gray_stone|))
+ (setf (gethash 'uxul-world::brown-stone *leveleditor-images*) (stretched-image uxul-world::|brown_stone|))
+ (setf (gethash 'uxul-world::empty *leveleditor-images*) (stretched-image uxul-world::|empty|))
+ (setf (gethash 'uxul-world::tulip *leveleditor-images*) (stretched-image uxul-world::|tulip|))
+ (setf (gethash 'uxul-world::door *leveleditor-images*) (stretched-image uxul-world::|door|))
+ (setf (gethash 'uxul-world::key *leveleditor-images*) (stretched-image uxul-world::|key|))
+))
-(defun load-image-into-tk (png-base64)
+(defun load-image-into-tk (png)
"return a tkobject with this image"
(let ((name (ltk::create-name)))
(ltk:format-wish "set ~A [ image create photo -data \"~A\" ]"
- name png-base64)
+ name (base64-encode-byteseq png))
(make-instance 'ltk:tkobject :name name)))
(defun config-button-image (button tkobject)
(ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject)))
(defun item-table-to-list (item-table)
- "Special Function vor level-editor. Returns a list of lists of the
-form (x y object)."
+ "Special Function for level-editor. Returns a list of lists of the
+form (x y object arg1 arg2 ...)."
(let ((ret nil))
(maphash #'(lambda (key val)
(when val
ret))
(defun level-editor (&optional (level nil) (width 16) (height 16))
- (declare (type '(integer 0 100) width height))
- (prepare-base64-images)
+ (prepare-images)
(let ((item-table (make-hash-table :test 'equal)))
;;initialize given level
(dolist (item level)
(brown-stone (load-image-into-tk (gethash 'uxul-world::brown-stone *leveleditor-images*)))
(empty (load-image-into-tk (gethash 'uxul-world::empty *leveleditor-images*)))
(tulip (load-image-into-tk (gethash 'uxul-world::tulip *leveleditor-images*)))
+ (key (load-image-into-tk (gethash 'uxul-world::key *leveleditor-images*)))
+ (door (load-image-into-tk (gethash 'uxul-world::door *leveleditor-images*)))
(current-upper-left (cons 0 0))
(current-chosen-object 'uxul)
(objects-and-arrows (make-instance 'ltk:frame))
+ (grid-frame (make-instance 'ltk:frame))
(object-frame (make-instance 'ltk:frame :master objects-and-arrows))
(arrow-frame (make-instance 'ltk:frame :master objects-and-arrows))
- (grid-frame (make-instance 'ltk:frame))
(right-button (make-instance 'ltk:button :text ">"
:master arrow-frame))
(left-button (make-instance 'ltk:button :text "<"
:master object-frame))
(leaf-button (make-instance 'ltk:button :text ""
:master object-frame))
+ (key-button (make-instance 'ltk:button :text ""
+ :master object-frame))
+ (door-button (make-instance 'ltk:button :text ""
+ :master object-frame))
(btns (make-array (list width height) :adjustable nil :element-type 'ltk:button)))
(labels ((redraw-button (i j)
"Redraw Button (i, j)"
(config-button-image cbtn empty))
((eq cval 'uxul-world::tulip)
(config-button-image cbtn tulip))
+ ((eq cval 'uxul-world::door)
+ (config-button-image cbtn door))
+ ((eq cval 'uxul-world::key)
+ (config-button-image cbtn key))
((eq cval 'uxul-world::uxul)
(config-button-image cbtn uxul)))))
(redraw-buttons ()
(let ((current-upper-x (car current-upper-left))
(current-upper-y (cdr current-upper-left)))
(cond
- ((eq current-chosen-object 'burning-marshmallow)
+ ((eq current-chosen-object 'uxul-world::burning-marshmallow)
(setf (gethash (cons (+ i current-upper-x)
(+ j current-upper-y))
- item-table) 'burning-marshmallow))
+ item-table) 'uxul-world::burning-marshmallow))
(t
(setf (gethash (cons (+ i current-upper-x)
(+ j current-upper-y))
(ltk:grid left-button 1 0)
(setf (ltk:command left-button) #'(lambda () (move-field-about 0 1)))
(ltk:grid lleft-button 2 0)
- (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 15)))
+ (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 (- width 1))))
(ltk:grid right-button 1 2)
(setf (ltk:command right-button) #'(lambda () (move-field-about 0 -1)))
(ltk:grid rright-button 0 2)
- (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 -15)))
+ (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 (- 1 width))))
(ltk:grid up-button 0 1)
(setf (ltk:command up-button) #'(lambda () (move-field-about 1 0)))
(ltk:grid uup-button 0 0)
- (setf (ltk:command uup-button) #'(lambda () (move-field-about 15 0)))
+ (setf (ltk:command uup-button) #'(lambda () (move-field-about (- width 1) 0)))
(ltk:grid down-button 2 1)
(setf (ltk:command down-button) #'(lambda () (move-field-about -1 0)))
(ltk:grid ddown-button 2 2)
- (setf (ltk:command ddown-button) #'(lambda () (move-field-about -15 0)))
+ (setf (ltk:command ddown-button) #'(lambda () (move-field-about (- 1 width) 0)))
(ltk:grid empty-button 0 0)
(config-button-image empty-button empty)
#'(lambda ()
(setf current-chosen-object 'uxul-world::tulip)))
+ (ltk:grid key-button 0 9)
+ (config-button-image key-button key)
+ (setf (ltk:command key-button)
+ #'(lambda ()
+ (setf current-chosen-object 'uxul-world::key)))
+
+ (ltk:grid door-button 0 10)
+ (config-button-image door-button door)
+ (setf (ltk:command door-button)
+ #'(lambda ()
+ (setf current-chosen-object 'uxul-world::door)))
+
(ltk:grid object-frame 0 0)
(ltk:pack objects-and-arrows)
projects / uxul-world.git / blobdiff