X-Git-Url: http://uxul.de/gitweb/?a=blobdiff_plain;f=leveleditor.lisp;h=57000602e13c0b488588fd93f0efb28666e9dc68;hb=470725f4a2f682d02fb15183cc596c7fa5c7b761;hp=bcc8c005f4597d66ed6797aa5003fd704bdac302;hpb=da600e03ab77744757cc17fae460e7cd94c3df10;p=uxul-world.git diff --git a/leveleditor.lisp b/leveleditor.lisp old mode 100644 new mode 100755 index bcc8c00..5700060 --- a/leveleditor.lisp +++ b/leveleditor.lisp @@ -1,58 +1,130 @@ -;;; Copyright 2009 Christoph Senjak +;;; Copyright 2009-2011 Christoph Senjak (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 prepare-base64-images (&optional (care-about-initialization *leveleditor-images*)) +(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-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|)))) + (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 level-editor (&optional (level nil) (width 16) (height 16)) - (declare (type '(integer 0 100) width height)) - (prepare-base64-images) + ;; hack. swap "width" and "height". (too lazy to change it properly by now) + (let ((nilpferd width)) + (setf width height) + (setf height nilpferd)) + + (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-world::uxul *leveleditor-images*))) @@ -64,12 +136,16 @@ form (x y object)." (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 "<" @@ -86,6 +162,10 @@ form (x y object)." :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 "" @@ -104,6 +184,14 @@ form (x y object)." :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)) + (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)" @@ -112,9 +200,11 @@ form (x y object)." (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 'uxul-world::leaf) (config-button-image cbtn leaf)) @@ -132,6 +222,12 @@ form (x y object)." (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::anchor) + (config-button-image cbtn (gethash (cadr cval2) anchors))) ((eq cval 'uxul-world::uxul) (config-button-image cbtn uxul))))) (redraw-buttons () @@ -143,14 +239,37 @@ form (x y object)." (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)) @@ -162,19 +281,25 @@ form (x y object)." (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) @@ -223,6 +348,24 @@ form (x y object)." #'(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 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)