Basic main menu and README

modules/ui.scm

@@ -0,0 +1,198 @@
+(module (bd ui) ()
+(import scheme
+	(chicken base)
+	(chicken module)
+	raylib
+	(imugi core)
+	(imugi math)
+	(imugi drawing)
+	(imugi resource)
+	(imugi input)
+	(srfi 1)
+	(srfi 4)
+	(srfi 99))
+
+(define base-font (font "../res/fonts/Felipa-Regular.ttf"))
+
+(define-record-type <label>
+  (int:make-label position centered? layer font font-size color text)
+  label?
+  (position label-pos set-label-pos!)
+  (centered? label-centered? set-label-centered!)
+  (layer label-layer set-label-layer!)
+  (font-size label-size set-label-size!)
+  (font label-font set-label-font!)
+  (color label-color set-label-color!)
+  (text label-text set-label-text!))
+
+(export title)
+(define (title position text
+	       #!key
+	       (centered (cons #f #f))
+	       (layer 0)
+	       (font base-font)
+	       (size 128)
+	       (color (make-color 0 0 0 1)))
+  (int:make-label position centered layer font size color text))
+
+(export subtitle)
+(define (subtitle position text
+		  #!key
+		  (centered (cons #f #f))
+		  (layer 0)
+		  (font base-font)
+		  (size 36)
+		  (color (make-color 0 0 0 1)))
+  (int:make-label position centered layer font size color text))
+
+(export footer)
+(define (footer position text
+		#!key
+		(centered (cons #f #f))
+		(layer 0)
+		(font base-font)
+		(size 24)
+		(color (make-color 0 0 0 1)))
+  (int:make-label position centered layer font size color text))
+
+(export draw-labels)
+(define draw-labels
+  (make-system
+   'draw-labels
+   10
+   'entity
+   '(<label>)
+   (lambda (_ label)
+     (push-render-object
+      'screen
+      (label-layer label)
+      (lambda ()
+	(let* (;; measure text length in pixels in case
+	       ;; we need it for horizontal centering
+	       (text-length (f32vector->list
+			     (measure-text-ex
+			      (resource-contents (label-font label))
+			      (label-text label)
+			      (label-size label)
+			      1)))
+	       ;; center the x/y of the position
+	       ;; based on label-centered?
+	       (draw-pos (vec
+			  (if (car (label-centered? label))
+			      (- (/ (car (*window-size*))
+				    2)
+				 (/ (car text-length)
+				    2))
+			      (v-x (label-pos label)))
+			  (if (cdr (label-centered? label))
+			      (- (/ (cdr (*window-size*))
+				    2)
+				 (cadr text-length))
+			      (v-y (label-pos label))))))
+	  (draw-font-text-2d
+	   draw-pos
+	   (label-text label)
+	   (label-size label)
+	   (label-color label)
+	   (label-font label))))))))
+
+(define-record-type <button>
+  (int:make-button position size layer label state click-fn colors)
+  button?
+  (position button-pos set-button-pos!)
+  (size button-size set-button-size!)
+  (layer button-layer set-button-layer!)
+  (label button-label set-button-label!)
+  (state button-state set-button-state!)
+  (click-fn button-click-fn set-button-click-fn!)
+  (colors button-colors set-button-colors!))
+
+(export button)
+(define (button position label click-fn
+		#!key
+		(layer 0)
+		(size (vec 100 60))
+		(colors (list (make-color 0.48 0.48 0.48 1)
+			      (make-color 0.63 0.63 0.63 1)
+			      (make-color 0.39 0.39 0.39 1))))
+  (int:make-button position size layer label 'ready click-fn colors))
+
+(define (check-button-state button)
+  (let ((x-range (cons (v-x (button-pos button))
+		       (+ (v-x (button-pos button))
+			  (v-x (button-size button)))))
+	(y-range (cons (v-y (button-pos button))
+		       (+ (v-y (button-pos button))
+			  (v-y (button-size button)))))
+	(mouse-pos (cons (get-mouse-x) (get-mouse-y))))
+    (if (and (< (car x-range) (car mouse-pos) (cdr x-range))
+	     (< (car y-range) (cdr mouse-pos) (cdr y-range)))
+	(if (peek-event 'input 'click)
+	    (set-button-state! button 'clicked)
+	    (set-button-state! button 'hovered))
+	(set-button-state! button 'ready))))
+
+(define (draw-button button)
+  (push-render-object
+   'screen
+   (button-layer button)
+   (lambda ()
+     (draw-rectangle-2d
+      (button-pos button)
+      (number->integer (v-x (button-size button)))
+      (number->integer (v-y (button-size button)))
+      (list-ref (button-colors button)
+		(case (button-state button)
+		  ((ready) 0)
+		  ((hovered) 1)
+		  ((clicked) 2)))
+      #t
+      1)))
+  (let* ((txt (button-label button))
+	 (text-length (f32vector->list
+		       (measure-text-ex
+			(resource-contents (label-font txt))
+			(label-text txt)
+			(label-size txt)
+			1)))
+	 (center-offset (vec (- (/ (v-x (button-size button))
+				   2)
+				(/ (car text-length)
+				   2))
+			     (- (/ (v-y (button-size button))
+				   2)
+				(/ (cadr text-length)
+				   2)))))
+    (push-render-object
+     'screen
+     (+ 1 (button-layer button))
+     (lambda ()
+       (draw-font-text-2d
+	(v+ (button-pos button)
+	    center-offset)
+	(label-text txt)
+	(label-size txt)
+	(label-color txt)
+	(label-font txt))))))
+
+(define (do-button-callback button)
+  (when (eqv? 'clicked (button-state button))
+    ((button-click-fn button))))
+
+(export handle-buttons)
+(define handle-buttons
+  (make-system
+   'handle-buttons
+   10
+   'batch
+   '(<button>)
+   (lambda (buttons)
+     (for-each
+      (lambda (b)	
+	(let ((button (find button? b)))
+	  (check-button-state button)
+	  (draw-button button)
+	  (do-button-callback button)))
+      buttons)
+     (pop-event 'input 'click))))
+)