samples/tic-tac-toe.scm

@@ -1,6 +1,7 @@
 (module (tic-tac-toe) ()
 (import scheme
 	(chicken base)
+	(chicken random)
 	(engine core)
 	(engine math)
 	(engine components core)
@@ -11,6 +12,8 @@
 	(srfi 1)
 	(srfi 99))
 
+(register-event-bus 'turn-change)
+
 (define draw-text-entities
   (make-system
    'draw-text
@@ -93,6 +96,43 @@
 
 (define grid-square-size (vec 150 150))
 
+(define (get-grid-value x y)
+  (list-ref (list-ref grid y) x))
+
+(define (set-grid-value! x y val)
+  (set! (list-ref (list-ref grid y) x) val))
+
+(define (game-complete?)
+  (or
+   (any (lambda (x) (and (not (= (car x) 0)) (apply = x))) grid)
+   (any (lambda (x) (and (not (= (car x) 0)) (apply = x)))
+	(list (map (lambda (x) (list-ref x 0)) grid)
+	      (map (lambda (x) (list-ref x 1)) grid)
+	      (map (lambda (x) (list-ref x 2)) grid)))
+   (and (not (= (get-grid-value 0 0) 0))
+	(= (get-grid-value 0 0)
+	   (get-grid-value 1 1)
+	   (get-grid-value 2 2)))
+   (and (not (= (get-grid-value 2 0) 0))
+	(= (get-grid-value 2 0)
+	   (get-grid-value 1 1)
+	   (get-grid-value 0 2)))
+   (every (lambda (x) (not (= 0 x)))
+	  (flatten grid))))
+
+(define (find-free-space)
+  (let* ((empty-spaces (filter
+			(lambda (x)
+			  (= 0
+			     (get-grid-value (car x)
+					     (cdr x))))
+			(map
+			 (lambda (x)
+			   (cons (modulo x 3)
+				 (floor (/ x 3))))
+			 (iota 9)))))
+    (list-ref empty-spaces (pseudo-random-integer (length empty-spaces)))))
+
 (define padding (vec 50 50))
 
 (define draw-grid-squares
@@ -121,6 +161,81 @@
   (x g-x)
   (y g-y))
 
+(define-record-type <turn-display>
+  (make-turn-display)
+  turn-display?)
+
+(define-record-type <turn>
+  (make-turn)
+  turn?)
+
+(define-record-type <bot>
+  (make-bot)
+  bot?)
+
+(define-record-type <timer>
+  (make-timer current max timeout done running)
+  timer?
+  (current timer-current set-timer-current!)
+  (max timer-max)
+  (timeout timer-timeout)
+  (done timer-done set-timer-done!)
+  (running timer-running set-timer-running!))
+
+(define update-turn-display
+  (make-system
+   'update-turn-display
+   1
+   'entity
+   '(<visual-2d> <turn-display>)
+   (lambda (_ vis-2d _)
+     (let ((draw (visual-2d-draw vis-2d)))
+       (when (text-2d? draw)
+	 (set-text-2d-text! draw
+			    (case turn
+			      ((player) "Your Turn!")
+			      ((bot) "Bot Turn!")
+			      ((end) "Game over!")
+			      (else "Whose turn is it anyway??"))))))))
+
+(define check-game-state
+  (make-system
+   'check-game-state
+   0
+   'global
+   '()
+   (lambda ()
+     (when (game-complete?)
+       (set! turn 'end)))))
+
+(define tick-timers
+  (make-system
+   'tick-timers
+   1
+   'entity
+   '(<timer>)
+   (lambda (_ timer)
+     (cond
+      ((> (timer-current timer) (timer-max timer))
+       (set-timer-done! timer #t)
+       (set-timer-running! timer #f)
+       (set-timer-current! timer 0)
+       ((timer-timeout timer)))
+      ((timer-running timer)
+       (set-timer-current! timer
+			   (+ (get-frame-time) (timer-current timer))))))))
+
+(define toggle-bot
+  (make-system
+   'toggle-bot
+   1
+   'entity
+   '(<timer> <bot>)
+   (lambda (_ timer _)
+     (when (pop-event 'turn-change 'bot)
+       (set-timer-done! timer #f)
+       (set-timer-running! timer #t)))))
+
 (define (make-grid-square x y)
   (entity
    (make-g-s x y)
@@ -144,14 +259,52 @@
     (vec 0 0)
     grid-square-size
     (lambda ()
-      (set! (list-ref (list-ref grid y) x) (+ 1 (list-ref (list-ref grid y) x)))))))
+      (when (and (eqv? turn 'player) (= 0 (get-grid-value x y)))
+	(set-grid-value! x y 1)
+	(set! turn 'bot)
+	(push-event 'turn-change 'bot (make-turn)))))))
 
 (define (game)
   (scene
    draw-rectangles
+   draw-text-entities
+   update-turn-display
    draw-grid-squares
+   toggle-bot
    click-buttons
+   tick-timers
    push-actions
+   check-game-state
+
+   (entity
+    (make-turn-display)
+    (make-visual-2d
+     (make-text-2d
+      (vec 0 0)
+      "<turn>"
+      24)
+     (make-color 0 0 0 1)
+     0)
+    (make-screen-transform
+     (vec 550 150)
+     (vec 0 0)
+     0
+     (vec 1 1)
+     'center
+     '()))
+
+   (entity
+    (make-bot)
+    (make-timer
+     0
+     2
+     (lambda ()
+       (when
+	   (let ((target (find-free-space)))
+	     (set-grid-value! (car target) (cdr target) 2)
+	     (set! turn 'player))))
+     #f
+     #f))
    
    (make-grid-square 0 0)
    (make-grid-square 1 0)