X-Git-Url: http://uxul.de/gitweb/?a=blobdiff_plain;f=leveleditor.lisp;h=0f01e4009c4843eff3d75c80e2dd99c1e7e8228c;hb=3a5b6fe5b066ace9e3d03ec20c96c224cdbeb0b8;hp=da98fb19854178968883ec0d70a3b37c1467fd3c;hpb=4e8bd7f10df674c08e258b6b1bd5c3d2cf60573c;p=uxul-world.git diff --git a/leveleditor.lisp b/leveleditor.lisp old mode 100644 new mode 100755 index da98fb1..0f01e40 --- a/leveleditor.lisp +++ b/leveleditor.lisp @@ -33,6 +33,7 @@ (defun prepare-images (&optional (care-about-initialization *leveleditor-images*)) (when (not care-about-initialization) (setf *leveleditor-images* (make-hash-table)) + (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|)) @@ -44,6 +45,7 @@ (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) @@ -67,12 +69,16 @@ form (x y object arg1 arg2 ...)." ret)) (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)) + (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) (cddr 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*))) @@ -86,6 +92,8 @@ form (x y object arg1 arg2 ...)." (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)) @@ -134,6 +142,10 @@ form (x y object arg1 arg2 ...)." :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)" @@ -142,9 +154,11 @@ form (x y object arg1 arg2 ...)." (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)) @@ -166,6 +180,8 @@ form (x y object arg1 arg2 ...)." (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 () @@ -176,6 +192,33 @@ form (x y object arg1 arg2 ...)." (react (i j) (let ((current-upper-x (car current-upper-left)) (current-upper-y (cdr current-upper-left))) + (cond + ((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) @@ -206,8 +249,11 @@ form (x y object arg1 arg2 ...)." (ltk:grid ddown-button 2 2) (setf (ltk:command ddown-button) #'(lambda () (move-field-about (- 1 width) 0))) - (ltk:grid argument1-entry 1 0 :columnspan 5) - (ltk:grid argument2-entry 1 6 :columnspan 5) + (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) @@ -268,6 +314,12 @@ form (x y object arg1 arg2 ...)." #'(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)