Main menu for tic-tac-toe and text/rectangle drawing functions

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,35 @@
   (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))
+  (when filled
+    (draw-rectangle
+     (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,172 @@
+(module (tic-tac-toe) ()
+(import scheme
+	(chicken base)
+	(engine core)
+	(engine math)
+	(engine components core)
+	(engine drawing)
+	(engine input)
+	(engine scene)
+	raylib
+	(srfi 1)
+	(srfi 99))
+
+(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 (game)
+  (scene
+   draw-text-entities
+
+   (entity
+    (make-screen-transform
+     (vec 350 250)
+     (vec 0 0)
+     0
+     (vec 1 1)
+     'center
+     '())
+    (make-visual-2d
+     (make-text-2d
+      (vec 0 0)
+      "You lost the game!"
+      12)
+     (make-color 0 0 0 1)
+     0))))
+
+(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)
+)