push

cells.lisp

@@ -949,12 +949,17 @@ world, and collision detection is performed between sprites and cells.")
 	       (< y world-height))
 	  (setf <x> x
 		<y> y)
-	  [do-collision self nil]))))
+	  (setf <x> 0 <y> 0)))))
+;;	  [do-collision self nil]))))
 
 (define-method move sprite (direction &optional movement-distance)
   (let ((dist (or movement-distance <movement-distance>)))
-    (multiple-value-bind (y x) (xe2:step-in-direction <y> <x> direction dist)
-      [update-position self x y])))
+    (let ((y <y>)
+	  (x <x>))
+      (when (and y x)
+	(multiple-value-bind (y0 x0) (xe2:step-in-direction y x direction dist)
+	  (when (and y0 x0)
+	    [update-position self x y]))))))
 
 (define-method collide sprite (sprite)
   ;; (message "COLLIDING A=~S B=~S"

console.lisp

@@ -154,9 +154,15 @@ for backward-compatibility."
   (unless (null *key-table*)
     (maphash #'(lambda (event counter)
 		 (dispatch-event event)
+		 ;; A counter value of -1 means that the key release
+		 ;; happened before the event had a chance to be sent.
+		 ;; These must be removed immediately after sending once.
 		 (if (minusp counter)
 		     (remhash event *key-table*)
-		     (incf (gethash event *key-table*))))
+		     ;; Otherwise, keep counting how many frames the
+		     ;; key is held for.
+		     (when (numberp (gethash event *key-table*))
+		       (incf (gethash event *key-table*)))))
 	     *key-table*)))
 
 (defun break-events (event)
@@ -593,6 +599,10 @@ display."
 				 (progn (message "Removing entry ~A:~A" event entry)
 					(remhash event *key-table*))
 				 (when (zerop entry)
+				   ;; This event hasn't yet been sent,
+				   ;; but the key release happened
+				   ;; now. Mark this entry as pending
+				   ;; deletion (by setting its value to -1)
 				   (setf (gethash event *key-table*) -1)))
 			     (break-events event)))))
       (:idle ()

forest/forest.lisp

@@ -39,6 +39,36 @@
 	      (xe2:set-timer-interval 1)
 	      (xe2:enable-held-keys 1 3)))
 
