-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathgui.rkt
65 lines (59 loc) · 4.08 KB
/
gui.rkt
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
#lang typed/racket/gui
(provide (all-defined-out))
(provide (all-from-out "digitama/gui/timer.rkt"))
(require "digitama/gui/timer.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax (fill-box! stx)
(syntax-case stx [<= =]
[(_ (w h d a t b) <= bmp) (syntax/loc stx (fill-box! (w h d a t b) ((send bmp get-width) (send bmp get-height) 0 0 0 0)))]
[(_ (w h d a) <= bmp) (syntax/loc stx (fill-box! (w h d a) ((send bmp get-width) (send bmp get-height) 0 0)))]
[(_ (w h) <= bmp) (syntax/loc stx (fill-box! (w h) ((send bmp get-width) (send bmp get-height))))]
[(_ (opbox ...) = v) (syntax/loc stx (begin (fill-box! opbox v) ...))]
[(_ (opbox ...) (v ...)) (syntax/loc stx (begin (fill-box! opbox v) ...))]
[(_ opbox v) (syntax/loc stx (when (box? opbox) (set-box! opbox (max 0 v))))]))
(define default.cur : (Instance Cursor%) (make-object cursor% 'arrow))
(define blank.cur : (Instance Cursor%) (make-object cursor% 'blank))
(define watch.cur : (Instance Cursor%) (make-object cursor% 'watch))
(define bullseye.cur : (Instance Cursor%) (make-object cursor% 'bullseye))
(define cross.cur : (Instance Cursor%) (make-object cursor% 'cross))
(define hand.cur : (Instance Cursor%) (make-object cursor% 'hand))
(define ibeam.cur : (Instance Cursor%) (make-object cursor% 'ibeam))
(define size-e/w.cur : (Instance Cursor%) (make-object cursor% 'size-e/w))
(define size-n/s.cur : (Instance Cursor%) (make-object cursor% 'size-n/s))
(define size-ne/sw.cur : (Instance Cursor%) (make-object cursor% 'size-ne/sw))
(define size-nw/se.cur : (Instance Cursor%) (make-object cursor% 'size-nw/se))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define change-style : (->* ((Instance Style<%>))
(#:font (Option (Instance Font%))
#:color (Option (Instance Color%))
#:background-color (Option (Instance Color%)))
(Instance Style<%>))
(lambda [style #:font [font #false] #:color [color #false] #:background-color [bgcolor #false]]
(send style set-delta
(let* ([style (make-object style-delta%)]
[style (if (false? color) style (send style set-delta-foreground color))]
[style (if (false? bgcolor) style (send style set-delta-background bgcolor))])
(cond [(false? font) style]
[else (send* style
(set-face (send font get-face))
(set-family (send font get-family)))
(send+ style
(set-delta 'change-style (send font get-style))
(set-delta 'change-weight (send font get-weight))
(set-delta 'change-smoothing (send font get-smoothing))
(set-delta 'change-underline (send font get-underlined))
(set-delta 'change-size (min (exact-round (send font get-size)) 255)))])))
style))
#;(define change-default-style! : (->* ((U (Instance Editor<%>) (Instance Style-List%)))
(#:font (Option (Instance Font%))
#:color (Option (Instance Color%))
#:background-color (Option (Instance Color%)))
(Instance Style<%>))
(lambda [src #:font [font #false] #:color [color #false] #:background-color [bgcolor #false]]
(define-values (style-list style-name)
(cond [(text%? src) (values (send src get-style-list) (send src default-style-name))]
[(pasteboard%? src) (values (send src get-style-list) (send src default-style-name))]
[else (values (if (style-list%? src) src (make-object style-list%)) "Standard")]))
(change-style #:font font #:color color #:background-color bgcolor
(or (send style-list find-named-style style-name)
(send style-list new-named-style style-name (send style-list basic-style))))))