Make growing and shrinking of the map explicitcommon-lisp

1 files changed, 82 insertions, 60 deletions

diff --git a/src/gridmapper.lisp b/src/gridmapper.lisp
index 58a0d3a..0bd0642 100644
--- a/src/gridmapper.lisp
+++ b/src/gridmapper.lisp
@@ -402,6 +402,8 @@ WINDOW is required for the Cairo surface."
     (cairo:set-font-size (* 12 *scale*))
     (help-lines x y line-height
 		"Move: ← ↓ ↑ → or h j k l or mouse move"
+		"Grow: Control and ← ↓ ↑ → or h j k l"
+		"Shrink: Control Alt and ← ↓ ↑ → or h j k l"
 		"Select: Shift ← ↓ ↑ → or Shift h j k l or Shift mouse move"
 		"Floor: f (use again to toggle) or mouse click"
 		"Door: d (use multiple times to rotate)"
@@ -426,35 +428,32 @@ size is increased, and *VISIBLE-WIDTH* and *VISIBLE-HEIGHT* are set to
 match *WIDTH* and *HEIGHT*. If the window does not increase, the two
 variables remain (and are now smaller than *WIDTH* and *HEIGHT*). See
 ADJUST-OFFSET for what happens when only part of the map is visible."
-  (multiple-value-bind (window-width window-height)
-      (get-window-size window)
-    (let* ((unit (* *dimension* *scale*))
-	   (display (get-display-bounds (get-window-display-index window)))
-	   (visible-width (floor window-width unit))
-	   (visible-height (floor window-height unit))
-	   (visible-max-width (floor (sdl2:rect-width display) unit))
-	   (visible-max-height (floor (sdl2:rect-height display) unit))
-	   (resize-window nil))
-      ;; The map size is within the max visible map size.
-      (when (<= *width* visible-max-width)
-	(setf *visible-width* *width*
-	      resize-window t))
-      (when (<= *height* visible-max-width)
-	(setf *visible-height* *height*
-	      resize-window t))
-      ;; The map size surpasses the max visible map size.
-      (when (> *width* visible-max-width)
-	(setf *visible-width* visible-max-width
-	      resize-window t))
-      (when (> *height* visible-max-width)
-	(setf *visible-height* visible-max-height
-	      resize-window t))
-      ;; Resize the window if anything changed.
-      (when resize-window
-	(set-window-size window
-			 (floor (* *visible-width* unit))
-			 (floor (* *visible-height* unit)))
-	(delay 10)))))
+  (let* ((unit (* *dimension* *scale*))
+	 (display (get-display-bounds (get-window-display-index window)))
+	 ;; 1- in order to take window decoration into account
+	 (visible-max-width (1- (floor (sdl2:rect-width display) unit)))
+	 (visible-max-height (1- (floor (sdl2:rect-height display) unit)))
+	 (resize-window nil))
+    ;; The map size is within the max visible map size.
+    (when (<= *width* visible-max-width)
+      (setf *visible-width* *width*
+	    resize-window t))
+    (when (<= *height* visible-max-height)
+      (setf *visible-height* *height*
+	    resize-window t))
+    ;; The map size surpasses the max visible map size.
+    (when (> *width* visible-max-width)
+      (setf *visible-width* visible-max-width
+	    resize-window t))
+    (when (> *height* visible-max-height)
+      (setf *visible-height* visible-max-height
+	    resize-window t))
+    ;; Resize the window if anything changed.
+    (when resize-window
+      (set-window-size window
+		       (floor (* *visible-width* unit))
+		       (floor (* *visible-height* unit)))
+      (delay 10))))
 
 (defun adjust-offset ()
   "If the *PEN* is not visible, set *OFFSET-X* and *OFFSET-Y*.
@@ -465,8 +464,8 @@ This changes how every single item is drawn."
 	   (setf *offset-x* (1+ (- x *visible-width*))))
 	  ((< x *offset-x*)
 	   (setf *offset-x* x)))
-    (cond ((>= y (+ *offset-y* *visible-width*))
-	   (setf *offset-y* (1+ (- y *visible-width*))))
+    (cond ((>= y (+ *offset-y* *visible-height*))
+	   (setf *offset-y* (1+ (- y *visible-height*))))
 	  ((< y *offset-y*)
 	   (setf *offset-y* y)))))
 
