blob: 3ec4b2e4079c6f6e51293a47ff36a502cec27a7e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
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))
(nodes (item-nodes menu)))
(set! (selected-item menu) i)
(unless (null? nodes)
(set! (position-y (& menu highlight))
(position-y (list-ref nodes i))))))
(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)))
|
