Basic combat

modules/attack.scm

@@ -0,0 +1,143 @@
+(module (bd attack) ()
+(import scheme
+	(chicken base) 
+	(chicken module)
+	(chicken string)
+	(bd random)
+	(srfi 99))
+
+(export hand-direction hand-vert hand-horiz)
+(define-record-type <hand-direction>
+  (hand-direction vert horiz)
+  hand-direction?
+  (vert hand-vert)
+  (horiz hand-horiz))
+
+(export direction-to-string)
+(define (direction-to-string dir)
+  (conc (hand-vert dir)
+	" : "
+	(hand-horiz dir)))
+
+(define (opposite-horiz h)
+  (if (eqv? h 'right)
+      'left
+      'right))
+
+(define (opposite-vert v)
+  (cond
+   ((eqv? v 'high) 'low)
+   ((eqv? v 'mid) 'mid)
+   ((eqv? v 'low) 'high)))
+
+(export opposite-pos)
+(define (opposite-pos h)
+  (hand-direction
+   (opposite-vert (hand-vert h))
+   (opposite-horiz (hand-horiz h))))
+
+(define (pos-= h1 h2)
+  (and (eqv? (hand-vert h1) (hand-vert h2))
+       (eqv? (hand-horiz h1) (hand-horiz h2))))
+
+(define (pos-to-int h)
+  (cond
+   ((pos-= h (hand-direction 'high 'right)) 0)
+   ((pos-= h (hand-direction 'high 'left)) 1)
+   ((pos-= h (hand-direction 'mid 'left)) 2)
+   ((pos-= h (hand-direction 'low 'left)) 3)
+   ((pos-= h (hand-direction 'low 'right)) 4)
+   ((pos-= h (hand-direction 'mid 'right)) 5)))
+
+(define (int-to-pos i)
+  (case i
+    ((0) (hand-direction 'high 'right))
+    ((1) (hand-direction 'high 'left))
+    ((2) (hand-direction 'mid 'left))
+    ((3) (hand-direction 'low 'left))
+    ((4) (hand-direction 'low 'right))
+    ((5) (hand-direction 'mid 'right))))
+
+(export rotate-pos rotate-pos-cc)
+(define (rotate-pos p)
+  (let ((pos (pos-to-int p)))
+    (if (= pos 5)
+	(int-to-pos 0)
+	(int-to-pos (+ 1 pos))))) 
+
+(define (rotate-pos-cc p)
+  (let ((pos (pos-to-int p)))
+    (if (= pos 0)
+	(int-to-pos 5)
+	(int-to-pos (- pos 1)))))
+
+(export attack attack-direction attack-offense)
+(define-record-type <attack>
+  (attack direction offense)
+  attack?
+  (direction attack-direction)
+  (offense attack-offense))
+
+(define (high-stance-attack dir)
+  (if (eqv? 'high (hand-vert dir))
+      80
+      50))
+
+(define (mid-stance-attack dir)
+  (if (eqv? 'mid (hand-vert dir))
+      80
+      50))
+
+(define (low-stance-attack dir)
+  (if (eqv? 'low (hand-vert dir))
+      80
+      50))
+
+(export attack-from-stance)
+(define (attack-from-stance attack-direction stance)
+  (attack attack-direction
+	  (cond
+	   ((eqv? stance 'high) (high-stance-attack attack-direction))
+	   ((eqv? stance 'mid) (mid-stance-attack attack-direction))
+	   ((eqv? stance 'low) (mid-stance-attack attack-direction))
+	   (else 50))))
+
+(define (high-stance-defense dir)
+  (cond
+   ((eqv? 'high (hand-vert dir)) 20)
+   ((eqv? 'low (hand-vert dir)) -30)
+   (else 0)))
+
+(define (mid-stance-defense dir)
+  (cond
+   ((eqv? 'mid (hand-vert dir)) 20)
+   (else -30)))
+
+(define (low-stance-defense dir)
+  (cond
+   ((eqv? 'low (hand-vert dir)) 20)
+   ((eqv? 'high (hand-vert dir)) -30)
+   (else 0)))
+
+(export defense-from-stance)
+(define (defense-from-stance attack-dir hand-pos stance)
+  (+ 40
+     (if (or (eqv? (hand-vert attack-dir)
+		   (opposite-vert (hand-vert hand-pos)))
+	     (eqv? (hand-horiz attack-dir)
+		   (opposite-horiz (hand-horiz hand-pos))))
+	 20
+	 0)
+     (cond
+      ((eqv? stance 'high) (high-stance-defense attack-dir))
+      ((eqv? stance 'mid) (mid-stance-defense attack-dir))
+      ((eqv? stance 'low) (low-stance-defense attack-dir))
+      (else 0))))
+
+(export resolve-combat)
+(define (resolve-combat attack defense)
+  (let ((tn (+ 5 (/ (- (attack-offense attack) defense) 10))))
+    (if (> tn (+ 1 (rand-int 10)))
+	'hit
+	'miss)))
+)

modules/grid.scm

@@ -0,0 +1,74 @@
+(module (bd grid) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	raylib
+	(imugi core)
+	(imugi drawing)
+	(imugi math)
+	(srfi 1)
+	(srfi 99))
+
+(export grid)
+(define (grid len wid default)
+  (define (iter i acc)
+    (if (= len i)
+	acc
+	(iter
+	 (+ 1 i)
+	 (cons (make-list wid default) acc))))
+  (iter 0 '()))
+
+(export gv)
+(define (gv grd x y)
+  (list-ref (list-ref grd y) x))
+
+(export gv!)
+(define (gv! grd x y val)
+  (set! (list-ref (list-ref grd y) x) val))
+
+(define (draw-grid-square offset width x y entity)
+  (let ((square-pos (v+ offset
+			(vec (* x width)
+			     (* y width)))))
+    (push-render-object
+     'screen
+     0
+     (lambda ()
+       (draw-rectangle-2d
+	square-pos
+	width
+	width
+	(cond
+	 ((eqv? entity 'player) (make-color 0 0 1 1))
+	 ((eqv? entity 'foe) (make-color 1 0 0 1))
+	 (else (make-color 0 0 0 1)))
+	(not (eqv? entity 'none))
+	2)))))
+
+(export draw-grid)
+(define draw-grid
+  (make-system
+   'draw-grid
+   10
+   'entity
+   '(<grid-view>)
+   (lambda (_ grid-view)
+     (let ((gd (grid-view-grid grid-view))
+	   (width (grid-view-width grid-view))
+	   (pos (grid-view-pos grid-view)))
+       (do ((i 0 (+ 1 i)))
+	   ((= i (length gd)) gd)
+	 (let ((row (list-ref gd i)))
+	   (do ((j 0 (+ 1 j)))
+	       ((= j (length row)) row)
+	     (draw-grid-square pos width i j (list-ref row j)))))))))
+
+(export grid-view grid-view-grid)
+(define-record-type <grid-view>
+  (grid-view start-pos gd width)
+  grid-view?
+  (start-pos grid-view-pos set-grid-view-pos!)
+  (gd grid-view-grid set-grid-view-grid!)
+  (width grid-view-width set-grid-view-width!))
+)

modules/random.scm

@@ -0,0 +1,15 @@
+(module (bd random) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	(chicken random))
+
+(export random)
+(export rand-int)
+(define random pseudo-random-real)
+(define rand-int pseudo-random-integer)
+
+(export pick-random)
+(define (pick-random lst)
+  (list-ref lst (rand-int (length lst))))
+)

modules/ui.scm

@@ -29,6 +29,22 @@
   (color label-color set-label-color!)
   (text label-text set-label-text!))
 
+(export process-dynamic-labels)
+(define process-dynamic-labels
+  (make-system
+   'process-dynamic-labels
+   9
+   'entity
+   '(<label> <dynamic-label>)
+   (lambda (_ label d-label)
+     (set-label-text! label ((label-func d-label))))))
+
+(export dynamic-label)
+(define-record-type <dynamic-label>
+  (dynamic-label func)
+  dynamic-label?
+  (func label-func))
+
 ;; Title/subtitle/footer etc are basically just different styles
 (export title)
 (define (title position text