blob: 5c3cf170c01b2efb2c9816901cabcb634f71ce48 (
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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; Commentary:
;;
;; System overlay scene for notifications and developer tools.
;;
;;; Code:
(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))
(define %background-color (make-color 0.2 0.2 0.2 0.8))
(define-class <overlay> (<scene>))
(define (make-overlay)
(make <overlay> #:name '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-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 (current-kernel)))))
(define (scene-for-region name)
(let ((r (find-region-by-name name)))
(and r (scene r))))
(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* ((s (scene-for-region 'overlay))
(f (and s (& s fps-display))))
(when f (detach f))))
(define-minibuffer-command repl
(let ((s (scene-for-region 'overlay)))
(when s
(push-major-mode s (make <repl-mode>)))))
|