+;;; Water
+
+(defcell foam 
+  (tile :initform "foam")
+  (clock :initform 4)
+  (categories :initform '(:actor :ephemeral)))
+
+(define-method run foam ()
+  (let ((dir (car (one-of '(:southwest :south :southeast)))))
+    (when [category-in-direction-p *world* <row> <column> dir :water]
+      [move self dir])
+    (decf <clock>)
+    (when (minusp <clock>)
+      [die self])))
+
+(defparameter *water-tiles* '("water-1"
+			     "water-2"
+			     "water-3"))
+
+(defcell water 
+  (tile :initform "floor")
+  (categories :initform '(:actor :reflective :water :exclusive)))
+
+(define-method run water ()
+  (let ((dist [distance-to-player self]))
+    (setf <tile> (if (< dist *earth-light-radius*)
+		     (prog1 (nth (truncate (/ dist 6)) *water-tiles*)
+		       (percent-of-time 1 [drop self (clone =foam=)]))
+		     "floor"))))
+
 ;;; Reflects light 
 
 (defparameter *earth-tiles* '("earth-1" 
@@ -51,27 +81,66 @@
 
 (defparameter *earth-light-radius* 14)
 
+(defparameter *earth-rain-clock* 10)
+
 (defcell earth 
   (tile :initform "floor")
-  (categories :initform '(:actor :reflective)))
+  (categories :initform '(:actor :reflective))
+  (clock :initform (random *earth-rain-clock*)))
 
 (define-method run earth ()
   (let ((dist [distance-to-player self]))
     (setf <tile> (if (< dist *earth-light-radius*)
-		     (nth (truncate (/ dist 2)) *earth-tiles*)
+		     (prog1 (nth (truncate (/ dist 2)) *earth-tiles*)
+		       (if (minusp <clock>)
+			   (progn (percent-of-time 5
+				    (multiple-value-bind (x y) [viewport-coordinates self]
+				      [drop-sprite self (clone =raindrop=) x y]))
+				  (setf <clock> *earth-rain-clock*))
+			   (decf <clock>)))
 		     "floor"))))
 
+;;; The storm 
+
+(defcell storm 
+  (tile :initform nil)
+  (categories :initform '(:actor))
+  (clock :initform 10))
+
+(define-method run storm ()
+  [expend-default-action-points self]
+  (decf <clock>)
+  (if (minusp <clock>)
+      (progn 
+	(setf <clock> (random (+ 400 (random 200))))
+	(message "THUNDER")
+	[play-sample self (car (one-of '("thunder-med" "thunder-med" "thunder-big")))]
+      (decf <clock>))))
+
 ;;; The tree
 
 (defcell tree 
   (tile :initform "tree-1")
   (categories :initform '(:obstacle :opaque)))
 
+;;; The stone wall
+
+(defcell wall
+  (tile :initform "wall")
+  (categories :initform '(:obstacle :opaque)))
+
+(defcell debris
+  (tile :initfomr "debris"))
+
+(defcell ruin-floor
+  (tile :initform "ruin-floor"))
+
 ;;; The player
 
 (defcell player 
   (tile :initform "player")
   (name :initform "Player")
+  (hearing-range :initform 1000)
   (speed :initform (make-stat :base 10 :min 0 :max 10))
   (movement-cost :initform (make-stat :base 10))
   (stepping :initform t)
@@ -84,6 +153,23 @@
   ;; if you are in category :actor, this is called every turn
   nil)
 
+;;; Raindrops
+
+(defsprite raindrop 
+  (image :initform "raindrop")
+  (categories :initform '(:actor))
+  (movement-distance :initform 1)
+  (clock :initform 4))
+
+(define-method run raindrop ()
+  [expend-default-action-points self]
+  (clon:with-fields (clock) self
+    (if (plusp clock) 
+	(progn 
+	  (decf clock)
+	  [move self :southeast])
+	[die self])))
+
 ;;; Ambient Fireflies
 
 (defsprite firefly 
@@ -105,18 +191,93 @@
 	    (percent-of-time 3
 	      (setf clock (+ 5 (random 5)))))))
     [move self (random-direction)]))
+
+;;; Skeletons haunt the woods, coming from gravestones
+
+(defcell gravestone 
+  (tile :initform "gravestone")
+  (categories :initform '(:obstacle :actor))
+  (generated :initform nil))
+
+(define-method run gravestone ()
+  (when (and (< [distance-to-player self] 10)
+	     [line-of-sight *world* <row> <column> 
+			    [player-row *world*]
+			    [player-column *world*]])
+    (percent-of-time 40
+      (when (not <generated>)
+	(setf <generated> t)
+	[drop self (clone =skeleton=) :loadout t]))))
+
+(defcell dagger 
+  (name :initform "dagger")
+  (categories :initform '(:item :weapon :equipment))
+  (tile :initform "dagger")
+  (attack-power :initform (make-stat :base 5))
+  (attack-cost :initform (make-stat :base 6))
+  (accuracy :initform (make-stat :base 90))
+  (stepping :initform t)
+  (weight :initform 3000)
+  (equip-for :initform '(:left-hand :right-hand)))
+
+(defcell skeleton 
+  (name :initform "Skeleton")
+  (strength :initform (make-stat :base 15 :min 0 :max 50))
+  (dexterity :initform (make-stat :base 15 :min 0 :max 30))
+  (intelligence :initform (make-stat :base 13 :min 0 :max 30))
+  (categories :initform '(:actor :target :obstacle :opaque :enemy :equipper))
+  (equipment-slots :initform '(:left-hand))
+  (max-items :initform (make-stat :base 3))
+  (stepping :initform t)
+  (speed :initform (make-stat :base 5))
+  (movement-cost :initform (make-stat :base 5))
+  (attacking-with :initform :robotic-arm)
+  (max-weight :initform (make-stat :base 25))
+  (hit-points :initform (make-stat :base 25 :min 0 :max 10))
+  (tile :initform "skeleton"))
+
+(define-method initialize skeleton ()
+  [make-inventory self]
+  [make-equipment self])
+
+(define-method loadout skeleton ()
+  (let ((dagger (clone =dagger=)))
+    [equip self [add-item self dagger]]))
+
+(define-method run skeleton ()
+  (clon:with-field-values (row column) self
+    (let* ((world *world*)
+	   (direction [direction-to-player *world* row column]))
+      (if [adjacent-to-player world row column]
+	  [>>attack self direction]
+	  (if [obstacle-in-direction-p world row column direction]
+	      (let ((target [target-in-direction-p world row column direction]))
+		(if (and target (not [in-category target :enemy]))
+		    [>>attack self direction]
+		    (progn (setf <direction> (random-direction))
+			   [>>move self direction])))
+	      (progn (when (< 7 (random 10))
+		       (setf <direction> (random-direction)))
+		     [>>move self direction]))))))
+
+;; (define-method die skeleton ()
+;;   (when (> 8 (random 10))
+;;     [drop self (clone (random-stat-powerup))])
+;;   [play-sample self "blaagh3"]
+;;   [parent>>die self])
 
 ;;; The forest
 
 (defcell drop-point 
   (categories :initform '(:player-entry-point))
   (tile :initform nil))
 
-(defparameter *forest-size* 80)
+(defparameter *forest-width* 49)
+(defparameter *forest-height* 200)
 
 (define-prototype forest (:parent xe2:=world=)
-  (height :initform *forest-size*)
-  (width :initform *forest-size*)
+  (height :initform *forest-height*)
+  (width :initform *forest-width*)
   (ambient-light :initform *earth-light-radius*)
   (edge-condition :initform :block))
 
@@ -145,24 +306,107 @@
 	    (when (or (null distance)
 		      (< (distance (+ j r0) (+ c0 i) row column) distance))
 	      (percent-of-time density
-		[drop-cell self (clone object) (+ r0 i) (+ c0 j) :no-collisions t]))))))))
-
-(define-method generate forest (&key (height *forest-size*)
-				     (width *forest-size*))
+		[drop-cell self (clone object) i j :no-collisions t]))))))))
+
+(define-method drop-graves forest (row column height width)
+  (setf height (max 5 height))
+  (setf width (max 5 width))
+  (dotimes (i height)
+    (dotimes (j width)
+      (percent-of-time 40
+	[drop-cell self (clone =gravestone=) 
+		   (+ (* 2 i) row) 
+		   (+ (* 2 j) column)]))))
+
+(define-method drop-water forest (&optional &key (object =water=)
+					    distance 
+					    (row 0) (column 0)
+					    (graininess 0.3)
+					    (density 100)
+					    (cutoff 0))
+  (clon:with-field-values (height width) self
+    (let* ((h0 (or distance height))
+	   (w0 (or distance width))
+	   (r0 (- row (truncate (/ h0 2))))
+	   (c0 (- column (truncate (/ w0 2))))
+	   (plasma (xe2:render-plasma h0 w0 :graininess graininess))
+	   (value nil))
+      (dotimes (i h0)
+	(dotimes (j w0)
+	  (setf value (aref plasma i j))
+	  (when (< cutoff value)
+	    (when (or (null distance)
+		      (< (distance (+ j r0) (+ c0 i) row column) distance))
+	      (percent-of-time density
+		[drop-cell self (clone object) i j :no-collisions t]))))))))
+
+(define-method drop-ruin forest (row column height width)
+  (let (rectangle openings)
+    (labels ((collect-point (&rest args)
+	       (prog1 nil (push args rectangle)))
+	     (drop-wall (r c)
+	       (unless (and (= r 0)
+			    (= c 0))
+		 (let ((wall (clone =wall=)))
+		   [replace-cells-at self r c wall]
+		   [set-location wall r c]))))
+      (trace-rectangle #'collect-point row column height width)
+      ;; make sure there are openings
+      (dotimes (i 6)
+	(let* ((n (random (length rectangle)))
+	       (point (nth n rectangle)))
+	  (destructuring-bind (r c) point
+	    ;; don't make gate holes on corners or above exit
+	    (unless (or (and (= r row) (= c (+ -1 column (truncate (/ width 2)))))
+			(and (= r row) (= c (+ column (truncate (/ width 2)))))
+			(and (= r row) (= c (+ 1 column (truncate (/ width 2)))))
+			(and (= r row) (= c column)) ;; top left 
+			(and (= r row) (= c (+ -1 column width))) ;; top right
+			(and (= r (+ -1 row height)) (= c column)) ;; bottom left
+			(and (= r (+ -1 row height)) (= c (+ -1 column width)))) ;; bottom right
+	      (push (nth n rectangle) openings)
+	      (setf rectangle (delete (nth n rectangle) rectangle))))))
+      ;; draw walls
+      (dolist (point rectangle)
+	(destructuring-bind (r c) point
+	  (drop-wall r c)))
+      ;; draw gates
+      (dolist (point openings)
+	(destructuring-bind (r c) point
+	  (let ((debris (clone =debris=)))
+	    [replace-cells-at self r c debris]
+	    [set-location debris r c])))
+      ;; drop floor, obliterating what's below
+      (labels ((drop-floor (r c)
+		 (prog1 nil
+		   (percent-of-time 80
+		     [replace-cells-at self r c (clone =ruin-floor=)]))))
+	(trace-rectangle #'drop-floor (1+ row) (1+ column) (- height 2) (- width 2) :fill)))))
+
+
+(define-method generate forest (&key (height *forest-height*)
+				     (width *forest-width*))
   (setf <height> height)
   (setf <width> width)
   [create-default-grid self]
   [drop-earth self]
+  [drop-cell self (clone =storm=) 0 0]
   (dotimes (i 100)
     (let ((firefly (clone =firefly=)))
       [add-sprite self firefly]
       [update-position firefly 
-		       (random (* 16 70))
-		       (random (* 16 70))]))
-  [drop-trees self :graininess 0.08 :density 30]
+		       (random (* 16 *forest-width*))
+		       (random (* 16 *forest-height*))]))
+  [drop-trees self :graininess 0.3 :density 32]
+  [drop-water self :graininess 0.2 :density 90 :cutoff 0.9]
+  (dotimes (n 10)
+    [drop-graves self (random *forest-height*) (random *forest-width*)
+		 (+ 4 (random 4)) (+ 4 (random 4))])
+  (dotimes (n 15)
+    [drop-ruin self (random *forest-height*) (random *forest-width*) (+ 9 (random 8)) (+ 4 (random 8))])
   [drop-cell self (clone =drop-point=) 
-	     (1+ (random 50)) 
-	     (1+ (random 50))
+	     (1+ (random 20)) 
+	     (1+ (random 20))
 	     :exclusive t :probe t])
 
 (define-method begin-ambient-loop forest ()