@@ -801,15 +800,15 @@ See ADJUST-SIZE for how this affects the window size."
     (:west (incf *width*) (shift-tiles :x 1)))
   (setf *redraw* t))
 
-(defun extend-map-if-necessary ()
-  "Return non-nil if *PEN* is outside the map.
-Usually this means we should call EXTEND-MAP for doing anything else."
-  (let ((x (pen-x *pen*))
-	(y (pen-y *pen*)))
-    (cond ((<= x 0) (extend-map :west))
-	  ((>= x (1- *width*)) (extend-map :east))
-	  ((<= y 0) (extend-map :north))
-	  ((>= y (1- *height*)) (extend-map :south)))))
+(defun shrink-map (direction)
+  "Shrink the map by one step in DIRECTION.
+See ADJUST-SIZE for how this affects the window size."
+  (case direction
+    (:north (shift-tiles :y -1) (decf *height*))
+    (:east (decf *width*))
+    (:south (decf *height*))
+    (:west (shift-tiles :x -1) (decf *width*)))
+  (setf *redraw* t))
 
 (defun move (direction &optional keep-region)
   "Move *PEN* in DIRECTION.
@@ -823,8 +822,7 @@ With optional argument KEEP-REGION do not set *REGION* to NIL."
 	((and (eq direction :east) (< (pos-x *pen*) (1- *width*)))
 	 (setf (pos-x *pen*) (1+ (pos-x *pen*)) *redraw* t))
 	((and (eq direction :south) (< (pos-y *pen*) (1- *height*)))
-	 (setf (pos-y *pen*) (1+ (pos-y *pen*)) *redraw* t))
-	(t (extend-map direction))))
+	 (setf (pos-y *pen*) (1+ (pos-y *pen*)) *redraw* t))))
 
 (defun move-to (x y &optional keep-region)
   "Move *PEN* to (X Y)."
@@ -986,20 +984,30 @@ CLIPBOARD-REGION removed."
 	   (setf *floor* orig-floor
 		 *walls* orig-walls)))))))
 
