blob: 31a14422e20d9adf49f0cba34e465669639a7997 (
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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
(define-module (catbird overlay)
#:use-module (catbird kernel)
#:use-module (catbird input-map)
#:use-module (catbird minibuffer)
#:use-module (catbird node)
#:use-module (catbird node-2d)
#:use-module (catbird region)
#:use-module (catbird repl)
#:use-module (catbird scene)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics path)
#:use-module (chickadee graphics text)
#:use-module (chickadee math vector)
#:use-module (chickadee scripting)
#:use-module (ice-9 format)
#:use-module (oop goops)
#:export (make-overlay
notify
open-minibuffer))
(define %background-color (make-color 0.2 0.2 0.2 0.8))
(define-class <overlay> (<scene>))
(define (make-overlay)
(make <overlay>))
(define-method (notify (scene <overlay>) message)
(run-script scene
(let* ((padding 8.0)
(label (make <label>
#:name 'message
#:rank 1
#:position (vec2 padding padding)
#:text message))
(region (car (regions scene)))
(bg (make <canvas>
#:name 'background
#:painter
(with-style ((fill-color %background-color))
(fill
(rounded-rectangle (vec2 0.0 0.0)
(+ (width label) padding padding)
(+ (height label) padding)
#:radius 2.0)))))
(notification (make <node-2d>
#:position (vec2 padding
(- (height (camera region))
(height bg)
padding)))))
(attach-to notification bg label)
(attach-to scene notification)
(sleep 5.0)
(detach notification))))
(define-method (open-minibuffer)
(let ((r (find-region-by-name 'overlay)))
(push-major-mode (scene r) (make <minibuffer-mode>))))
(define-class <fps-display> (<node-2d>))
(define-method (on-boot (fps-display <fps-display>))
(let* ((font (default-font))
(padding 4.0)
(box-width (+ (font-line-width font "999.9")
(* padding 2.0)))
(box-height (+ (font-line-height font) padding)))
(attach-to fps-display
(make <canvas>
#:name 'background
#:painter
(with-style ((fill-color (make-color 0 0 0 0.5)))
(fill
(rectangle (vec2 0.0 0.0)
box-width
box-height))))
(make <label>
#:name 'label
#:rank 1
#:font font
#:position (vec2 padding padding)))
(set! (width fps-display) box-width)
(set! (height fps-display) box-height)
(set! (origin-y fps-display) box-height)
(update-fps fps-display)
(run-script fps-display
(forever
(sleep 1.0)
(update-fps fps-display)))))
(define-method (update-fps (fps-display <fps-display>))
(set! (text (& fps-display label))
(format #f "~1,1f" (frames-per-second))))
(define-minibuffer-command show-fps
(let* ((r (find-region-by-name 'overlay))
(s (and r (scene r))))
(when (and s (not (& s fps-display)))
(attach-to s (make <fps-display>
#:name 'fps-display
#:rank 99
#:position (vec2 0.0 (area-height r)))))))
(define-minibuffer-command hide-fps
(let* ((r (find-region-by-name 'overlay))
(s (and r (scene r)))
(f (and s (& s fps-display))))
(when f (detach f))))
(define-minibuffer-command repl
(let* ((r (find-region-by-name 'overlay))
(s (and r (scene r))))
(when s
(push-major-mode s (make <repl-mode>)))))
(bind-input/global (key-press 'x '(alt)) open-minibuffer)
|
