blob: ce1228543b9d997d3921dc4498256f994b5b0e8c (
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
|
#lang racket/gui
(provide show-window)
(require racket/format)
(require racket/class)
(require (planet williams/table-panel:1:2/table-panel))
;(require table-panel)
(require "full-parse.rkt")
(define ns (make-base-namespace))
(namespace-set-variable-value! '^ expt #t ns)
(define (show-window)
(define frame (new frame% [label "Calculator"]))
(define msg (new message%
[parent frame]
[label ""]))
(define root-panel (new vertical-panel%
[parent frame]
[alignment '(left top)]))
(define top-op-panel (new horizontal-panel%
[parent root-panel]
[alignment '(left top)]))
(define center-panel (new horizontal-panel%
[parent root-panel]
[alignment '(left top)]))
(define number-panel (new table-panel%
[parent center-panel]
[alignment '(left top)]))
(define left-op-panel (new vertical-panel%
[parent center-panel]
[alignment '(left top)]))
(define bottom-op-panel (new horizontal-panel%
[parent root-panel]
[alignment '(left top)]))
(send number-panel set-dimensions 3 3)
(define (setup-num-btn lbl par)
(new button%
[parent par]
[label (~a lbl)]
[min-width 30]
[callback
(lambda (button event)
(send msg
set-label
(string-append
(send msg get-label)
(send button get-label))))]))
(map (lambda (x) (setup-num-btn x top-op-panel)) '("(" ")" "/"))
(map
(lambda (x) (setup-num-btn x number-panel))
(range 1 10))
(map
(lambda (x) (setup-num-btn x left-op-panel))
'(* - +))
(map
(lambda (x) (setup-num-btn x bottom-op-panel))
'(0 "." ^ ))
(new button%
[parent top-op-panel]
[label "←"]
[min-width 30]
[callback
(lambda (button event)
(define str (send msg get-label))
(send msg set-label (substring str 0 (- (string-length str) 1))))])
(new button%
[parent bottom-op-panel]
[label "="]
[min-width 30]
[callback
(lambda (button event)
(define ^ expt)
(send msg set-label (~a
(eval (full-parse (send msg get-label)) ns))))])
(send frame show #t))
|
