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