1#lang scheme/base
2
3;; Mon Mar 27 10:29:28 EST 2006: integrated Felix's mouse events
4;; Wed Jan 25 13:38:42 EST 2006: on-redraw: proc is now called on installation
5;; Tue Jan  3 11:17:50 EST 2006: changed add-line behavior in world.rkt
6;; Sat Dec 10 19:39:03 EST 2005: fixed name, changed interface to on-key-event
7;; Fri Dec  9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw
8;; Thu Dec  1 17:03:03 EST 2005: fixed place-image; all coordinates okay now
9
10  (require
11   (except-in mred make-color)
12   mzlib/class
13   htdp/error
14   "image.rkt"
15   (prefix-in beg: lang/htdp-beginner)
16   lang/prim
17   deinprogramm/signature/signature-syntax)
18
19  ;; --- provide ---------------------------------------------------------------
20  (provide (all-from-out "image.rkt"))
21
22  (provide      ;; forall(World):
23   big-bang     ;; Number Number Number World -> true
24   end-of-time  ;; String u Symbol -> World
25   )
26
27  (provide-higher-order-primitive
28   on-tick-event (tock) ;; (World -> World) -> true
29   )
30
31  (provide-higher-order-primitive
32   on-redraw (world-image) ;; (World -> Image) -> true
33   )
34
35  ;; KeyEvent is one of:
36  ;; -- Char
37  ;; -- Symbol
38
39  (provide-higher-order-primitive ;; (World KeyEvent -> World) -> true
40   on-key-event
41   (draw)
42   )
43
44  ;; A MouseEventKind is one of:
45  ;; "enter" -- mouse pointer entered the window
46  ;; "leave" -- mouse pointer left the window
47  ;; "left-down" -- left mouse button pressed
48  ;; "left-up" -- left mouse button released
49  ;; "middle-down" -- middle mouse button pressed
50  ;; "middle-up" -- middle mouse button released
51  ;; "right-down" -- right mouse button pressed (Mac OS: click with control key pressed)
52  ;; "right-up" -- right mouse button released (Mac OS: release with control key pressed)
53  ;; "motion" -- mouse moved, with or without button(s) pressed
54
55
56  (provide-higher-order-primitive ;; (World Number Number MouseEventKind -> World) -> true
57   on-mouse-event
58   (clack)
59   )
60
61  (provide mouse-event-kind)
62
63  (define mouse-event-kind
64    (signature
65     (one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up")))
66
67  ;; ---------------------------------------------------------------------------
68
69  ;; Symbol Any String -> Void
70  (define (check-pos tag c rank)
71    (check-arg tag (and (number? c) (integer? c) (>= c 0)) "positive integer" rank c))
72
73  ;; ---------------------------------------------------------------------------
74
75  ;; The One and Only Visible World
76  (define the-frame #f)
77  (define txt (new text%))
78
79  ;; World (type parameter)
80  (define the-world0 (cons 1 1))
81  [define the-world the-world0]
82
83  (define (check-world tag)
84    (when (eq? the-world0 the-world) (error tag SEQUENCE-ERROR)))
85
86  ;; Number > 0
87  [define the-delta 1000]
88
89  ;; Amount of space around the image in the world window:
90  (define INSET 5)
91
92  ;; Number Number Number World -> true
93  ;; create the visible world (canvas)
94  (define (big-bang w h delta world)
95    (check-pos 'big-bang w "first")
96    (check-pos 'big-bang h "second")
97    (check-arg 'big-bang
98               (and (number? delta) (<= 0 delta 1000))
99               "number [of seconds] between 0 and 1000"
100               "first"
101               delta)
102    (when the-frame (error 'big-bang "big-bang already called once"))
103    (set! the-delta delta)
104    (set! the-world world)
105    (set! the-frame
106          (new (class frame%
107                 (super-new)
108                 (define/augment (on-close)
109                   ;; shut down the timer when the window is destroyed
110                   (send the-time stop)
111                   (inner (void) on-close)))
112               (label "DrRacket")
113               (stretchable-width #f)
114               (stretchable-height #f)
115               (style '(no-resize-border metal))))
116    (let ([c (new (class editor-canvas%
117		    (super-new)
118		    (define/override (on-char e)
119		      (on-char-proc (send e get-key-code)))
120		    (define/override (on-event e)
121		      (on-mouse-proc e)))
122                  (parent the-frame)
123                  (editor txt)
124                  (style '(no-hscroll no-vscroll))
125                  (horizontal-inset INSET)
126                  (vertical-inset INSET))])
127      (send c min-client-width (+ w INSET INSET))
128      (send c min-client-height (+ h INSET INSET))
129      (send c focus))
130    (send txt set-cursor (make-object cursor% 'arrow))
131    (send txt hide-caret #t)
132    (send the-frame show #t)
133    #t)
134
135  ;; --- time events
136  [define the-time (new timer% [notify-callback (lambda () (timer-callback))])]
137
138  ;; (World -> World)
139  [define timer-callback void]
140
141  [define (on-tick-event f)
142    (check-proc 'on-tick-event f 1 "on-tick-event" "one argument")
143    (check-world 'on-tick-event)
144    (if (eq? timer-callback void)
145        (set! timer-callback
146              (lambda ()
147                (with-handlers ([exn:break? break-handler]
148                                [exn? exn-handler])
149                  (set! the-world (f the-world))
150                  (on-redraw-proc))))
151        (error 'on-tick "the timing action has been set already"))
152    (send the-time start
153          (let* ([w (ceiling (* 1000 the-delta))])
154            (if (exact? w) w (inexact->exact w))))
155    #t]
156
157  ;; --- key and mouse events
158
159  ;; KeyEvent -> Void
160  [define on-char-proc void]
161
162  [define (on-key-event f)
163    (check-proc 'on-key-event f 2 "on-key-event" "two arguments")
164    (check-world 'on-key-event)
165    (let ([esp (current-eventspace)])
166      (if (eq? on-char-proc void)
167          (begin
168            (set! on-char-proc
169                  (lambda (e)
170		    (cond
171		     ((event->string e)
172		      => (lambda (s)
173			   (parameterize ([current-eventspace esp])
174			     (queue-callback
175			      (lambda ()
176				(with-handlers ([exn:break? break-handler]
177						[exn? exn-handler])
178				  (set! the-world (f the-world s))
179				  (on-redraw-proc))))))))
180		    #t))
181            #t)
182          (error 'on-event "the event action has been set already")))]
183
184  (define (event->string e)
185    (if (char? e)
186	(string e)
187	(case e
188	  ((left) "left")
189	  ((right) "right")
190	  ((up) "up")
191	  ((down) "down")
192	  ((wheel-up) "wheel-up")
193	  ((wheel-down) "wheel-down")
194	  (else #f))))
195
196  [define (end-of-time s)
197    (printf "end of time: ~a\n" s)
198    (stop-it)
199    the-world]
200
201  ;; MouseEvent -> Void
202  [define on-mouse-proc void]
203
204  [define (on-mouse-event f)
205    (check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments")
206    (check-world 'on-mouse-event)
207    (let ([esp (current-eventspace)])
208      (if (eq? on-mouse-proc void)
209          (begin
210            (set! on-mouse-proc
211                  (lambda (e)
212                    (parameterize ([current-eventspace esp])
213                      (queue-callback
214                       (lambda ()
215                         (with-handlers ([exn:break? break-handler]
216                                         [exn? exn-handler])
217                           (set! the-world (f the-world
218                                              (send e get-x)
219                                              (send e get-y)
220					      (symbol->string (send e get-event-type))))
221                           (on-redraw-proc))))
222                      #t)))
223            #t)
224          (error 'on-mouse-event "the mouse event action has been set already")))]
225
226  ;; --- library
227  [define (exn-handler e)
228    (send the-time stop)
229    (set! on-char-proc void)
230    (set! timer-callback void)
231    (raise e)]
232
233  [define (break-handler . _)
234    (printf "animation stopped")
235    (stop-it)
236    the-world]
237
238  ;; -> Void
239  (define (stop-it)
240    (send the-time stop)
241    (set! on-char-proc void)
242    (set! timer-callback void))
243
244  (define on-redraw-proc void)
245
246  (define (on-redraw f)
247    (check-proc 'on-redraw f 1 "on-redraw" "one argument")
248    (check-world 'on-redraw)
249    (if (eq? on-redraw-proc void)
250        (begin
251          (set! on-redraw-proc
252                (lambda ()
253                  (with-handlers ([exn:break? break-handler]
254                                  [exn? exn-handler])
255                    (define img (f the-world))
256                    (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img)
257                    (update-frame img)
258                    #t)))
259          (on-redraw-proc))
260        (error 'on-redraw "the redraw function has already been specified")))
261
262  (define (update-frame pict)
263    (send txt begin-edit-sequence)
264    (send txt lock #f)
265    (send txt delete 0 (send txt last-position) #f)
266    (send txt insert (send pict copy) 0 0 #f)
267    (send txt lock #t)
268    (send txt end-edit-sequence))
269
270  (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first")
271