+(defun pen-outside-the-map ()
+  "Return non-nil if *PEN* is outside the editable map.
+The editable map is on top the grey background. Usually that means we
+should ignore any command as it should have no effect atop the white
+edge of the map."
+  (let ((x (pen-x *pen*))
+	(y (pen-y *pen*)))
+    (or (<= x 0) (>= x (1- *width*))
+	(<= y 0) (>= y (1- *height*)))))
+
 (defun draw-or-erase-floor ()
   "Draw or erase a floor tile at the pen's position."
   (let ((x (pen-x *pen*))
 	(y (pen-y *pen*))
 	(mode (pen-m *pen*))
 	(tile (tile-at *floor* *pen*)))
-    (cond ((and (eq mode :drawing) (not tile))
+    (cond ((pen-outside-the-map))
+	  ((and (eq mode :drawing) (not tile))
 	   (setf tile (make-tile :x x :y y :z *z* :d nil :t :empty))
 	   (perform-action (lambda () (push tile *floor*))
 			   (lambda () (setq *floor* (delete tile *floor*)))))
 	  ((and (eq mode :erasing) tile)
 	   (perform-action (lambda () (setq *floor* (delete tile *floor*)))
-			   (lambda () (push tile *floor*)))))
-    (extend-map-if-necessary)))
+			   (lambda () (push tile *floor*)))))))
 
 (defun draw-or-erase-floor-to (x y)
   "Draw floor tiles on the way to (X, Y).
@@ -1042,13 +1050,13 @@ With optional argument DIRECTION, prefer a direction after it."
 
 (defun draw-door ()
   "Draw a door where the pen is, or rotate it."
-  (cond ((pen-d *pen*)
+  (cond ((pen-outside-the-map))
+	((pen-d *pen*)
 	 (rotate-wall))
 	((setf (pen-d *pen*) (free-wall))
 	 (let ((tile (make-tile :x (pen-x *pen*) :y (pen-y *pen*) :z *z* :d (pen-d *pen*) :t :door)))
 	   (perform-action (lambda () (push tile *walls*))
-			   (lambda () (setq *walls* (delete tile *walls*)))))))
-  (extend-map-if-necessary))
+			   (lambda () (setq *walls* (delete tile *walls*))))))))
 
 (defun next-direction (direction)
   "Return the next direction after DIRECTION in *DIRECTIONS*."
@@ -1067,13 +1075,13 @@ With optional argument DIRECTION, prefer a direction after it."
 
 (defun draw-stair ()
   "Draw a stair where the pen is, or rotate it."
-  (cond ((tile-at *stairs* *pen* :any)
+  (cond ((pen-outside-the-map))
+	((tile-at *stairs* *pen* :any)
 	 (rotate-stair))
 	(t
 	 (let ((tile (make-tile :x (pen-x *pen*) :y (pen-y *pen*) :z *z* :d (car *directions*) :t :stair)))
 	   (perform-action (lambda () (push tile *stairs*))
-			   (lambda () (setq *stairs* (delete tile *stairs*)))))))
-  (extend-map-if-necessary))
+			   (lambda () (setq *stairs* (delete tile *stairs*))))))))
 
 (defun erase-here ()
   "Erase whatever is here, starting with wall elements or doors."
@@ -1106,16 +1114,30 @@ Also set *COORDINATES* to nil so that the texture gets recomputed."
 Key names are used so that an x is an x no matter the keyboard
 layout. Sadly, the + is a = so all of this doesn't really work."
   (let* ((mod (mod-value keysym))
-	 (ctrl (mod-value-p mod :lctrl :rctrl))
+	 (control (mod-value-p mod :lctrl :rctrl))
 	 (shift (mod-value-p mod :lshift :rshift))
+	 (alt (mod-value-p mod :lalt :ralt))
 	 (key-name (get-key-name (get-key-from-scancode (scancode-value keysym)))))
     (setf *shift* shift)
-    ;; The keys we know about. Remember to check CTRL and SHIFT before
+    ;; The keys we know about. Remember to check CONTROL and SHIFT before
     ;; regular bindings!
     (cond ((or (string= key-name "Escape")
 	       (string= key-name "Q")
-	       (and ctrl (string= key-name "W")))
+	       (and control (string= key-name "W")))
 	   (push-event :quit))
+	  ;; Map extensions
+	  ((and control (or (string= key-name "H")
+			 (string= key-name "Left")))
+	   (if alt (shrink-map :west) (extend-map :west)) (reset-pen))
+	  ((and control (or (string= key-name "J")
+			 (string= key-name "Down")))
+	   (if alt (shrink-map :south) (extend-map :south)) (reset-pen))
+	  ((and control (or (string= key-name "K")
+			 (string= key-name "Up")))
+	   (if alt (shrink-map :north) (extend-map :north)) (reset-pen))
+	  ((and control (or (string= key-name "L")
+			 (string= key-name "Right")))
+	   (if alt (shrink-map :east) (extend-map :east)) (reset-pen))
 	  ;; Region
 	  ((and shift (or (string= key-name "H")
 			  (string= key-name "Left")))
@@ -1129,11 +1151,11 @@ layout. Sadly, the + is a = so all of this doesn't really work."
 	  ((and shift (or (string= key-name "L")
 			  (string= key-name "Right")))
 	   (extend-region :east) (reset-pen))
-	  ((and ctrl (string= key-name "C"))
+	  ((and control (string= key-name "C"))
 	   (copy-region))
-	  ((and ctrl (string= key-name "X"))
+	  ((and control (string= key-name "X"))
 	   (cut-region))
-	  ((and ctrl (string= key-name "V"))
+	  ((and control (string= key-name "V"))
 	   (paste-region))
 	  ;; Walls and doors
 	  ((string= key-name "D")
@@ -1171,11 +1193,11 @@ layout. Sadly, the + is a = so all of this doesn't really work."
 	  ((string= key-name "-")
 	   (zoom -0.5))
 	  ;; Open, save, export map
-	  ((and ctrl (string= key-name "S"))
+	  ((and control (string= key-name "S"))
 	   (save-map))
-	  ((and ctrl (string= key-name "E"))
+	  ((and control (string= key-name "E"))
 	   (export-map))
-	  ((and ctrl (string= key-name "O"))
+	  ((and control (string= key-name "O"))
 	   (load-map))
 	  ;; Help
 	  ((and shift (string= key-name "/"))