1 files changed, 92 insertions, 0 deletions
diff --git a/apple-town-fair/menu.scm b/apple-town-fair/menu.scm
new file mode 100644
index 0000000..ad3b893
--- /dev/null
+++ b/apple-town-fair/menu.scm
@@ -0,0 +1,92 @@
+;;; Copyright © 2022 David Thompson <davet@gnu.org>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+(define-module (apple-town-fair menu)
+  #:use-module (apple-town-fair assets)
+  #:use-module (apple-town-fair common)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics path)
+  #:use-module (chickadee graphics text)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math vector)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<menu>
+            down-selection
+            selection
+            up-selection))
+
+
+(define-class <menu> (<node-2d>)
+  (items #:accessor items #:init-keyword #:items)
+  (item-nodes #:accessor item-nodes)
+  (selected-item #:accessor selected-item))
+
+(define-method (on-boot (menu <menu>))
+  (let ((nodes (map (lambda (item)
+                      (make <label>
+                        #:rank 1
+                        #:font monogram-font
+                        #:text item))
+                    (items menu)))
+        (padding 2.0))
+    (attach-to menu
+               (make <canvas>
+                 #:name 'highlight
+                 #:painter
+                 (with-style ((fill-color red))
+                   (fill
+                    (rectangle (vec2 0.0 0.0)
+                               (fold (lambda (node w)
+                                       (max w (width node)))
+                                     0.0
+                                     nodes)
+                               (fold (lambda (node h)
+                                       (max h (height node)))
+                                     0.0
+                                     nodes))))))
+    (apply attach-to menu nodes)
+    (let loop ((nodes (reverse nodes))
+               (prev #f))
+      (match nodes
+        (() #t)
+        ((node . rest)
+         (when prev
+           (place-above prev node #:padding padding))
+         (loop rest node))))
+    (set! (item-nodes menu) nodes)
+    (select-item menu 0)))
+
+(define-method (select-item (menu <menu>) i)
+  (let* ((i (clamp 0 (- (length (items menu)) 1) i))
+         (node (list-ref (item-nodes menu) i)))
+    (set! (selected-item menu) i)
+    (when node
+      (set! (position-y (& menu highlight))
+            (position-y node)))))
+
+(define-method (selection (menu <menu>))
+  (let ((node (list-ref (item-nodes menu) (selected-item menu))))
+    (and node (text node))))
+
+(define-method (up-selection (menu <menu>) n)
+  (select-item menu (- (selected-item menu) n)))
+
+(define-method (down-selection (menu <menu>) n)
+  (select-item menu (+ (selected-item menu) n)))