Finish tic-tac-toe

engine/core.scm

@@ -304,8 +304,6 @@
 	(hash-table-set! event-buses name (make-hash-table))
 	name)))
 
-(register-event-bus 'input)
-
 ;; Remove an event bus
 (define (remove-event-bus name)
   (assert (symbol? name))
@@ -368,45 +366,6 @@
 	  event)
 	#f)))
 
-;; Input actions alist
-(define input-actions '())
-
-;; Key-press type action
-(define-record-type <key-press>
-  (make-key-press key)
-  key-press?
-  (key key-press-key))
-
-;; Add a new action to the input actions alist
-(export register-action push-actions)
-(define (register-action name type . data)
-  (assert (symbol? name))
-  (assert (member type '(key-press)))
-  (set! input-actions
-    (cons (cons name
-		(apply (cond
-			((eqv? type 'key-press) make-key-press))
-		       data))
-	  input-actions)))
-
-;; Default global system for simple input management
-(define push-actions
-  (make-system
-   'push-actions
-   0
-   'global
-   '()
-   (lambda ()
-     (for-each
-      (lambda (action)
-	(cond
-	 ((key-press? (cdr action))
-	  (when (key-pressed? (key-press-key (cdr action)))
-	    (push-event 'input
-			(car action)
-			(cdr action))))))
-      input-actions))))
-
 ;; Render queue exports
 (export register-render-queue push-render-object evaluate-render-queue)
 

engine/drawing.scm

@@ -189,6 +189,29 @@
 (define set-triangle-2d-filled!
   (guarded-mutator triangle-2d? 'filled boolean?))
 
+;; 2D text drawing
+(export text-2d? make-text-2d text-2d-position set-text-2d-position!
+	text-2d-text set-text-2d-text! text-2d-size set-text-2d-size!)
+(define-record-type <text-2d>
+  (int:make-text-2d position text size)
+  text-2d?
+  (position text-2d-position int:set-text-2d-position!)
+  (text text-2d-text int:set-text-2d-text!)
+  (size text-2d-size int:set-text-2d-size!))
+
+(define (make-text-2d position text size)
+  (assert (vec2? position))
+  (assert (string? text))
+  (assert ((conjoin integer? positive?) size))
+  (int:make-text-2d position text size))
+
+(define set-text-2d-position!
+  (guarded-mutator text-2d? 'position vec2?))
+(define set-text-2d-text!
+  (guarded-mutator text-2d? 'text string?))
+(define set-text-2d-size!
+  (guarded-mutator text-2d? 'size (conjoin integer? positive?)))
+
 ;; Visual component
 (export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw!
 	visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!)
@@ -200,13 +223,13 @@
   (layer visual-2d-layer int:set-visual-2d-layer!))
 
 (define (make-visual-2d draw color layer)
-  (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
+  (assert ((disjoin text-2d? triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
   (assert (color? color))
   (assert (integer? layer))
   (int:make-visual-2d draw color layer))
 
 (define set-visual-2d-draw!
-  (guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
+  (guarded-mutator visual-2d? 'draw (disjoin text-2d? triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
 (define set-visual-2d-color!
   (guarded-mutator visual-2d? 'color color?))
 (define set-visual-2d-layer!
@@ -214,7 +237,7 @@
 
 ;; Drawing functions
 ;; Helper wrappers for raylib functions
-(export draw-circle-2d)
+(export draw-circle-2d draw-rectangle-2d draw-text-2d)
 (define (draw-circle-2d pos-vec radius color filled)
   (assert (vec2? pos-vec))
   (assert (number? radius))
@@ -222,9 +245,41 @@
   (assert (boolean? filled))
   ((if filled
        draw-circle
-       draw-circle-2d)
+       draw-circle-lines)
    (number->integer (v-x pos-vec))
    (number->integer (v-y pos-vec))
    (number->integer radius)
    (use-color color)))
-)
+
+(define (draw-rectangle-2d pos-vec width height color filled thickness)
+  (assert (vec2? pos-vec))
+  (assert ((conjoin integer? positive?) width))
+  (assert ((conjoin integer? positive?) height))
+  (assert ((conjoin integer? positive?) thickness))
+  (assert (boolean? filled))
+  (assert (color? color))
+  (if filled
+      (draw-rectangle
+       (number->integer (v-x pos-vec))
+       (number->integer (v-y pos-vec))
+       width
+       height
+       (use-color color))
+      (draw-rectangle-lines
+       (number->integer (v-x pos-vec))
+       (number->integer (v-y pos-vec))
+       width
+       height
+       (use-color color))))
+
+(define (draw-text-2d pos-vec text size tint)
+  (assert (vec2? pos-vec))
+  (assert (string? text))
+  (assert ((conjoin integer? positive?) size))
+  (assert (color? tint))
+  (draw-text text
+	     (number->integer (v-x pos-vec))
+	     (number->integer (v-y pos-vec))
+	     size
+	     (use-color tint)))
+  )

engine/input.scm

@@ -0,0 +1,61 @@
+(module (engine input) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	(engine core)
+	raylib
+	(srfi 99))
+
+(register-event-bus 'input)
+
+;; Input actions alist
+(define input-actions '())
+
+;; Key-press type action
+(define-record-type <key-press>
+  (make-key-press key)
+  key-press?
+  (key key-press-key))
+
+;; Mouse click type action
+(define-record-type <mouse-press>
+  (make-mouse-press button)
+  mouse-press?
+  (button mouse-press-button))
+
+;; Add a new action to the input actions alist
+(export register-action push-actions)
+(define (register-action name type . data)
+  (assert (symbol? name))
+  (assert (member type '(key-press mouse-press)))
+  (set! input-actions
+    (cons (cons name
+		(apply (cond
+			((eqv? type 'key-press) make-key-press)
+			((eqv? type 'mouse-press) make-mouse-press))
+		       data))
+	  input-actions)))
+
+;; Default global system for simple input management
+(define push-actions
+  (make-system
+   'push-actions
+   0
+   'global
+   '()
+   (lambda ()
+     (for-each
+      (lambda (action)
+	(cond
+	 ((key-press? (cdr action))
+	  (when (key-pressed? (key-press-key (cdr action)))
+	    (push-event 'input
+			(car action)
+			(cdr action))))
+	 ((mouse-press? (cdr action))
+	  (when (mouse-button-pressed? (mouse-press-button (cdr action)))
+	    (push-event 'input
+			(car action)
+			(cdr action))))))
+      input-actions))))
+)

samples/bounce.scm

@@ -5,6 +5,7 @@
 	(engine core)
 	(engine components core)
 	(engine math)
+	(engine input)
 	(engine drawing)
 	(engine scene)
 	(srfi 1)

samples/tic-tac-toe.scm

@@ -0,0 +1,383 @@
+(module (tic-tac-toe) ()
+(import scheme
+	(chicken base)
+	(chicken random)
+	(engine core)
+	(engine math)
+	(engine components core)
+	(engine drawing)
+	(engine input)
+	(engine scene)
+	raylib
+	(srfi 1)
+	(srfi 99))
+
+(register-event-bus 'turn-change)
+
+(define draw-text-entities
+  (make-system
+   'draw-text
+   0
+   'entity
+   '(<visual-2d> <screen-transform>)
+   (lambda (_ vis-2d transform)
+     (let ((draw (visual-2d-draw vis-2d)))
+       (when (text-2d? draw)
+	 (push-render-object 'screen
+			     (visual-2d-layer vis-2d)
+			     (lambda ()
+			       (let ((draw-pos (v+ (position transform)
+						   (text-2d-position draw))))
+				 (draw-text-2d
+				  draw-pos
+				  (text-2d-text draw)
+				  (text-2d-size draw)
+				  (visual-2d-color vis-2d))))))))))
+
+(define draw-rectangles
+  (make-system
+   'draw-rectangles
+   0
+   'entity
+   '(<visual-2d> <screen-transform>)
+   (lambda (_ vis-2d transform)
+     (let ((draw (visual-2d-draw vis-2d)))
+       (when (rectangle-2d? draw)
+	 (push-render-object 'screen
+			     (visual-2d-layer vis-2d)
+			     (lambda ()
+			       (let ((draw-pos (v+ (position transform)
+						   (rectangle-2d-origin draw))))
+				 (draw-rectangle-2d
+				  draw-pos
+				  (rectangle-2d-width draw)
+				  (rectangle-2d-height draw)
+				  (visual-2d-color vis-2d)
+				  (rectangle-2d-filled? draw)
+				  (rectangle-2d-thickness draw))))))))))
+
+(register-action 'click 'mouse-press MOUSE_BUTTON_LEFT)
+
+(define-record-type <button-region>
+  (make-button-region top-left bottom-right on-click)
+  button-region?
+  (top-left button-top-left)
+  (bottom-right button-bottom-right)
+  (on-click button-on-click))
+
+(define click-buttons
+  (make-system
+   'click-buttons
+   1
+   'batch
+   '(<button-region> <screen-transform>)
+   (lambda (buttons)
+     (when (pop-event 'input 'click)
+       (for-each
+	(lambda (button)
+	  (let* ((btn (find button-region? button))
+		 (transform (find screen-transform? button))
+		 (top-left (v+ (position transform)
+			       (button-top-left btn)))
+		 (bottom-right (v+ (position transform)
+				   (button-bottom-right btn)))
+		 (m-x (get-mouse-x))
+		 (m-y (get-mouse-y)))
+	    (when (and (< (v-x top-left) m-x (v-x bottom-right))
+		       (< (v-y top-left) m-y (v-y bottom-right)))
+	      ((button-on-click btn)))))
+	buttons)))))
+
+(define grid '((0 0 0)
+	       (0 0 0)
+	       (0 0 0)))
+
+(define turn 'player) ;; Either 'player or 'bot
+
+(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
+  (make-system
+   'draw-grid-squares
+   0
+   'entity
+   '(<screen-transform> <grid-square>)
+   (lambda (_ transform sq)
+     (let ((check (list-ref (list-ref grid (g-y sq)) (g-x sq))))
+       (push-render-object 'screen
+			   0
+			   (lambda ()
+			     (draw-text-2d
+			      (v+ (v/ grid-square-size 4) (position transform))
+			      (cond
+			       ((= check 1) "X")
+			       ((= check 2) "O")
+			       (else ""))
+			      64
+			      (make-color 0 0 0 1))))))))
+
+(define-record-type <grid-square>
+  (make-g-s x y)
+  grid-square?
+  (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)
+   (make-screen-transform
+    (v+ padding (v* (vec x y) grid-square-size))
+    (vec 0 0)
+    0
+    (vec 1 1)
+    'center
+    '())
+   (make-visual-2d
+    (make-rectangle-2d
+     (vec 0 0)
+     (v-x grid-square-size)
+     (v-y grid-square-size)
+     #f
+     10)
+    (make-color 0 0 0 1)
+    0)
+   (make-button-region
+    (vec 0 0)
+    grid-square-size
+    (lambda ()
+      (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)
+   (make-grid-square 2 0)
+   (make-grid-square 0 1)
+   (make-grid-square 1 1)
+   (make-grid-square 2 1)
+   (make-grid-square 0 2)
+   (make-grid-square 1 2)
+   (make-grid-square 2 2)))
+
+(define (main-menu)
+  (scene
+   draw-text-entities
+   click-buttons
+   draw-rectangles
+   push-actions
+
+   (entity
+    (make-screen-transform
+     (vec 350 250)
+     (vec 0 0)
+     0
+     (vec 1 1)
+     'center
+     '())
+    (make-visual-2d
+     (make-text-2d
+      (vec 0 0)
+      "Start Game!"
+      12)
+     (make-color 0 0 0 1)
+     0))
+   
+   (entity
+    (make-button-region
+     (vec 0 0)
+     (vec 100 80)
+     (lambda ()
+       ((game))))
+    (make-visual-2d
+     (make-rectangle-2d
+      (vec 0 0)
+      100
+      80
+      #t
+      1)
+     (make-color 1 0 0 1)
+     0)
+    (make-screen-transform
+     (vec 350 250)
+     (vec 0 0)
+     0
+     (vec 1 1)
+     'center
+     '()))
+   
+   (entity
+    (make-visual-2d
+     (make-text-2d
+      (vec 0 0)
+      "Tic Tac Toe!"
+      48)
+     (make-color 0 0 0 1)
+     0)
+    (make-screen-transform
+     (vec 250 150)
+     (vec 0 0)
+     0
+     (vec 1 1)
+     'center
+     '()))))
+
+((main-menu))
+(create-window)
+)