X-Git-Url: http://uxul.de/gitweb/?a=blobdiff_plain;f=leveleditor.lisp;h=11ff966adb9b8547eeb917efe1997f78541813c7;hb=9fd8c82ee3279f484cffd635da57b1e9b0010782;hp=5a7808cceaf820cbd335097cb2f9a544bcaf838b;hpb=3520f2248cddebdc3c03a080047d76fdf1f6c382;p=uxul-world.git diff --git a/leveleditor.lisp b/leveleditor.lisp index 5a7808c..11ff966 100644 --- a/leveleditor.lisp +++ b/leveleditor.lisp @@ -1,6 +1,6 @@ ;;; Copyright 2009 Christoph Senjak -(in-package :uxul-world) +(in-package :uxul-world-leveleditor) (defparameter *leveleditor-images* nil) @@ -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_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|)))) + (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,7 @@ 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)) (prepare-base64-images) (let ((item-table (make-hash-table :test 'equal))) ;;initialize given level @@ -102,15 +54,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 +103,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 +115,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 +184,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