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).

diff --git a/leveleditor.lisp b/leveleditor.lisp
index 72c53df..bcc8c00 100644 (file)
--- 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 (executable)
--- 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