From da600e03ab77744757cc17fae460e7cd94c3df10 Mon Sep 17 00:00:00 2001 From: christoph Date: Tue, 4 Aug 2009 02:44:20 +0200 Subject: [PATCH] You can pass a different size to level-editor (for window managers like Mac OS, which do not allow moving the window above the upper screen-bound). --- leveleditor.lisp | 129 +++++++++++++++-------------------------------- room.lisp | 50 +++++++++++++++++- 2 files changed, 90 insertions(+), 89 deletions(-) diff --git a/leveleditor.lisp b/leveleditor.lisp index 72c53df..bcc8c00 100644 --- a/leveleditor.lisp +++ b/leveleditor.lisp @@ -15,15 +15,15 @@ (defun prepare-base64-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-world::|uxul_small1|)) - (setf (gethash 'leaf *leveleditor-images*) (stretched-base64-image uxul-world::|leaf|)) - (setf (gethash 'nasobem *leveleditor-images*) (stretched-base64-image uxul-world::|nasobem|)) - (setf (gethash 'blue-nasobem *leveleditor-images*) (stretched-base64-image uxul-world::|blue_nasobem|)) - (setf (gethash 'burning-marshmallow *leveleditor-images*) (stretched-base64-image uxul-world::|burning_marshmallow_ld1|)) - (setf (gethash 'gray-stone *leveleditor-images*) (stretched-base64-image uxul-world::|gray_stone|)) - (setf (gethash 'brown-stone *leveleditor-images*) (stretched-base64-image uxul-world::|brown_stone|)) - (setf (gethash 'empty *leveleditor-images*) (stretched-base64-image uxul-world::|empty|)) - (setf (gethash 'tulip *leveleditor-images*) (stretched-base64-image uxul-world::|tulip|)))) + (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|)))) (defun load-image-into-tk (png-base64) "return a tkobject with this image" @@ -45,55 +45,8 @@ form (x y object)." 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)) +(defun level-editor (&optional (level nil) (width 16) (height 16)) + (declare (type '(integer 0 100) width height)) (prepare-base64-images) (let ((item-table (make-hash-table :test 'equal))) ;;initialize given level @@ -102,15 +55,15 @@ form (x y object)." (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*))) (current-upper-left (cons 0 0)) (current-chosen-object 'uxul) (objects-and-arrows (make-instance 'ltk:frame)) @@ -151,7 +104,7 @@ form (x y object)." :master object-frame)) (leaf-button (make-instance 'ltk:button :text "" :master object-frame)) - (btns (make-array '(16 16) :adjustable nil :element-type 'ltk:button))) + (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)) @@ -163,28 +116,28 @@ form (x y object)." (if (listp 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::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)) @@ -232,49 +185,49 @@ form (x y object)." (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 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 diff --git a/room.lisp b/room.lisp index 37292d0..bf55313 100755 --- a/room.lisp +++ b/room.lisp @@ -92,4 +92,52 @@ (if (invocation-function obj) (funcall (invocation-function obj) obj) (dolist (invoker (get-objects obj 'uxul-world::game-object)) - (if (active invoker) (invoke invoker))))) \ No newline at end of file + (if (active invoker) (invoke invoker))))) + +(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)) \ No newline at end of file -- 2.20.1