(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)
(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))
+ ;; 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*)))
(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))
: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))
(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)"
(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))
(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 ()
(let ((current-upper-x (car current-upper-left))
(current-upper-y (cdr current-upper-left)))
(cond
- ((eq current-chosen-object 'uxul-world::burning-marshmallow)
- (setf (gethash (cons (+ i current-upper-x)
- (+ j current-upper-y))
- item-table) 'uxul-world::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)
#'(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)
projects / uxul-world.git / blobdiff