diff options
Diffstat (limited to 'apple-town-fair/menu.scm')
-rw-r--r-- | apple-town-fair/menu.scm | 92 |
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))) |