-;;; Copyright 2009 Christoph Senjak
+;;; Copyright 2009-2011 Christoph Senjak
-(in-package :uxul-world)
+(in-package :uxul-world-leveleditor)
(defparameter *leveleditor-images* nil)
-(defun stretched-base64-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))))
+(defun bmp-to-gif (inblob)
+ "Convert BMP to Grayscale-Gif using skippy."
+ (let*
+ ((w (uxul-world::bmp-width inblob))
+ (h (uxul-world::bmp-height inblob))
+ (img (uxul-world::bmp-pixel-data inblob))
+ (color-table (skippy:make-color-table))
+ (colors
+ (let
+ ((v (make-array '(256) :adjustable nil)))
+ (dotimes (i 256)
+ (setf (elt v i)
+ (skippy:ensure-color (skippy:rgb-color i i i) color-table)))
+ v))
+ (grayscale (lambda (x)
+ ;; 0 becomes transparent
+ (cond
+ ((< (elt x 3) 128) 0)
+ (t (max 1
+ (round
+ (/ (+ (elt x 1) (elt x 2) (elt x 0)) 3)))))))
+ (image-data
+ (let ((id (skippy:make-image-data w h)))
+ (dotimes (i w)
+ (dotimes (j h)
+ (setf (elt id (+ i (* w (- h j 1))))
+ (elt colors
+ (funcall grayscale
+ (make-array '(4)
+ :element-type '(unsigned-byte 8)
+ :displaced-to img
+ :displaced-index-offset
+ (* 4 (+ i (* w j)))))))))
+ id))
+ (image (skippy:make-image :width w :height h
+ :image-data image-data
+ :transparency-index 0))
+ (data-stream (skippy:make-data-stream
+ :height h :width w
+ :color-table color-table)))
+ (skippy:add-image image data-stream)
+ (flexi-streams:with-output-to-sequence (out)
+ (skippy:write-data-stream data-stream out))))
+
+
+(defun stretched-image (imgs)
+ "Resize that image to 32x32 and convert it into a ppm."
+ (bmp-to-gif
+ (uxul-world::resize-bmp-blob imgs 32 32)))
+
+(defun annotated-image (img ann)
+ "Add a (lower-left) annotation."
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;FIXME
+img
+
+;; (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-base64-images (&optional (care-about-initialization *leveleditor-images*))
+(defun prepare-images (&optional (care-about-initialization *leveleditor-images*))
(when (not care-about-initialization)
(setf *leveleditor-images* (make-hash-table))
- (setf (gethash 'uxul *leveleditor-images*) (stretched-base64-image |uxul_small1|))
- (setf (gethash 'leaf *leveleditor-images*) (stretched-base64-image |leaf|))
- (setf (gethash 'nasobem *leveleditor-images*) (stretched-base64-image |nasobem|))
- (setf (gethash 'blue-nasobem *leveleditor-images*) (stretched-base64-image |blue_nasobem|))
- (setf (gethash 'burning-marshmallow *leveleditor-images*) (stretched-base64-image |burning_marshmallow_ld1|))
- (setf (gethash 'gray-stone *leveleditor-images*) (stretched-base64-image |gray_stone|))
- (setf (gethash 'brown-stone *leveleditor-images*) (stretched-base64-image |brown_stone|))
- (setf (gethash 'empty *leveleditor-images*) (stretched-base64-image |empty|))
- (setf (gethash 'tulip *leveleditor-images*) (stretched-base64-image |tulip|))))
+ (uxul-world::init-files)
+ (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|))
+ (setf (gethash 'uxul-world::anchor *leveleditor-images*) (stretched-image uxul-world::|anchor|))
+))
-(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
- (push (list (car key) (cdr key) val) ret)))
+ (push (concatenate 'list (list (car key) (cdr key)) val) ret)))
item-table)
ret))
-(defun create-room-from-item-list (item-list)
- (let*
- ((player (make-instance 'player
- :active t
- :visible t
- :redraw t))
- (room (make-instance 'room :width 0 :height 0
- :graphic-centralizer player
- :key-listener player
- :key-up-function #'(lambda (key) (on-key-up player key))
- :key-down-function #'(lambda (key) (on-key-down player key)))))
- (dolist (item item-list)
- (let ((y (car item))
- (x (cadr item))
- (type (caddr item)))
- (cond
- ((eq type 'uxul)
- (setf (x player) (* 128 x))
- (setf (y player) (* 128 y))
- (add-object player room))
- ((eq type 'tulip)
- (add-object (make-instance 'tulip
- :x (* 128 x)
- :y (* 128 y)) room))
- ((eq type 'brown-stone)
- (add-object (make-instance 'stone
- :animation (make-animation 0 |brown_stone|)
- :x (* 128 x)
- :y (* 128 y)) room))
- ((eq type 'gray-stone)
- (add-object (make-instance 'stone
- :animation (make-animation 0 |gray_stone|)
- :x (* 128 x)
- :y (* 128 y)) room))
- ((eq type 'nasobem)
- (add-object (make-instance 'simple-enemy
- :x (* 128 x)
- :y (* 128 y)) room))
- ((eq type 'blue-nasobem)
- (add-object (make-instance 'flying-nasobem
- :x (* 128 x)
- :y (* 128 y)) room))
- (T
- (add-object (make-instance type
- :x (* 128 x)
- :y (* 128 y)) room)))))
- room))
+(defun level-editor (&optional (level nil) (width 16) (height 16))
+ ;; hack. swap "width" and "height". (too lazy to change it properly by now)
+ (let ((nilpferd width))
+ (setf width height)
+ (setf height nilpferd))
-(defun level-editor (&optional (level nil))
- (prepare-base64-images)
+ (prepare-images)
(let ((item-table (make-hash-table :test 'equal)))
;;initialize given level
(dolist (item level)
- (setf (gethash (cons (car item) (cadr item)) item-table) (caddr item)))
-
+ (setf (gethash (cons (car item) (cadr item)) item-table) (cddr item)))
(ltk:with-ltk ()
(let*
- ((uxul (load-image-into-tk (gethash 'uxul *leveleditor-images*)))
- (leaf (load-image-into-tk (gethash 'leaf *leveleditor-images*)))
- (nasobem (load-image-into-tk (gethash 'nasobem *leveleditor-images*)))
- (blue-nasobem (load-image-into-tk (gethash 'blue-nasobem *leveleditor-images*)))
- (burning-marshmallow (load-image-into-tk (gethash 'burning-marshmallow *leveleditor-images*)))
- (gray-stone (load-image-into-tk (gethash 'gray-stone *leveleditor-images*)))
- (brown-stone (load-image-into-tk (gethash 'brown-stone *leveleditor-images*)))
- (empty (load-image-into-tk (gethash 'empty *leveleditor-images*)))
- (tulip (load-image-into-tk (gethash 'tulip *leveleditor-images*)))
+ ((uxul (load-image-into-tk (gethash 'uxul-world::uxul *leveleditor-images*)))
+ (leaf (load-image-into-tk (gethash 'uxul-world::leaf *leveleditor-images*)))
+ (nasobem (load-image-into-tk (gethash 'uxul-world::nasobem *leveleditor-images*)))
+ (blue-nasobem (load-image-into-tk (gethash 'uxul-world::blue-nasobem *leveleditor-images*)))
+ (burning-marshmallow (load-image-into-tk (gethash 'uxul-world::burning-marshmallow *leveleditor-images*)))
+ (gray-stone (load-image-into-tk (gethash 'uxul-world::gray-stone *leveleditor-images*)))
+ (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*)))
+ (anchor (load-image-into-tk (gethash 'uxul-world::anchor *leveleditor-images*)))
+ (anchors (make-hash-table :test 'equal))
(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 arrow-frame))
(ddown-button (make-instance 'ltk:button :text "\\\\//"
:master arrow-frame))
+ (argument1-entry (make-instance 'ltk:entry :text ""
+ :master object-frame))
+ (argument2-entry (make-instance 'ltk:entry :text ""
+ :master object-frame))
(uxul-button (make-instance 'ltk:button :text ""
:master object-frame))
(nasobem-button (make-instance 'ltk:button :text ""
:master object-frame))
(leaf-button (make-instance 'ltk:button :text ""
:master object-frame))
- (btns (make-array '(16 16) :adjustable nil :element-type 'ltk:button)))
+ (key-button (make-instance 'ltk:button :text ""
+ :master object-frame))
+ (door-button (make-instance 'ltk:button :text ""
+ :master object-frame))
+ (anchor-button (make-instance 'ltk:button :text ""
+ :master object-frame))
+ (info-button (make-instance 'ltk:button :text "Info"
+ :master object-frame))
+ (btns (make-array (list width height) :adjustable nil :element-type 'ltk:button)))
(labels ((redraw-button (i j)
"Redraw Button (i, j)"
(let* ((current-upper-x (car current-upper-left))
(cval (gethash (cons (+ i current-upper-x)
(+ j current-upper-y))
item-table nil))
+ (cval2 nil)
(cbtn (aref btns i j)))
- (if (listp cval)
- (setf cval (car cval)))
+ (when (listp cval)
+ (setf cval2 cval)
+ (setf cval (car cval)))
(cond
- ((eq cval 'leaf)
+ ((eq cval 'uxul-world::leaf)
(config-button-image cbtn leaf))
- ((eq cval 'nasobem)
+ ((eq cval 'uxul-world::nasobem)
(config-button-image cbtn nasobem))
- ((eq cval 'blue-nasobem)
+ ((eq cval 'uxul-world::blue-nasobem)
(config-button-image cbtn blue-nasobem))
- ((eq cval 'burning-marshmallow)
+ ((eq cval 'uxul-world::burning-marshmallow)
(config-button-image cbtn burning-marshmallow))
- ((eq cval 'gray-stone)
+ ((eq cval 'uxul-world::gray-stone)
(config-button-image cbtn gray-stone))
- ((eq cval 'brown-stone)
+ ((eq cval 'uxul-world::brown-stone)
(config-button-image cbtn brown-stone))
((eq cval nil)
(config-button-image cbtn empty))
- ((eq cval 'tulip)
+ ((eq cval 'uxul-world::tulip)
(config-button-image cbtn tulip))
- ((eq cval 'uxul)
+ ((eq cval 'uxul-world::door)
+ (config-button-image cbtn door))
+ ((eq cval 'uxul-world::key)
+ (config-button-image cbtn key))
+ ((eq cval 'uxul-world::anchor)
+ (config-button-image cbtn (gethash (cadr cval2) anchors)))
+ ((eq cval 'uxul-world::uxul)
(config-button-image cbtn uxul)))))
(redraw-buttons ()
"Redraw all Buttons"
- (dotimes (i 16)
- (dotimes (j 16)
+ (dotimes (i width)
+ (dotimes (j height)
(redraw-button i j))))
(react (i j)
(let ((current-upper-x (car current-upper-left))
(current-upper-y (cdr current-upper-left)))
(cond
- ((eq current-chosen-object 'burning-marshmallow)
- (setf (gethash (cons (+ i current-upper-x)
- (+ j current-upper-y))
- item-table) 'burning-marshmallow))
- (t
- (setf (gethash (cons (+ i current-upper-x)
- (+ j current-upper-y))
- item-table) current-chosen-object)))
+ ((eql current-chosen-object :info)
+ (let ((sym (gethash (cons (+ i current-upper-x)
+ (+ j current-upper-y))
+ item-table nil)))
+ (if sym
+ (ltk:do-msg
+ (format nil (concatenate 'string
+ "Symbolname: \"" (symbol-name (car sym)) "\"~%"
+ "First argument: \"" (cadr sym) "\"~%"
+ "Second argument: \"" (caddr sym) "\"")))
+ (ltk:do-msg "There doesnt seem to be anything here."))
+ (return-from react)))
+ ((eql current-chosen-object 'uxul-world::anchor)
+ (cond
+ ((string= (ltk:text argument1-entry) "")
+ (ltk:do-msg "Please give an argument in the left textbox")
+ (return-from react))
+ ((gethash (ltk:text argument1-entry) anchors nil)
+ (ltk:do-msg "Warning: You already set an
+ anchor with the same dungeon-name. Make
+ sure that you remove one of them. Behavior
+ is not specified in this case and may
+ change."))
+ (t
+ (setf (gethash (ltk:text argument1-entry) anchors)
+ (load-image-into-tk (annotated-image (gethash 'uxul-world::anchor *leveleditor-images*) (ltk:text argument1-entry))))))))
+ (setf (gethash (cons (+ i current-upper-x)
+ (+ j current-upper-y))
+ item-table)
+ (and current-chosen-object
+ (list current-chosen-object (ltk:text argument1-entry) (ltk:text argument2-entry))))
(redraw-button i j)))
(move-field-about (i j)
(let ((current-upper-y (car current-upper-left))
(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 argument1-entry 1 0 :columnspan 4)
+ (ltk:grid argument2-entry 1 5 :columnspan 4)
+ (ltk:grid info-button 1 9 :columnspan 2)
+ (setf (ltk:command info-button)
+ #'(lambda () (setf current-chosen-object :info)))
(ltk:grid empty-button 0 0)
(config-button-image empty-button empty)
(config-button-image uxul-button uxul)
(setf (ltk:command uxul-button)
#'(lambda ()
- (setf current-chosen-object 'uxul)))
+ (setf current-chosen-object 'uxul-world::uxul)))
(ltk:grid nasobem-button 0 2)
(config-button-image nasobem-button nasobem)
(setf (ltk:command nasobem-button)
#'(lambda ()
- (setf current-chosen-object 'nasobem)))
+ (setf current-chosen-object 'uxul-world::nasobem)))
(ltk:grid blue-nasobem-button 0 3)
(config-button-image blue-nasobem-button blue-nasobem)
(setf (ltk:command blue-nasobem-button)
#'(lambda ()
- (setf current-chosen-object 'blue-nasobem)))
+ (setf current-chosen-object 'uxul-world::blue-nasobem)))
(ltk:grid burning-marshmallow-button 0 4)
(config-button-image burning-marshmallow-button burning-marshmallow)
(setf (ltk:command burning-marshmallow-button)
#'(lambda ()
- (setf current-chosen-object 'burning-marshmallow)))
+ (setf current-chosen-object 'uxul-world::burning-marshmallow)))
(ltk:grid gray-stone-button 0 5)
(config-button-image gray-stone-button gray-stone)
(setf (ltk:command gray-stone-button)
#'(lambda ()
- (setf current-chosen-object 'gray-stone)))
+ (setf current-chosen-object 'uxul-world::gray-stone)))
(ltk:grid brown-stone-button 0 6)
(config-button-image brown-stone-button brown-stone)
(setf (ltk:command brown-stone-button)
#'(lambda ()
- (setf current-chosen-object 'brown-stone)))
+ (setf current-chosen-object 'uxul-world::brown-stone)))
(ltk:grid leaf-button 0 7)
(config-button-image leaf-button leaf)
(setf (ltk:command leaf-button)
#'(lambda ()
- (setf current-chosen-object 'leaf)))
+ (setf current-chosen-object 'uxul-world::leaf)))
(ltk:grid tulip-button 0 8)
(config-button-image tulip-button tulip)
(setf (ltk:command tulip-button)
#'(lambda ()
- (setf current-chosen-object 'tulip)))
+ (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 anchor-button 0 11)
+ (config-button-image anchor-button anchor)
+ (setf (ltk:command anchor-button)
+ #'(lambda ()
+ (setf current-chosen-object 'uxul-world::anchor)))
(ltk:grid object-frame 0 0)
(ltk:pack objects-and-arrows)
- (dotimes (i 16)
- (dotimes (j 16)
+ (dotimes (i width)
+ (dotimes (j height)
(let ((cbtn
(make-instance 'ltk:button
:master grid-frame
projects / uxul-world.git / blobdiff