diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss new file mode 100644 index 0000000000..b0a404c4d7 --- /dev/null +++ b/collects/2htdp/private/check-aux.ss @@ -0,0 +1,174 @@ +#lang scheme + +(require htdp/image + htdp/error + (only-in lang/htdp-beginner image?)) + +(provide (all-defined-out)) + +(define INSET 5) ;; the space around the image in the canvas +(define RATE 1/30) ;; the clock tick rate +(define TRIES 3) ;; how many times should register try to connect to the server +(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server +(define SQPORT 4567) ;; the port on which universe traffic flows + +(define (K w . r) w) +(define (False w) #f) + +; +; +; +; ;;; ;;; +; ; ; ; ; +; ; ; ; ; +; ; ;;; ;;;;; ;;;;; ;;; ;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; +; ;;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ;; +; +; +; + +;; ----------------------------------------------------------------------------- + +;; Any -> Boolean +(define (scene? i) + (and (image? i) (internal-scene? i))) + +;; Image -> Boolean +(define (internal-scene? i) + (and (= 0 (pinhole-x i)) (= 0 (pinhole-y i)))) + +;; Number -> Integer +(define (number->integer x) + (inexact->exact (floor x))) + +;; ----------------------------------------------------------------------------- +;; Nat Nat ->String +;; converts i to a string, adding leading zeros, make it at least as long as L +(define (zero-fill i L) + (let ([n (number->string i)]) + (string-append (make-string (max (- L (string-length n)) 0) #\0) n))) + +;; ----------------------------------------------------------------------------- + +;; MouseEvent -> [List Nat Nat MouseEventType] +;; turn a mouse event into its pieces +(define (mouse-event->parts e) + (define x (- (send e get-x) INSET)) + (define y (- (send e get-y) INSET)) + (list x y (cond [(send e button-down?) 'button-down] + [(send e button-up?) 'button-up] + [(send e dragging?) 'drag] + [(send e moving?) 'move] + [(send e entering?) 'enter] + [(send e leaving?) 'leave] + [else ; (send e get-event-type) + (error 'on-mouse-event + (format + "Unknown event type: ~a" + (send e get-event-type)))]))) + +;; ----------------------------------------------------------------------------- +;; Any -> Symbol +(define (name-of draw tag) + (define fname (object-name draw)) + (if fname fname tag)) + +;; ----------------------------------------------------------------------------- +;; Any -> Boolean +(define (sexp? x) + (cond + [(empty? x) true] + [(string? x) true] + [(symbol? x) true] + [(number? x) true] + [(char? x) true] + [(pair? x) (and (list? x) (andmap sexp? x))] + [else false])) + +(define (no-newline? x) + (not (member #\newline (string->list x)))) + +;; ----------------------------------------------------------------------------- +;; exchange one-line messages between worlds and the server + +(define tcp-eof (gensym 'tcp-eof)) + +;; Any -> Boolean +(define (tcp-eof? a) (eq? tcp-eof a)) + +;; OutPort Sexp -> Void +(define (tcp-send out msg) + (write msg out) + (newline out) + (flush-output out)) + +;; InPort -> Sexp +(define (tcp-receive in) + (with-handlers ((exn? (lambda (x) (raise tcp-eof)))) + (define x (read in)) + (if (eof-object? x) + (raise tcp-eof) + (begin + (read-line in) ;; read the newline + x)))) + +; +; +; +; ;;; ;;; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ; ;; ;;;; ; ;;;; ; ; +; ;;;;; ;; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;;;; ;;; ; ; ; ; +; ; +; ; ; +; ;;; + +;; Symbol Any String -> Void +(define (check-pos t c r) + (check-arg + t (and (number? c) (> (number->integer c) 0)) "positive integer" r c)) + +;; Symbol Any String String *-> Void +(define (check-image tag i rank . other-message) + (if (and (pair? other-message) (string? (car other-message))) + (check-arg tag (image? i) (car other-message) rank i) + (check-arg tag (image? i) "image" rank i))) + +;; Symbol Any String -> Void +(define (check-scene tag i rank) + (define error "image with pinhole at (~s,~s)") + (if (image? i) + (check-arg tag (internal-scene? i) "scene" rank (image-pins i)) + (check-arg tag #f "scene" rank i))) + +;; Symbol Any -> Void +(define (check-scene-result tname i) + (if (image? i) + (check-result tname internal-scene? "scene" i (image-pins i)) + (check-result tname (lambda (x) (image? x)) "scene" i))) + +(define (image-pins i) + (format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i))) + + +;; Symbol Any String -> Void +(define (check-color tag width rank) + (check-arg tag (or (symbol? width) (string? width)) + "color symbol or string" rank width)) + +;; Symbol (union Symbol String) Nat -> Void +(define (check-mode tag s rank) + (check-arg tag (or (eq? s 'solid) + (eq? s 'outline) + (string=? "solid" s) + (string=? "outline" s)) "mode (solid or outline)" rank s)) + diff --git a/collects/2htdp/private/design.txt b/collects/2htdp/private/design.txt new file mode 100644 index 0000000000..df68373fc0 --- /dev/null +++ b/collects/2htdp/private/design.txt @@ -0,0 +1,17 @@ + +Files for constructing universe.ss: + + world.ss the old world + world% = (clock-mixin ...) -- the basic world + aworld% = (class world% ...) -- the world with recording + + universe.ss the universe server + universe% = (clock-mixin ...) -- the basic universe + + timer.ss the clock-mixin + + check-aux.ss common primitives + image.ss the world image functions + syn-aux.ss syntactic auxiliaries + syn-aux-aux.ss auxiliaries to the syntactic auxiliaries + diff --git a/collects/2htdp/private/image.ss b/collects/2htdp/private/image.ss new file mode 100644 index 0000000000..de4c4b39ce --- /dev/null +++ b/collects/2htdp/private/image.ss @@ -0,0 +1,195 @@ +#lang scheme + +(require htdp/image + htdp/error + "check-aux.ss") + +; +; +; ;;;;; ;;;;; +; ; ; +; ; ; +; ; ;;; ; ;;;; ;;;; ;;; ; ; ; ; ;; ;;; +; ; ; ;;; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; +; ;;;;; ; ; ; ;; ; ;; ; ;;;; ; ;; ; ; ; ;;; +; ; +; ;;;; +; + +(provide (all-from-out htdp/image)) + +(provide + ;; Scene is Image with pinhole in origin + nw:rectangle ;; Number Number Mode Color -> Image + place-image ;; Image Number Number Scene -> Scene + empty-scene ;; Number Number -> Scene + scene+line ;; Scene Number Number Number Number Color -> Scene + ;; cut all pieces that are outside the given rectangle + ) + +(define (nw:rectangle width height mode color) + (check-pos 'rectangle width "first") + (check-pos 'rectangle height "second") + (check-mode 'rectangle mode "third") + (check-color 'rectangle color "fourth") + (put-pinhole (rectangle width height mode color) 0 0)) + +(define (place-image image x y scene) + (check-image 'place-image image "first") + (check-arg 'place-image (number? x) 'integer "second" x) + (check-arg 'place-image (number? y) 'integer "third" y) + (check-scene 'place-image scene "fourth") + (let ([x (number->integer x)] + [y (number->integer y)]) + (place-image0 image x y scene))) + +(define (empty-scene width height) + (check-pos 'empty-scene width "first") + (check-pos 'empty-scene height "second") + (put-pinhole + (overlay (rectangle width height 'solid 'white) + (rectangle width height 'outline 'black)) + 0 0)) + +(define (scene+line img x0 y0 x1 y1 c) + ;; img and c are checked via calls to add-line from image.ss + (check-arg 'scene+line (scene? img) "scene" "first" "plain image") + (check-arg 'scene+line (number? x0) "number" "second" x0) + (check-arg 'scene+line (number? y0) "number" "third" y0) + (check-arg 'scene+line (number? x1) "number" "fourth" x1) + (check-arg 'scene+line (number? y1) "number" "fifth" y1) + (let ([x0 (number->integer x0)] + [x1 (number->integer x1)] + [y0 (number->integer y0)] + [y1 (number->integer y1)]) + (add-line-to-scene0 img x0 y0 x1 y1 c))) + +;; Image Number Number Image -> Image +(define (place-image0 image x y scene) + (define sw (image-width scene)) + (define sh (image-height scene)) + (define ns (overlay/xy scene x y image)) + (define nw (image-width ns)) + (define nh (image-height ns)) + (if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1)))) + +;; Image Number Number Number Number Color -> Image +(define (add-line-to-scene0 img x0 y0 x1 y1 c) + (define w (image-width img)) + (define h (image-height img)) + (cond + [(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w)) + (add-line img x0 y0 x1 y1 c)] + [(= x0 x1) ;; vertical + (if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)] + [(= y0 y1) ;; horizontal + (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)] + [else + (local ((define lin (points->line x0 y0 x1 y1)) + (define dir (direction x0 y0 x1 y1)) + (define-values (upp low lft rgt) (intersections lin w h)) + (define (add x y) (add-line img x0 y0 x y c))) + (cond + [(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior + (case dir + [(upper-left) (if (number? upp) (add upp 0) (add 0 lft))] + [(lower-left) (if (number? low) (add low h) (add 0 lft))] + [(upper-right) (if (number? upp) (add upp 0) (add h rgt))] + [(lower-right) (if (number? low) (add low h) (add w rgt))] + [else (error 'dir "contract violation: ~e" dir)])] + [(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry! + (add-line-to-scene0 img x1 y1 x0 y0 c)] + [else + (cond + [(and (number? upp) (number? low)) (add-line img upp 0 low h c)] + [(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)] + [(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)] + [(and (number? low) (number? lft)) (add-line img low h 0 lft c)] + [(and (number? low) (number? rgt)) (add-line img low h w rgt c)] + [(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)] + [else img])]))])) + +;; Nat Nat -> Nat +;; y if in [0,h], otherwise the closest boundary +(define (app y h) + (cond + [(and (<= 0 y) (< y h)) y] + [(< y 0) 0] + [else (- h 1)])) + +;; Nat Nat Nat Nat -> (union 'upper-left 'upper-right 'lower-left 'lower-right) +;; how to get to (x1,y1) from (x0,y0) +(define (direction x0 y0 x1 y1) + (string->symbol + (string-append + (if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left")))) + +#| TESTS +'direction +(equal? (direction 10 10 0 0) 'upper-left) +(equal? (direction 10 10 20 20) 'lower-right) +(equal? (direction 10 10 0 20) 'lower-left) +(equal? (direction 10 10 20 0) 'upper-right) +|# + +;; ----------------------------------------------------------------------------- +;; LINEs + +;; Number Number -> LINE +;; create a line from a slope and the intersection with the y-axis +(define-struct lyne (slope y0)) + +;; Nat Nat Nat Nat -> LINE +;; determine the line function from the four points (or the attributes) +;; ASSUME: (not (= x0 x1)) +(define (points->line x0 y0 x1 y1) + (local ((define slope (/ (- y1 y0) (- x1 x0)))) + (make-lyne slope (- y0 (* slope x0))))) + +;; LINE Number -> Number +(define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln))) + +;; LINE Nat Nat -> [Opt Number] [Opt Number] [Opt Number] [Opt Number] +;; where does the line intersect the rectangle [0,w] x [0,h] +;; (values UP LW LF RT) means the line intersects with +;; the rectangle [0,w] x [0,h] at (UP,0) or (LW,h) or (0,LF) or (w,RT) +;; when a field is false, the line doesn't interesect with that side +(define (intersections l w h) + (values + (opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h))) + +;; Number Number -> [Opt Number] +(define (opt z lft) (if (<= 0 z lft) z false)) + +;; LINE Number -> Number +;; the x0 where LINE crosses y(x) = h +;; assume: LINE is not a horizontal +(define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln))) + +;; --- TESTS --- +#| +(define line1 (points->line 0 0 100 100)) +(= (of line1 0) 0) +(= (of line1 100) 100) +(= (of line1 50) 50) + +(= (X (make-lyne 1 0) 0) 0) +(= (X (make-lyne 1 0) 100) 100) + +(equal? (call-with-values + (lambda () (intersections (points->line -10 -10 110 110) 100 100)) + list) + (list 0 100 0 100)) +(equal? (call-with-values + (lambda () (intersections (points->line 0 10 100 80) 100 100)) + list) + (list false false 10 80)) +|# + +;; ----------------------------------------------------------------------------- + +; +; diff --git a/collects/2htdp/private/last.ss b/collects/2htdp/private/last.ss new file mode 100644 index 0000000000..8faf32bcd2 --- /dev/null +++ b/collects/2htdp/private/last.ss @@ -0,0 +1,30 @@ +#lang scheme/gui + +(require "timer.ss") + +(provide last-mixin) + +(define last-mixin + (mixin (start-stop<%>) () + (field [end:ch (make-channel)]) + ;; X -> Void + (define/override (stop! w) + (send-to-last w) + (super stop! w)) + + ;; -> World + (define/public (last) + (define result (yield end:ch)) + (if (exn? result) (raise result) result)) + + (field [dr:cust (current-custodian)]) + + ;; X -> Void + ;; send x to last method + (define/private (send-to-last x) + (parameterize ((current-custodian dr:cust)) + (thread (lambda () (channel-put end:ch x))))) + + (super-new))) + + diff --git a/collects/2htdp/private/syn-aux-aux.ss b/collects/2htdp/private/syn-aux-aux.ss new file mode 100644 index 0000000000..538164f672 --- /dev/null +++ b/collects/2htdp/private/syn-aux-aux.ss @@ -0,0 +1,60 @@ +#lang scheme + +(require htdp/error) + +; +; +; +; ;;; ;;; +; ; ; ; ; +; ; ; ; +; ; ; ; ;;;; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ;; ; ; +; ;;; ;;;; ; ; ; ; ;; ; ; ; +; ; +; ; ; +; ;;; + +(provide nat> nat? proc> bool> num> ip> string> symbol>) + +;; Any -> Boolean +(define (nat? x) + (and (number? x) (integer? x) (>= x 0))) + +;; Symbol X -> X +(define (bool> tag x) + (check-arg tag (boolean? x) "boolean" "first" x) + x) + +;; Symbol X -> X +(define (string> tag x) + (check-arg tag (string? x) "string" "first" x) + x) + +(define ip> string>) + +;; Symbol X -> X +(define (symbol> tag x) + (check-arg tag (symbol? x) "symbol" "second" x) + x) + +;; Symbol X Nat -> X +(define (proc> tag f ar) + (check-proc tag f ar "first" + (if (> ar 1) + (format "~a arguments" ar) + "one argument")) + f) + +;; Symbol X (Number -> Boolean) String String -> X +(define (num> tag x pred? spec which) + (check-arg tag (and (number? x) (pred? x)) spec which x) + x) + +;; Symbol X String -> X +(define (nat> tag x spec) + (check-arg tag (nat? x) spec "natural number" x) + x) diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss new file mode 100644 index 0000000000..a44a2af08d --- /dev/null +++ b/collects/2htdp/private/syn-aux.ss @@ -0,0 +1,43 @@ +#lang scheme + +(provide define-keywords function-with-arity except err check-flat-spec + (all-from-out "syn-aux-aux.ss")) + +(require "syn-aux-aux.ss" + (for-template "syn-aux-aux.ss" + scheme + (rename-in lang/prim (first-order->higher-order f2h)))) + +(define-syntax-rule (define-keywords the-list (kw coerce) ...) + (begin + (provide kw ...) + (define-syntax (kw x) + (raise-syntax-error 'kw "used out of context" x)) + ... + (define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...)))) + +(define-syntax function-with-arity + (syntax-rules (except) + [(_ arity) + (lambda (tag) + (lambda (p) + (syntax-case p () + [(x) #`(proc> #,tag (f2h x) arity)] + [_ (err tag p)])))] + [(_ arity except extra) + (lambda (tag) + (lambda (p) + (syntax-case p () + [(x) #`(proc> #,tag (f2h x) arity)] + extra + [_ (err tag p)])))])) + +(define (err spec p) + (raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p)) + +;; Symbol (Symbol X -> X) -> (X -> X) +(define (check-flat-spec tag coerce>) + (lambda (p) + (syntax-case p () + [(b) #'(coerce> tag b)] + [_ (err tag p)]))) \ No newline at end of file diff --git a/collects/2htdp/private/timer.ss b/collects/2htdp/private/timer.ss new file mode 100644 index 0000000000..1beaa18c30 --- /dev/null +++ b/collects/2htdp/private/timer.ss @@ -0,0 +1,38 @@ +#lang scheme/gui + +;; The module provides a timer mixing for world and universe. + +;; The interface ensures that super class provides start and stop method, +;; plus a call back for clock ticks. The super-init call provides the +;; on-tick parameter, which the super-class uses to define the callback. + + +(require "check-aux.ss") + +(provide clock-mixin start-stop<%>) + +(define start-stop<%> (interface () start! ptock stop!)) + +;; T = (U (World -> World) (list (World -> World) Nat)) +;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X] +(define (selector default lchoice pchoice) + (lambda (on-tick) + (cond + [(cons? on-tick) (lchoice on-tick)] + [(procedure? on-tick) (pchoice on-tick)] + [else default]))) + +(define clock-mixin + (mixin (start-stop<%>) () + (inherit ptock) + (init-field [on-tick #f]) + (field [rate ((selector 0 second (lambda _ RATE)) on-tick)] + [timer (new timer% [notify-callback (lambda () (ptock))])]) + (define/override (start!) + (unless (<= rate 0) + (send timer start (number->integer (* 1000 rate)))) + (super start!)) + (define/override (stop! w) + (send timer stop) + (super stop! w)) + (super-new [tick ((selector void first (lambda (x) x)) on-tick)]))) diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss new file mode 100644 index 0000000000..17b5263732 --- /dev/null +++ b/collects/2htdp/private/universe.ss @@ -0,0 +1,363 @@ +#lang scheme/gui + +(require (for-syntax "syn-aux.ss") + "check-aux.ss" + "timer.ss" + "last.ss" + scheme/match + htdp/error + (only-in mzlib/etc evcase) + string-constants) + +(provide universe%) + +; +; +; +; ; ; ; +; ; ; ; +; ; ; +; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;; +; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;; ; ;;; ;;; +; +; +; + +(define universe% + (last-mixin + (clock-mixin + (class* object% (start-stop<%>) (inspect #f) (super-new) + (init-field ;; type Result = (make-bundle Universe [Listof Mail]) + universe0 ;; the initial state of the universe + on-new ;; Universe World -> Result + on-msg ;; Universe World Message -> Result + tick ;; Universe -> Result + (on-disconnect ;; Universe World -> Result + (lambda (u w) (list u))) + (to-string #f) ;; Universe -> String + ) + + (field [universe universe0]) + + ;; ----------------------------------------------------------------------- + ;; dealing with events + (define-syntax-rule + ;; A B ... -> Void + (def/cback pub (pname a ...) + ;; Universe A B ... -> (cons Universe Mail) + ;; effect: change server state, broadcast mails + name) + (begin + (pub pname) + (define (pname a ...) + (define (handler e) (stop! e)) + (with-handlers ([exn? handler]) + (define r (check-state-x-mail 'name (name universe a ...))) + (define u (bundle-state r)) + (set! universe u) + (unless (boolean? to-string) (send gui add (to-string u))) + (broadcast (bundle-mails r)))))) + + (def/cback private (pmsg world received) on-msg) + + (def/cback private (pdisconnect world) on-disconnect) + + (def/cback private (pnew world) ppnew) + + (define/private (ppnew uni p) + (world-send p 'okay) + (on-new uni p)) + + (def/cback public (ptock) tick) + + ;; Symbol Any -> Result + ;; check that r is Result + ;; effect: stop the server if the callbacks perform badly + (define/private (check-state-x-mail tag r) + (with-handlers ((exn? (lambda (x) (stop! x)))) + (define s (format "expected from ~a, given: " tag)) + (unless (bundle? r) + (error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r))) + r)) + + ;; ----------------------------------------------------------------------- + ;; start and stop server, start and stop the universe + + (field [worlds '()] ;; [Listof World] + [gui (new gui% + [stop-server (lambda () (stop! universe))] + [stop-and-restart (lambda () (restart))])] + [dr:custodian (current-custodian)] + [the-custodian (make-custodian)]) + + ;; start the universe, enable registrations and message exchanges + (define/public (start!) + (set! the-custodian (make-custodian)) + (parameterize ([current-custodian the-custodian]) + (define (loop) + (apply sync + (handle-evt (tcp-accept-evt tcp-listener) add-world) + (map world-wait-for-msg worlds))) + (define (add-world in-out) + (with-handlers ((tcp-eof? (lambda _ (loop)))) + (define in (first in-out)) + (define next (tcp-receive in)) + (match next + [(cons 'REGISTER info) + (let* ([w (create-world in (second in-out) info)]) + (set! worlds (cons w worlds)) + (pnew w) + (send gui add (format "~a signed up" info)) + (loop))] + [else (loop)]))) + (define (world-wait-for-msg p) + (handle-evt (world-in p) + (lambda (in) + (with-handlers + ((tcp-eof? + (lambda (e) + (handler p e + (lambda () + (if (null? worlds) + (restart) + (loop))))))) + (define r (tcp-receive in)) + (send gui add (format "~a ->: ~a" (world-name p) r)) + (pmsg p r) + (loop))))) + (define tcp-listener + (with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) + (tcp-listen SQPORT 4 #t))) + ;; --- go universe go --- + (set! worlds '()) + (set! universe universe0) + (send gui add "a new universe is up and running") + (thread loop))) + + ;; World Exn (-> X) -> X + (define/private (handler p e cont) + (close-output-port (world-out p)) + (close-input-port (world-in p)) + (send gui add (format "~a !! closed port" (world-name p))) + (set! worlds (remq p worlds)) + (pdisconnect p) + (cont)) + + ;; [Listof Mail] -> Void + ;; send payload of messages to designated worlds + (define/private (broadcast lm) + ;;; --- why the heck is there no exception handler ------------- + (for-each (lambda (p+m) + ;; what exception should I catch + ;; remove the world from the list + ;; factor out from elsewhere + ;; can this mean I perform a callback during a callback? + ;; collect 'bad' worlds instead and disconnect them later? + ;; (handler + (with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n")))) + (define w (mail-to p+m)) + (define n (world-name w)) + (define p (mail-content p+m)) + (unless (memq w worlds) + (send gui add (format "~s not on list" n))) + (when (memq w worlds) + (world-send w p) + (send gui add (format "-> ~a: ~a" n p))))) + lm)) + + (define/private (restart) + ;; I am running in a custodian that is about to be killed, + ;; so let's switch to one up in the hierarchy + (let ([old-t (current-thread)] + [go (make-semaphore)]) + (parameterize ([current-custodian dr:custodian]) + (thread (lambda () + (sync old-t go) + (start!)))) + (send gui add "stopping the universe") + (send gui add "----------------------------------") + (for-each (lambda (w) + (close-input-port (world-in w)) + (close-output-port (world-out w))) + worlds) + (custodian-shutdown-all the-custodian) + (semaphore-post go))) + + (define/public (stop! msg) + (send gui show #f) + (custodian-shutdown-all the-custodian)) + + ;; ----------------------------------------------------------------------- + ;; initialize the universe and run + (send gui show #t) + (start!))))) + + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; ;;; +; ; ; ; ; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;; +; ;; ;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; ;;; +; +; +; + +(provide + world? ;; Any -> Boolean + world=? ;; World World -> Boolean + world1 ;; sample worlds + world2 + world3) + +;; --- the server representation of a world --- +(define-struct world (in out name info) #:transparent) +;; World = (make-world IPort OPort Symbol [Listof Sexp]) + +(define world1 (make-world (current-input-port) (current-output-port) 'sk '())) +(define world2 (make-world (current-input-port) (current-output-port) 'mf '())) +(define world3 (make-world (current-input-port) (current-output-port) 'rf '())) + +(define (world=? u v) + (check-arg 'world=? (world? u) 'world "first" u) + (check-arg 'world=? (world? v) 'world "second" v) + (eq? u v)) + +;; IPort OPort Sexp -> Player +(define (create-world i o info) + (if (and (pair? info) (symbol? (car info))) + (make-world i o (car info) (cdr info)) + (make-world i o (gensym 'world) info))) + +;; Player S-exp -> Void +(define (world-send p sexp) + (tcp-send (world-out p) sexp)) + +; +; +; +; ;;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ;;; ;;; ; +; +; +; + +;; effect: create and show a gui with two buttons and an editor for logging +(define gui% + (class frame% + (init stop-server stop-and-restart) + (inherit show) + (define/augment (on-close) (end)) + (super-new [label "Universe"][width 500][height 300][style '(metal)]) + (field + [end (lambda _ (show #f) (stop-server))] + [panel (new horizontal-panel% [parent this] [stretchable-height #f] + [alignment '(center center)])] + [stop (new button% [parent panel] [label "stop"] [callback end])] + [s&re (new button% [parent panel] [label "stop and restart"] + [callback (lambda (but evt) (stop-and-restart))])] + [text (new text%)] + [edit (new editor-canvas% [parent this] [editor text] + [style '(no-border combo no-hscroll auto-vscroll)])]) + + ;; add lines to the end of the text + (define/public (add str) + (queue-callback + (lambda () + (send text lock #f) + (send text insert (format "~a\n" str) (send text last-position)) + (send text lock #t)))) + + ;; ------------------------------------------------------------------------- + ;; add menu, lock, and show + (copy-and-paste this) + (send text lock #t))) + +;; ----------------------------------------------------------------------------- +;; Frame Text -> Void +;; add menu bar to frame for copying all of the text +(require string-constants) + +(define (copy-and-paste frame) + (define mb (new menu-bar% [parent frame])) + (define edit (new menu% + [label (string-constant edit-menu-label)] + [parent mb])) + (new menu-item% + [label (string-constant copy-menu-item)] + [parent edit] + [shortcut #\c] + [callback (lambda (m e) + (define t (send frame get-focus-object)) + (when (is-a? t editor<%>) + (send t copy)))]) + (new menu-item% + [label (string-constant select-all-menu-item)] + [parent edit] + [shortcut #\a] + [callback (lambda (m e) + (define t (send frame get-focus-object)) + (when (is-a? t text%) + (send t set-position 0 (send t last-position))))]) + (void)) + +; +; +; ;;; ;;; ; ;; +; ;; ;; ; +; ;; ;; ;;; ;;; ; +; ; ; ; ; ; ; ; +; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ;;; ;;; ;;;;; ;;;;; ;;;;; +; +; +; +; + +(provide + ;; type Bundle = (make-bundle Universe [Listof Mail]) + ;; type Mail = (make-mail World S-expression) + make-bundle ;; Universe [Listof Mail] -> Bundle + bundle? ;; is this a bundle? + make-mail ;; World S-expression -> Mail + mail? ;; is this a real mail? + ) + +(define-struct bundle (state mails) #:transparent) + +(set! make-bundle + (let ([make-bundle make-bundle]) + (lambda (state mails) + (check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails) + (for-each (lambda (c) + (check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c)) + mails) + (make-bundle state mails)))) + +(define-struct mail (to content) #:transparent) + +(set! make-mail + (let ([make-mail make-mail]) + (lambda (to content) + (check-arg 'make-mail (world? to) 'world "first" to) + (check-arg 'make-mail (sexp? content) 'S-expression "second" content) + (make-mail to content)))) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss new file mode 100644 index 0000000000..2270aafeb1 --- /dev/null +++ b/collects/2htdp/private/world.ss @@ -0,0 +1,382 @@ +#lang scheme/gui + +(require "check-aux.ss" + "timer.ss" + "last.ss" + htdp/image + htdp/error + mzlib/runtime-path + mrlib/bitmap-label + string-constants + mrlib/gif) + +(provide world% aworld%) + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; +; ; ; ; ; ;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; +; +; +; + +;; ----------------------------------------------------------------------------- +;; packages for broadcasting information to the universe + +(define-struct package (world message) #:transparent) + +;; World Sexp -> Package +(define (create-package w m) + (check-arg 'make-package (sexp? m) 'sexp "second" m) + (make-package w m)) + +(provide + (rename-out (create-package make-package)) ;; World S-expression -> Package + package? ;; Any -> Package + ) + +(define world% + (last-mixin + (clock-mixin + (class* object% (start-stop<%>) + (inspect #f) + (init-field + world0 ;; World + (tick K)) ;; (U (World -> World) (list (World -> World) Nat)) + + (init + (on-key K) ;; World KeyEvent -> World + (on-mouse K) ;; World Nat Nat MouseEvent -> World + (on-receive #f) ;; (U #f (World S-expression -> World)) + (on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat)) + (stop-when False) ;; World -> Boolean + (record? #f) ;; Boolean + (register #f)) ;; (U #f String (list String Symbol)) + + ;; ----------------------------------------------------------------------- + (field (world world0)) + + ;; (U World Package) -> Boolean + ;; does the new world differ from the old? + ;; effect: if so, set world + (define/private (set-world new-world) + (when (package? new-world) + (broadcast (package-message new-world)) + (set! new-world (package-world new-world))) + (if (equal? world new-world) + #t + (begin + (set! world new-world) + #f))) + + ;; ----------------------------------------------------------------------- + (field [*out* #f] ;; (U #f OutputPort), where to send messages to + [*rec* (make-custodian)] ;; Custodian, monitor traffic + [host (cond + [(string? register) register] + [(pair? register) (car register)] + [else register])] + [name (cond + [(string? register) (gensym 'world)] + [(pair? register) (second register)] + [else register])]) + + (define/private (register-with-host) + (define FMTtry "unable to register with ~a after ~s tries") + (define FMTcom "unable to register with ~a due to protocol problems") + ;; try to register with the server n times + (define (register n) + (printf "trying to register with ~a ...\n" host) + (with-handlers ((tcp-eof? + (lambda (x) + (error 'register FMTcom host))) + (exn:fail:network? + (lambda (x) + (if (= n 1) + (error 'register FMTtry host TRIES) + (begin (sleep PAUSE) + (register (- n 1))))))) + (define-values (in out) (tcp-connect host SQPORT)) + (tcp-send out `(REGISTER ,(if name name (gensym 'world)))) + (if (eq? (tcp-receive in) 'okay) + (values in out) + (raise tcp-eof)))) + ;; --- now register, obtain connection, and spawn a thread for receiving + (parameterize ([current-custodian *rec*]) + (define-values (in out) (register TRIES)) + (define dis (text "the universe disappeared" 11 'red)) + (define (RECEIVE) + (sync + (handle-evt + in + (lambda (in) + (with-handlers ((tcp-eof? (compose (handler #f) + (lambda (e) + (set! draw (lambda (w) dis)) + (pdraw) + e)))) + ;; --- "the universe disconnected" should come from here --- + (define msg (tcp-receive in)) + (cond + [(sexp? msg) (prec msg) (RECEIVE)] ;; break loop if EOF + [#t (error 'RECEIVE "sexp expected, received: ~e" msg)])))))) + (printf "... successful registered and ready to receive\n") + (set! *out* out) + (thread RECEIVE))) + + (define/private (broadcast msg) + (when *out* + (check-result 'send sexp? "Sexp expected; given ~e\n" msg) + (tcp-send *out* msg))) + + ;; ----------------------------------------------------------------------- + (field + (draw (cond + [(procedure? on-draw) on-draw] + [(pair? on-draw) (first on-draw)] + [else on-draw])) + (live (not (boolean? draw))) + (width (if (pair? on-draw) (second on-draw) #f)) + (height (if (pair? on-draw) (third on-draw) #f))) + + ;; the visible world + (field [enable-images-button void] ;; used if stop-when call produces #t + [disable-images-button void] + [visible (new pasteboard%)]) + + (define (show-canvas) + (send visible set-cursor (make-object cursor% 'arrow)) + (let ([fst-scene (ppdraw)]) + (set! width (if width width (image-width fst-scene))) + (set! height (if height height (image-height fst-scene))) + (create-frame) + (show fst-scene))) + + ;; effect: create, show and set the-frame + (define/pubment (create-frame) + (define play-back:cust (make-custodian)) + (define frame (new (class frame% + (super-new) + (define/augment (on-close) + (callback-stop! 'frame-stop) + (custodian-shutdown-all play-back:cust))) + (label (if name (format "~a's World" name) "World")) + (stretchable-width #f) + (stretchable-height #f) + (style '(no-resize-border metal)))) + (define editor-canvas + (new (class editor-canvas% + (super-new) + ;; deal with keyboard events + (define/override (on-char e) + (when live (pkey (send e get-key-code)))) + ;; deal with mouse events if live and within range + (define/override (on-event e) + (define l (mouse-event->parts e)) + (when live + (when (and (<= 0 (first l) width) (<= 0 (second l) height)) + (pmouse . l))))) + (parent frame) + (editor visible) + (style '(no-hscroll no-vscroll)) + (horizontal-inset INSET) + (vertical-inset INSET))) + (send editor-canvas min-client-width (+ width INSET INSET)) + (send editor-canvas min-client-height (+ height INSET INSET)) + (set!-values (enable-images-button disable-images-button) + (inner (values void void) create-frame frame play-back:cust)) + (send editor-canvas focus) + (send frame show #t)) + + ;; Image -> Void + ;; show the image in the visible world + (define/public (show pict) + (send visible begin-edit-sequence) + (send visible lock #f) + (let ([s (send visible find-first-snip)] + [c (send visible get-canvas)]) + (when s (send visible delete s)) + (send visible insert (send pict copy) 0 0)) + (send visible lock #t) + (send visible end-edit-sequence)) + + ;; ----------------------------------------------------------------------- + ;; callbacks + (field + (key on-key) + (mouse on-mouse) + (rec on-receive)) + + (define-syntax-rule (def/pub-cback (name arg ...) transform) + ;; Any ... -> Boolean + (define/public (name arg ...) + (queue-callback + (lambda () + (with-handlers ([exn:break? (handler #f)][exn? (handler #t)]) + (define changed-world? (set-world (transform world arg ...))) + (unless changed-world? + (when draw (pdraw)) + (when (pstop) + (callback-stop! 'name) + (enable-images-button))) + changed-world?))))) + + ;; tick, tock : deal with a tick event for this world + (def/pub-cback (ptock) tick) + + ;; key events + (def/pub-cback (pkey ke) key) + + ;; mouse events + (def/pub-cback (pmouse x y me) mouse) + + ;; receive revents + (def/pub-cback (prec msg) rec) + + ;; ----------------------------------------------------------------------- + ;; draw : render this world + (define/private (pdraw) (show (ppdraw))) + + (define/private (ppdraw) + (check-scene-result (name-of draw 'your-draw) (draw world))) + + ;; ----------------------------------------------------------------------- + ;; stop-when + (field [stop stop-when]) + + (define/private (pstop) + (define result (stop world)) + (check-result (name-of stop 'your-stop-when) boolean? "boolean" result) + result) + + ;; ----------------------------------------------------------------------- + ;; start & stop + (define/public (callback-stop! msg) + (stop! world)) + + (define (handler re-raise) + (lambda (e) + (disable-images-button) + (stop! (if re-raise e world)))) + + (define/public (start!) + (when draw (show-canvas)) + (when host (register-with-host))) + + (define/public (stop! w) + (set! live #f) + (custodian-shutdown-all *rec*)) + + ;; ------------------------------------------------------------------------- + ;; initialize the world and run + (super-new) + (start!))))) + +;; ----------------------------------------------------------------------------- +(define-runtime-path break-btn:path '(lib "icons/break.png")) +(define break-button:label + ((bitmap-label-maker (string-constant break-button-label) break-btn:path) '_)) + +(define-runtime-path image-button:path '(lib "icons/file.gif")) +(define image-button:label ((bitmap-label-maker "Images" image-button:path) '_)) + +(define aworld% + (class world% (super-new) + (inherit-field world0 tick key mouse rec draw rate width height) + (inherit show callback-stop!) + + ;; Frame Custodian -> (-> Void) + ;; adds the stop animation and image creation button, + ;; whose callbacks runs as a thread in the custodian + ;; provide a function for switching button enabling + (define/augment (create-frame frm play-back-custodian) + (define p (new horizontal-pane% [parent frm][alignment '(center center)])) + (define (switch) + (send stop-button enable #f) + (send image-button enable #t)) + (define (stop) (send stop-button enable #f)) + (define-syntax-rule (btn l a y ...) + (new button% [parent p] [label l] [style '(border)] + [callback (lambda a y ...)])) + (define stop-button + (btn break-button:label (b e) (callback-stop! 'stop-images) (switch))) + (define image-button + (btn image-button:label (b e) + (parameterize ([current-custodian play-back-custodian]) + (thread (lambda () (play-back))) + (stop)))) + (send image-button enable #f) + (values switch stop)) + + (field [event-history '()]) ;; [Listof Evt] + ;; Symbol Any *-> Void + (define/private (add-event type . stuff) + (set! event-history (cons (cons type stuff) event-history))) + + ;; --- new callbacks --- + (define-syntax-rule (def/over-cb (pname name arg ...)) + (define/override (pname arg ...) + (when (super pname arg ...) (add-event name arg ...)))) + + (def/over-cb (ptock tick)) + (def/over-cb (pkey key e)) + (def/over-cb (pmouse mouse x y me)) + (def/over-cb (prec rec m)) + + ;; --> Void + ;; re-play the history of events; create a png per step; create animated gif + ;; effect: write to user-chosen directory + (define/private (play-back) + ;; World EventRecord -> World + (define (world-transition world fst) (apply (car fst) world (cdr fst))) + ;; --- creating images + (define total (+ (length event-history) 1)) + (define digt# (string-length (number->string total))) + (define imag# 0) + (define bmps '()) + ;; Image -> Void + (define (save-image img) + (define bm (make-object bitmap% width height)) + (define dc (make-object bitmap-dc% bm)) + (send dc clear) + (send img draw dc 0 0 0 0 width height 0 0 #f) + (set! imag# (+ imag# 1)) + (send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png) + (set! bmps (cons bm bmps))) + ;; --- choose place + (define img:dir (get-directory "image directory:" #f (current-directory))) + (when img:dir + (parameterize ([current-directory img:dir]) + (define last + (foldr (lambda (event world) + (save-image (draw world)) + (show (text (format "~a/~a created" imag# total) 18 'red)) + (world-transition world event)) + world0 + event-history)) + (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red)) + (create-animated-gif rate (reverse bmps)) + (show (draw last))))))) + +;; Number [Listof (-> bitmap)] -> Void +;; turn the list of thunks into animated gifs +;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) +;; [Listof (-> bitmap)] -> Void +;; turn the list of thunks into animated gifs +;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) +(define (create-animated-gif R bitmap-list) + (when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE)) + (write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5) + ANIMATED-GIF-FILE + #:one-at-a-time? #t + #:loop? #f)) + +(define ANIMATED-GIF-FILE "i-animated.gif") diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss new file mode 100755 index 0000000000..33801da892 --- /dev/null +++ b/collects/2htdp/universe.ss @@ -0,0 +1,311 @@ +#lang scheme/gui + +#| TODO: + -- make window resizable :: why? +|# + +(require (for-syntax "private/syn-aux.ss") + "private/syn-aux-aux.ss" + "private/syn-aux.ss" + "private/check-aux.ss" + "private/image.ss" + "private/world.ss" + "private/universe.ss" + htdp/error + (rename-in lang/prim (first-order->higher-order f2h)) + (only-in mzlib/etc evcase)) + +(provide (all-from-out "private/image.ss")) + +(provide + sexp? ;; Any -> Boolean + scene? ;; Any -> Boolean + ) + +;; Spec = (on-tick Expr) +;; | (on-tick Expr Expr) +;; -- on-tick must specify a tick handler; it may specify a clock-tick rate + +(define-keywords AllSpec + [on-tick (function-with-arity + 1 + except + [(x rate) + #'(list (proc> 'on-tick (f2h x) 1) + (num> 'on-tick rate positive? "pos. number" "rate"))])]) + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; +; ; ; ; ; ;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; +; +; +; + +(provide big-bang ;; : see below + make-package ;; World Sexp -> Package + package? ;; Any -> Boolean + run-movie ;; [Listof Image] -> true + + ;; A MouseEventType is one of: + ;; - 'button-down + ;; - 'button-up + ;; - 'drag + ;; - 'move + ;; - 'enter + ;; - 'leave + + mouse-event? ;; Any -> Boolean + mouse=? ;; MouseEventType MouseEventType -> Boolean + + ;; KeyEvent is one of: + ;; -- Char + ;; -- Symbol + + key-event? ;; Any -> Boolean + key=? ;; KeyEvent KeyEvent -> Boolean + + ;; IP : a string that points to a machine on the net + LOCALHOST ;; IP + ) + +(provide-higher-order-primitive + run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true) + ) + +;; Expr = (big-bang Expr WorldSpec ...) +;; WorldSpec = AllSpec +;; | (on-draw Expr) +;; | (on-draw Expr Expr Expr) +;; -- on-draw must specify a rendering function; it may specify canvas dimensions +;; | (on-key Expr) +;; -- on-key must specify a key event handler +;; | (on-mouse Expr) +;; -- on-mouse must specify a mouse event handler +;; | (stop-when Expr) +;; -- stop-when must specify a boolean-valued function +;; | (register Expr) +;; | (register Expr Expr) +;; -- register must specify the internet address of a host (including LOCALHOST) +;; -- it may specify a world's name +;; | (record? Expr) +;; -- should the session be recorded and turned into PNGs and an animated GIF +;; | (on-receive Expr) +;; -- on-receive must specify a receive handler + +(define-keywords WldSpec + [on-draw (function-with-arity + 1 + except + [(f width height) + #'(list (proc> 'on-draw (f2h f) 1) + (nat> 'on-draw width "width") + (nat> 'on-draw height "height"))])] + [on-mouse (function-with-arity 4)] + [on-key (function-with-arity 2)] + [on-receive (function-with-arity 2)] + [stop-when (function-with-arity 1)] + [register (lambda (tag) + (lambda (p) + (syntax-case p () + [(host) #`(ip> #,tag host)] + [(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))] + [_ (err tag p)])))] + [record? (lambda (tag) + (lambda (p) + (syntax-case p () + [(b) #`(bool> #,tag b)] + [_ (err tag p)])))]) + +(define-syntax (big-bang stx) + (syntax-case stx () + [(big-bang) (raise-syntax-error #f "bad world description" stx)] + [(big-bang w s ...) + (let* ([Spec (append AllSpec WldSpec)] + [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))] + [rec? #'#f] + [spec (map (lambda (stx) + (syntax-case stx () + [(kw . E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (begin + (when (free-identifier=? #'kw #'record?) + (syntax-case #'E () + [(V) (set! rec? #'V)] + [_ (err 'record? stx)])) + (cons (syntax-e #'kw) (syntax E)))] + [_ (raise-syntax-error + 'big-bang "not a legal big-bang clause" stx)])) + (syntax->list (syntax (s ...))))] + ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co (assq kw Spec)) + (list kw ((cadr co) (cdr x)))) + spec)]) + #`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))])) + + +; +; +; +; ; ; ; ; ;;; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; ; ; ; ; ; ; +; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ;;; ; ;; ;;;; ; ; ;; ; ; ; +; +; +; + +(define (run-simulation f) + (check-proc 'run-simulation f 1 "first" "one argument") + (big-bang 1 (on-tick add1) (on-draw f))) + +(define (run-movie r m*) + (check-arg 'run-movie (positive? r) "positive number" "first" r) + (check-arg 'run-movie (list? m*) "list (of images)" "second" m*) + (for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*) + (let* ([fst (car m*)] + [wdt (image-width fst)] + [hgt (image-height fst)]) + (big-bang + m* + (on-tick rest r) + (on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m)))) + (stop-when empty?)))) + +(define (mouse-event? a) + (pair? (member a '(button-down button-up drag move enter leave)))) + +(define (mouse=? k m) + (check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k) + (check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m) + (eq? k m)) + +(define (key-event? k) + (or (char? k) (symbol? k))) + +(define (key=? k m) + (check-arg 'key=? (key-event? k) 'KeyEvent "first" k) + (check-arg 'key=? (key-event? m) 'KeyEvent "second" m) + (eqv? k m)) + +(define LOCALHOST "127.0.0.1") + +;; ----------------------------------------------------------------------------- + +; +; +; +; ; ; ; +; ; ; ; +; ; ; +; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;; +; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;; ; ;;; ;;; +; +; +; + +(provide + ;; type World + world? ;; Any -> Boolean + world=? ;; World World -> Boolean + world1 ;; sample worlds + world2 + world3 + ;; type Bundle = (make-bundle Universe [Listof Mail]) + ;; type Mail = (make-mail World S-expression) + make-bundle ;; Universe [Listof Mail] -> Bundle + bundle? ;; is this a bundle? + make-mail ;; World S-expression -> Mail + mail? ;; is this a real mail? + universe ;; : see below + universe2 ;; (World World -> U) (U World Message) -> U + ) + +;; Expr = (universe Expr UniSpec) +;; UniSpec = AllSepc +;; | (on-new Expr) +;; -- on-new must specify a 'new world" handler; what happens when a world joins +;; | (on-msg Expr) +;; -- on-msg must specify a 'message' handler +;; | (on-disconnect Expr) +;; -- on-disconnect may specify a handler for the event that a world is leaving +;; | (to-string Expr) +;; -- to-string specifies how to render the universe as a string for display +;; in the console + +(define-keywords UniSpec + [on-new (function-with-arity 2)] + [on-msg (function-with-arity 3)] + [on-disconnect (function-with-arity 2)] + [to-string (function-with-arity 1)]) + +(define-syntax (universe stx) + (syntax-case stx () + [(universe) (raise-syntax-error #f "not a legal universe description" stx)] + [(universe u) (raise-syntax-error #f "not a legal universe description" stx)] + [(universe u bind ...) + (let* ([Spec (append AllSpec UniSpec)] + [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))] + [spec (map (lambda (stx) + (syntax-case stx () + [(kw . E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (cons (syntax-e #'kw) (syntax E))] + [(kw E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (list (syntax-e #'kw) (syntax E))] + [_ (raise-syntax-error + 'universe "not a legal universe clause" stx)])) + (syntax->list (syntax (bind ...))))] + ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co (assq kw Spec)) + (list kw ((cadr co) (cdr x)))) + spec)] + [domain (map car args)]) + (cond + [(not (memq 'on-new domain)) + (raise-syntax-error #f "missing on-new clause" stx)] + [(not (memq 'on-msg domain)) + (raise-syntax-error #f "missing on-msg clause" stx)] + [else ; (and (memq #'on-new domain) (memq #'on-msg domain)) + #`(send (new universe% [universe0 u] #,@args) last)]))])) + +;; (World World -> U) (U World Msg) -> U +(define (universe2 create process) + ;; UniState = '() | (list World) | Universe + ;; UniState World -> (cons UniState [Listof (list World S-expression)]) + (define (nu s p) + (cond + [(null? s) (make-bundle (list p) '())] + [(not (pair? s)) (make-bundle s '())] + [(null? (rest s)) (create (first s) p)] + [else (error 'create "a third world is signing up!")])) + (universe '() + (on-new nu) + (on-msg process) + #; + (on-tick (lambda (u) (printf "hello!\n") (list u)) 1))) \ No newline at end of file diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index c78d310a40..cef5601613 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -23,7 +23,7 @@ (close-output-port out) in)))]) (let ([n (match v - [(struct compilation-top (_ prefix (struct primitive (n)))) n] + [(struct compilation-top (_ prefix (struct primval (n)))) n] [else #f])]) (hash-set! table n (car b))))) table)) @@ -77,7 +77,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,stx #;(stx-encoded stx)) + `(#%decode-syntax ,(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -126,7 +126,7 @@ `(let () ,@defns ,(decompile-expr rhs globs '(#%globals) closed))))] - [(struct sequence (forms)) + [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed)) forms))] @@ -179,7 +179,7 @@ `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) (list-ref/protect globs (+ midpt pos) 'topsyntax)] - [(struct primitive (id)) + [(struct primval (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) @@ -249,7 +249,7 @@ [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] - [(struct sequence (exprs)) + [(struct seq (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 00c1a5dbb2..6e4abbc12c 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -7,11 +7,18 @@ ;; ---------------------------------------- ;; Structures to represent bytecode -(define-syntax-rule (define-form-struct id (field-id ...)) +(define-syntax-rule (define-form-struct* id id+par (field-id ...)) (begin - (define-struct id (field-id ...) #:transparent) + (define-struct id+par (field-id ...) #:transparent) (provide (struct-out id)))) +(define-syntax define-form-struct + (syntax-rules () + [(_ (id sup) . rest) + (define-form-struct* id (id sup) . rest)] + [(_ id . rest) + (define-form-struct* id id . rest)])) + (define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this (define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array @@ -21,43 +28,46 @@ (define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id ;; In stxs of prefix: -(define-form-struct stx (encoded)) ; todo: decode syntax objects +(define-form-struct stx (encoded)) -(define-form-struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) +(define-form-struct form ()) +(define-form-struct (expr form) ()) -(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' -(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over) -(define-form-struct case-lam (name clauses)) ; each clause is an lam +(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth)) -(define-form-struct let-one (rhs body)) ; pushes one value onto stack -(define-form-struct let-void (count boxes? body)) ; create new stack slots -(define-form-struct install-value (count pos boxes? rhs body)) ; set existing stack slot(s) -(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots -(define-form-struct boxenv (pos body)) ; box existing stack element +(define-form-struct (lam expr) (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' +(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) +(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam -(define-form-struct localref (unbox? offset clear?)) ; access local via stack +(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack +(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots +(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s) +(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) (pos body)) ; box existing stack element -(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack) -(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) +(define-form-struct (localref expr) (unbox? pos clear?)) ; access local via stack -(define-form-struct application (rator rands)) ; function call -(define-form-struct branch (test then else)) ; `if' -(define-form-struct with-cont-mark (key val body)) ; `with-continuation-mark' -(define-form-struct beg0 (seq)) ; `begin0' -(define-form-struct sequence (forms)) ; `begin' -(define-form-struct splice (forms)) ; top-level `begin' -(define-form-struct varref (toplevel)) ; `#%variable-reference' -(define-form-struct assign (id rhs undef-ok?)) ; top-level or module-level set! -(define-form-struct apply-values (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc) -(define-form-struct primitive (id)) ; direct preference to a kernel primitive +(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack) +(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack) + +(define-form-struct (application expr) (rator rands)) ; function call +(define-form-struct (branch expr) (test then else)) ; `if' +(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark' +(define-form-struct (beg0 expr) (seq)) ; `begin0' +(define-form-struct (seq form) (forms)) ; `begin' +(define-form-struct (splice form) (forms)) ; top-level `begin' +(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference' +(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set! +(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive ;; Definitions (top level or within module): -(define-form-struct def-values (ids rhs)) -(define-form-struct def-syntaxes (ids rhs prefix max-let-depth)) -(define-form-struct def-for-syntax (ids rhs prefix max-let-depth)) +(define-form-struct (def-values form) (ids rhs)) +(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth)) +(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth)) ;; Top-level `require' -(define-form-struct req (reqs dummy)) +(define-form-struct (req form) (reqs dummy)) ;; A static closure can refer directly to itself, creating a cycle (define-struct indirect ([v #:mutable]) #:prefab) @@ -145,7 +155,7 @@ (make-with-cont-mark key val body)])) (define (read-sequence v) - (make-sequence v)) + (make-seq v)) (define (read-define-values v) (make-def-values @@ -173,7 +183,7 @@ (define (read-begin0 v) (match v - [(struct sequence (exprs)) + [(struct seq (exprs)) (make-beg0 exprs)])) (define (read-boxenv v) @@ -429,9 +439,12 @@ ;; Synatx unmarshaling (define-form-struct wrapped (datum wraps certs)) -(define-form-struct lexical-rename (alist)) -(define-form-struct phase-shift (amt src dest)) -(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) + +(define-form-struct wrap ()) +(define-form-struct (lexical-rename wrap) (alist)) +(define-form-struct (phase-shift wrap) (amt src dest)) +(define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?)) + (define-form-struct all-from-module (path phase src-phase exceptions prefix)) (define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id)) @@ -696,7 +709,7 @@ [read-accept-quasiquote #t]) (read (open-input-bytes s))))] [(reference) - (make-primitive (read-compact-number cp))] + (make-primval (read-compact-number cp))] [(small-list small-proper-list) (let* ([l (- ch cpt-start)] [ppr (eq? cpt-tag 'small-proper-list)]) diff --git a/collects/drscheme/private/bitmap-message.ss b/collects/drscheme/private/bitmap-message.ss index e3683e7472..80c440b0f7 100644 --- a/collects/drscheme/private/bitmap-message.ss +++ b/collects/drscheme/private/bitmap-message.ss @@ -5,7 +5,7 @@ (define bitmap-message% (class canvas% - (inherit min-width min-height get-dc) + (inherit min-width min-height get-dc refresh) (define bm #f) (define/override (on-paint) (when bm @@ -14,6 +14,7 @@ (define/public (set-bm b) (set! bm b) (min-width (send bm get-width)) - (min-height (send bm get-height))) + (min-height (send bm get-height)) + (refresh)) (super-new (stretchable-width #f) (stretchable-height #f)))) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 8f22224638..6e50ad42cb 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -3103,8 +3103,9 @@ module browser threading seems wrong. [demand-callback (λ (mi) (let ([target (get-edit-target-object)]) - (send mi enable (get-edit-target-object)) - (send mi check (and target (send target get-overwrite-mode)))))] + (send mi enable (is-a? target text%)) + (when (is-a? target text%) + (send mi check (and target (send target get-overwrite-mode))))))] [callback (λ (x y) (let ([target (get-edit-target-object)]) (send target set-overwrite-mode diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 0990485cdc..ebce5d6120 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1942,6 +1942,13 @@ (send text-to-search set-position anchor-pos)))))) (send tlw hide-search))))) +(send search/replace-keymap map-function "f3" "unhide-search-and-toggle-focus") +(send search/replace-keymap add-function "unhide-search-and-toggle-focus" + (λ (text evt) + (let ([tlw (send text get-top-level-window)]) + (when tlw + (send tlw unhide-search-and-toggle-focus))))) + (define searchable-canvas% (class editor-canvas% (inherit refresh get-dc get-client-size) @@ -1981,19 +1988,7 @@ (define/public (get-case-sensitive-search?) case-sensitive-search?) (define replace-visible? (preferences:get 'framework:replace-visible?)) - (define/override (edit-menu:find-callback menu evt) - (cond - [hidden? - (unhide-search #t)] - [(or (not text-to-search) - (send (send text-to-search get-canvas) has-focus?)) - (send find-edit set-position 0 (send find-edit last-position)) - (send find-canvas focus)] - [else - (let ([canvas (send text-to-search get-canvas)]) - (when canvas - (send canvas focus)))]) - #t) + (define/override (edit-menu:find-callback menu evt) (unhide-search-and-toggle-focus) #t) (define/override (edit-menu:create-find?) #t) (define/override (edit-menu:find-next-callback menu evt) (search 'forward) #t) @@ -2100,6 +2095,19 @@ (send find-edit set-position 0 (send find-edit last-position)) (send (send find-edit get-canvas) focus)))) + (define/public (unhide-search-and-toggle-focus) + (cond + [hidden? + (unhide-search #t)] + [(or (not text-to-search) + (send (send text-to-search get-canvas) has-focus?)) + (send find-edit set-position 0 (send find-edit last-position)) + (send find-canvas focus)] + [else + (let ([canvas (send text-to-search get-canvas)]) + (when canvas + (send canvas focus)))])) + (define/public (search searching-direction) (unhide-search #f) (send find-edit search searching-direction #t)) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 8fe8fec90a..c130a59f38 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -1311,12 +1311,13 @@ (send-frame (λ (f) (send f replace&search 'forward)))) (add "replace & search backward" (send-frame (λ (f) (send f replace&search 'backward)))) - + (add "unhide search and toggle focus" + (send-frame (λ (f) (send f unhide-search-and-toggle-focus)))) (add "hide-search" (send-frame (λ (f) (send f hide-search)))) (map "c:g" "hide-search") - (map "f3" "search forward") + (map "f3" "unhide search and toggle focus") (map "c:s" "search forward") (map "c:r" "search backward") (case (system-type) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index 2ecff2f226..4b0ddf7c71 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -1,3 +1,5 @@ +;#lang scheme (require htdp/world lang/posn) (define-syntax (check-expect stx) #'(void)) + (require "hash.ss") ;; constants @@ -5,15 +7,15 @@ (define circle-spacing 22) (define normal-color 'lightskyblue) -(define on-shortest-path-color normal-color) -;(define on-shortest-path-color 'cornflowerblue) +(define on-shortest-path-color 'white) (define blocked-color 'black) +(define under-mouse-color 'black) ;; data definitions ;; a world is: -;; (make-world board posn state number) -(define-struct world (board cat state size)) +;; (make-world board posn state number mouse posn-or-false boolean) +(define-struct world (board cat state size mouse-posn h-down?)) ;; a state is either: ;; - 'playing @@ -30,255 +32,6 @@ (define-struct cell (p blocked?)) -; -; -; -; -; -; ;; ;;;; -; ;;;; ;;;;; -; ;;; ; -; ;;; ;;; ; ;;;; ;;;; ;;;;;; ;; ;;;; ;;;;;; ;; ;;;; ;;; -; ;;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;; ;; ; ;;;;; ;;; ;;;; ;;;;;;; -; ;;;;;;;;; ;;; ;;;;;;;;;;;;;;; ;;; ;; ;; ;;; ;;; ;;;; ; ;;;; -; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;; ;;; -; ;; ;;;; ;;; ;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;;;;;;; ;;; ;;;;;;;;;; ;;; ;; ;;;;; ;;;; ;;; ;;; ;;; -; ;;;;;;;;;;;;;;;; ;;;;;;;;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; ;;;; ;;; -; ;;;;; ;;;; ;;;; ;;;;; ;;; -; ;;;;;;; ;;; -; ;;;;;; -; - - -;; world->image : world -> image -(define (world->image w) - (chop-whiskers - (overlay (board->image (world-board w) - (world-size w) - (on-cats-path? w)) - (move-pinhole - (cond - [(equal? (world-state w) 'cat-won) happy-cat] - [(equal? (world-state w) 'cat-lost) sad-cat] - [else thinking-cat]) - (- (cell-center-x (world-cat w))) - (- (cell-center-y (world-cat w))))))) - -(check-expect - (world->image - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'playing - 2)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true)) - (move-pinhole thinking-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(check-expect - (world->image - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-won - 2)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true)) - (move-pinhole happy-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(check-expect - (world->image - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-lost - 2)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true)) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -;; chop-whiskers : image -> image -;; crops the image so that anything above or to the left of the pinhole is gone -(define (chop-whiskers img) - (shrink img - 0 - 0 - (- (image-width img) (pinhole-x img) 1) - (- (image-height img) (pinhole-y img) 1))) - -(check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) -(check-expect (chop-whiskers (rectangle 6 6 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) - -(check-expect - (pinhole-x - (world->image - (make-world - (empty-board 3) - (make-posn 0 0) - 'playing - 3))) - 0) -(check-expect - (pinhole-x - (world->image - (make-world - (empty-board 3) - (make-posn 0 1) - 'playing - 3))) - 0) - - -;; board->image : board number (posn -> boolean) -> image -(define (board->image cs world-size on-cat-path?) - (foldl (lambda (x y) (overlay y x)) - (nw:rectangle (world-width world-size) - (world-height world-size) - 'solid - 'white) - (map (lambda (c) (cell->image c (on-cat-path? (cell-p c)))) - cs))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) true)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - true))) - - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1)))) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false) - (cell->image (make-cell (make-posn 0 1) false) - true))) - - -;; cell->image : cell boolean -> image -(define (cell->image c on-short-path?) - (local [(define x (cell-center-x (cell-p c))) - (define y (cell-center-y (cell-p c)))] - (move-pinhole - (cond - [on-short-path? - (circle circle-radius 'solid on-shortest-path-color)] - [(cell-blocked? c) - (circle circle-radius 'solid blocked-color)] - [else - (circle circle-radius 'solid normal-color)]) - (- x) - (- y)))) - -(check-expect (cell->image (make-cell (make-posn 0 0) false) false) - (move-pinhole (circle circle-radius 'solid normal-color) - (- circle-radius) - (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) true) false) - (move-pinhole (circle circle-radius 'solid 'black) - (- circle-radius) - (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) false) true) - (move-pinhole (circle circle-radius 'solid on-shortest-path-color) - (- circle-radius) - (- circle-radius))) - -;; world-width : number -> number -;; computes the width of the drawn world in terms of its size -(define (world-width board-size) - (local [(define rightmost-posn - (make-posn (- board-size 1) (- board-size 2)))] - (+ (cell-center-x rightmost-posn) circle-radius))) - -(check-expect (world-width 3) 150) - -;; world-height : number -> number -;; computes the height of the drawn world in terms of its size -(define (world-height board-size) - (local [(define bottommost-posn - (make-posn (- board-size 1) (- board-size 1)))] - (+ (cell-center-y bottommost-posn) circle-radius))) -(check-expect (world-height 3) 116.208) - - -;; cell-center-x : posn -> number -(define (cell-center-x p) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (+ circle-radius - (* x circle-spacing 2) - (if (odd? y) - circle-spacing - 0)))) - -(check-expect (cell-center-x (make-posn 0 0)) - circle-radius) -(check-expect (cell-center-x (make-posn 0 1)) - (+ circle-spacing circle-radius)) -(check-expect (cell-center-x (make-posn 1 0)) - (+ (* 2 circle-spacing) circle-radius)) -(check-expect (cell-center-x (make-posn 1 1)) - (+ (* 3 circle-spacing) circle-radius)) - -;; cell-center-y : posn -> number -(define (cell-center-y p) - (local [(define y (posn-y p))] - (+ circle-radius - (* y circle-spacing 2 - .866 ;; .866 is an exact approximate to sin(pi/3) - )))) - -(check-expect (cell-center-y (make-posn 1 1)) - (+ circle-radius (* 2 circle-spacing .866))) -(check-expect (cell-center-y (make-posn 1 0)) - circle-radius) - - ; ; ; @@ -350,7 +103,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3) + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) 'boundary) (list (make-dist-cell 'boundary 0) @@ -367,7 +120,7 @@ true) (check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3) + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) (make-posn 1 1)) (list (make-dist-cell 'boundary 2) @@ -394,7 +147,9 @@ (make-cell (make-posn 2 2) true)) (make-posn 1 1) 'playing - 3) + 3 + (make-posn 0 0) + false) 'boundary) (list (make-dist-cell 'boundary 0))) @@ -404,7 +159,9 @@ (build-bfs-table (make-world (empty-board 5) (make-posn 2 2) 'playing - 5) + 5 + (make-posn 0 0) + false) 'boundary) (list (make-dist-cell 'boundary 0) @@ -445,7 +202,9 @@ (empty-board 5)) (make-posn 2 2) 'playing - 5) + 5 + (make-posn 0 0) + false) 'boundary) (list (make-dist-cell 'boundary 0) @@ -483,7 +242,9 @@ (build-bfs-table (make-world (empty-board 5) (make-posn 2 2) 'playing - 5) + 5 + (make-posn 0 0) + false) (make-posn 2 2)) (list (make-dist-cell 'boundary 3) @@ -522,7 +283,9 @@ (build-bfs-table (make-world (empty-board 5) (make-posn 2 2) 'playing - 5) + 5 + (make-posn 0 0) + false) (make-posn 2 2)) (make-posn 1 4)) 2) @@ -549,32 +312,62 @@ '∞) -;; on-cats-path? : world -> posn -> boolean +;; p : world -> posn -> boolean ;; returns true when the posn is on the shortest path ;; from the cat to the edge of the board, in the given world (define (on-cats-path? w) - (local [(define edge-distance-map (build-bfs-table w 'boundary)) - (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance (lookup-in-table edge-distance-map - (world-cat w)))] - (lambda (p) - (equal? (+/f (lookup-in-table cat-distance-map p) - (lookup-in-table edge-distance-map p)) - cat-distance)))) + (cond + [(world-h-down? w) + (local [(define edge-distance-map (build-bfs-table w 'boundary)) + (define cat-distance-map (build-bfs-table w (world-cat w))) + (define cat-distance (lookup-in-table edge-distance-map + (world-cat w)))] + (cond + [(equal? cat-distance '∞) + (lambda (p) false)] + [else + (lambda (p) + (equal? (+/f (lookup-in-table cat-distance-map p) + (lookup-in-table edge-distance-map p)) + cat-distance))]))] + [else + (lambda (p) false)])) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5)) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) (make-posn 1 0)) true) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5)) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) false)) + (make-posn 1 0)) + false) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) (make-posn 2 1)) false) +(check-expect ((on-cats-path? + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + true)) + (make-posn 0 1)) + false) -;; neighbors : world (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) +;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) ;; computes the neighbors of a posn, for a given board size (define (neighbors w) - (local [(define blocked (map cell-p - (filter cell-blocked? - (world-board w)))) + (local [(define blocked + (map cell-p + (filter (lambda (c) + (or (cell-blocked? c) + (equal? (cell-p c) (world-mouse-posn w)))) + (world-board w)))) (define boundary-cells (filter (lambda (p) (and (not (member p blocked)) (on-boundary? p (world-size w)))) @@ -626,7 +419,9 @@ (make-cell (make-posn 2 2) false)) (make-posn 1 1) 'playing - 3)) + 3 + (make-posn 0 0) + false)) (make-posn 1 1)) '()) (check-expect ((neighbors (make-world (list @@ -639,7 +434,9 @@ (make-cell (make-posn 2 2) false)) (make-posn 1 1) 'playing - 3)) + 3 + (make-posn 0 0) + false)) (make-posn 1 0)) (list 'boundary (make-posn 2 0) (make-posn 0 1))) @@ -739,6 +536,382 @@ (check-expect (+/f 1 '∞) '∞) (check-expect (+/f 1 2) 3) + +; +; +; +; +; +; ;; ;;;; +; ;;;; ;;;;; +; ;;; ; +; ;;; ;;; ; ;;;; ;;;; ;;;;;; ;; ;;;; ;;;;;; ;; ;;;; ;;; +; ;;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;; ;; ; ;;;;; ;;; ;;;; ;;;;;;; +; ;;;;;;;;; ;;; ;;;;;;;;;;;;;;; ;;; ;; ;; ;;; ;;; ;;;; ; ;;;; +; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;; ;;; +; ;; ;;;; ;;; ;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;; +; ;;;;;;;; ;;; ;;;;;;;;;; ;;; ;; ;;;;; ;;;; ;;; ;;; ;;; +; ;;;;;;;;;;;;;;;; ;;;;;;;;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; ;;;; ;;; +; ;;;;; ;;;; ;;;; ;;;;; ;;; +; ;;;;;;; ;;; +; ;;;;;; +; + + +;; render-world : world -> image +(define (render-world w) + (chop-whiskers + (overlay (board->image (world-board w) + (world-size w) + (on-cats-path? w) + (world-mouse-posn w)) + (move-pinhole + (cond + [(equal? (world-state w) 'cat-won) happy-cat] + [(equal? (world-state w) 'cat-lost) sad-cat] + [else thinking-cat]) + (- (cell-center-x (world-cat w))) + (- (cell-center-y (world-cat w))))))) + +(check-expect + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'playing + 2 + (make-posn 0 0) + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole thinking-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + +(check-expect + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-won + 2 + false + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole happy-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + +(check-expect + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-lost + 2 + false + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + +(check-expect + (render-world + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + false + false)) + (overlay + (board->image (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + 3 + (lambda (x) false) + false) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1)))))) + +(check-expect + (render-world + (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1))) + true)) + + (overlay + (board->image (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + 3 + (lambda (x) true) + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1)))) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1)))))) + +;; chop-whiskers : image -> image +;; crops the image so that anything above or to the left of the pinhole is gone +(define (chop-whiskers img) + (shrink img + 0 + 0 + (- (image-width img) (pinhole-x img) 1) + (- (image-height img) (pinhole-y img) 1))) + +(check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) +(check-expect (chop-whiskers (rectangle 6 6 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + +(check-expect + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 0) + 'playing + 3 + (make-posn 0 0) + false))) + 0) +(check-expect + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false))) + 0) + + +;; board->image : board number (posn -> boolean) posn-or-false -> image +(define (board->image cs world-size on-cat-path? mouse) + (foldl (lambda (x y) (overlay y x)) + (nw:rectangle (world-width world-size) + (world-height world-size) + 'solid + 'white) + (map (lambda (c) (cell->image c + (on-cat-path? (cell-p c)) + (and (posn? mouse) + (equal? mouse (cell-p c))) + #; + (and (posn? mouse) + (point-in-this-circle? (cell-p c) + (posn-x mouse) + (posn-y mouse))))) + cs))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) true) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + true + false))) + + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false) + (cell->image (make-cell (make-posn 0 1) false) + true + false))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + (make-posn 0 0)) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + true) + (cell->image (make-cell (make-posn 0 1) false) + true + false))) + +;; cell->image : cell boolean boolean -> image +(define (cell->image c on-short-path? under-mouse?) + (local [(define x (cell-center-x (cell-p c))) + (define y (cell-center-y (cell-p c))) + (define main-circle + (cond + [(cell-blocked? c) + (circle circle-radius 'solid blocked-color)] + [else + (circle circle-radius 'solid normal-color)]))] + (move-pinhole + (cond + [under-mouse? + (overlay main-circle + (circle (quotient circle-radius 2) 'solid under-mouse-color))] + [on-short-path? + (overlay main-circle + (circle (quotient circle-radius 2) 'solid on-shortest-path-color))] + [else + main-circle]) + (- x) + (- y)))) + +(check-expect (cell->image (make-cell (make-posn 0 0) false) false false) + (move-pinhole (circle circle-radius 'solid normal-color) + (- circle-radius) + (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) true) false false) + (move-pinhole (circle circle-radius 'solid 'black) + (- circle-radius) + (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) false) true false) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid on-shortest-path-color)) + (- circle-radius) + (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) false) true true) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid under-mouse-color)) + (- circle-radius) + (- circle-radius))) + +;; world-width : number -> number +;; computes the width of the drawn world in terms of its size +(define (world-width board-size) + (local [(define rightmost-posn + (make-posn (- board-size 1) (- board-size 2)))] + (+ (cell-center-x rightmost-posn) circle-radius))) + +(check-expect (world-width 3) 150) + +;; world-height : number -> number +;; computes the height of the drawn world in terms of its size +(define (world-height board-size) + (local [(define bottommost-posn + (make-posn (- board-size 1) (- board-size 1)))] + (+ (cell-center-y bottommost-posn) circle-radius))) +(check-expect (world-height 3) 116.208) + + +;; cell-center-x : posn -> number +(define (cell-center-x p) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (+ circle-radius + (* x circle-spacing 2) + (if (odd? y) + circle-spacing + 0)))) + +(check-expect (cell-center-x (make-posn 0 0)) + circle-radius) +(check-expect (cell-center-x (make-posn 0 1)) + (+ circle-spacing circle-radius)) +(check-expect (cell-center-x (make-posn 1 0)) + (+ (* 2 circle-spacing) circle-radius)) +(check-expect (cell-center-x (make-posn 1 1)) + (+ (* 3 circle-spacing) circle-radius)) + +;; cell-center-y : posn -> number +(define (cell-center-y p) + (local [(define y (posn-y p))] + (+ circle-radius + (* y circle-spacing 2 + .866 ;; .866 is an exact approximate to sin(pi/3) + )))) + +(check-expect (cell-center-y (make-posn 1 1)) + (+ circle-radius (* 2 circle-spacing .866))) +(check-expect (cell-center-y (make-posn 1 0)) + circle-radius) + + ; ; ; @@ -762,34 +935,100 @@ (define (clack world x y evt) (cond - [(and (equal? evt 'button-up) - (equal? 'playing (world-state world)) - (point-in-circle? (world-board world) x y)) - (move-cat - (make-world (add-obstacle (world-board world) x y) - (world-cat world) - (world-state world) - (world-size world)))] - [else - world])) + [(equal? evt 'button-up) + (cond + [(and (equal? 'playing (world-state world)) + (point-in-a-circle? (world-board world) x y)) + (move-cat + (update-world-posn + (make-world (add-obstacle (world-board world) x y) + (world-cat world) + (world-state world) + (world-size world) + (world-mouse-posn world) + (world-h-down? world)) + (make-posn x y)))] + [else (update-world-posn world (make-posn x y))])] + [(equal? evt 'button-down) + world] + [(equal? evt 'drag) world] + [(equal? evt 'move) + (update-world-posn world (make-posn x y))] + [(equal? evt 'enter) + (update-world-posn world (make-posn x y))] + [(equal? evt 'leave) + (update-world-posn world false)])) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1) +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false) + 1 1 'button-down) + (make-world '() (make-posn 0 0) 'playing 1 false false)) +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false) + 1 1 'drag) + (make-world '() (make-posn 0 0) 'playing 1 false false)) +(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 1 + false + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'move) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 1 + (make-posn 0 0) + false)) +(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 1 + false + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'enter) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 1 + (make-posn 0 0) + false)) +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) + 1 1 'leave) + (make-world '() (make-posn 0 0) 'playing 1 false false)) + +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) 10 10 'button-down) - (make-world '() (make-posn 0 0) 'playing 1)) + (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1) - 0 - 0 +(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) 'button-up) - (make-world '() (make-posn 0 0) 'playing 1)) + (make-world (list (make-cell (make-posn 0 0) true) + (make-cell (make-posn 1 1) false)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1) + +(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false) 10 10 'button-up) - (make-world '() (make-posn 0 0) 'cat-lost 1)) + (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false)) (check-expect (clack (make-world (list (make-cell (make-posn 1 0) false) @@ -801,7 +1040,9 @@ (make-cell (make-posn 2 2) true)) (make-posn 1 1) 'playing - 3) + 3 + false + false) (cell-center-x (make-posn 1 0)) (cell-center-y (make-posn 1 0)) 'button-up) @@ -815,7 +1056,96 @@ (make-cell (make-posn 2 2) true)) (make-posn 1 1) 'cat-lost - 3)) + 3 + (make-posn 1 0) + false)) + +(check-expect (clack + (make-world + (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'playing + 3 + false + false) + (cell-center-x (make-posn 1 0)) + (cell-center-y (make-posn 1 0)) + 'button-up) + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 2 0) + 'cat-won + 3 + (make-posn 1 0) + false)) + +;; update-world-posn/playing : world posn-or-false -> world +(define (update-world-posn w p) + (cond + [(equal? (world-state w) 'playing) + (cond + [(posn? p) + (local [(define mouse-spot + (circle-at-point (world-board w) + (posn-x p) + (posn-y p)))] + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (cond + [(equal? mouse-spot (world-cat w)) + false] + [else + mouse-spot]) + (world-h-down? w)))] + [else + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + false + (world-h-down? w))])] + [else w])) + +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false)) + +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false)) + +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false) + (make-posn 0 0)) + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false)) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false)) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false)) ;; move-cat : world -> world (define (move-cat world) @@ -843,7 +1173,9 @@ [(on-boundary? next-cat-position (world-size world)) 'cat-won] [else 'playing]) - (world-size world)))) + (world-size world) + (world-mouse-posn world) + (world-h-down? world)))) (check-expect @@ -877,7 +1209,9 @@ (make-cell (make-posn 4 4) false)) (make-posn 2 2) 'playing - 5)) + 5 + (make-posn 0 0) + false)) (make-world (list (make-cell (make-posn 1 0) false) (make-cell (make-posn 2 0) false) (make-cell (make-posn 3 0) false) @@ -907,7 +1241,9 @@ (make-cell (make-posn 4 4) false)) (make-posn 2 3) 'playing - 5)) + 5 + (make-posn 0 0) + false)) ;; find-best-positions : (nelistof posn) (nelistof number or '∞) -> (nelistof posn) or false (define (find-best-positions posns scores) @@ -973,27 +1309,69 @@ (list (make-cell (make-posn 0 0) true) (make-cell (make-posn 0 1) false))) -;; point-in-circle? : board number number -> boolean -(define (point-in-circle? board x y) +;; circle-at-point : board number number -> posn-or-false +;; returns the posn corresponding to cell where the x,y coordinates are +(define (circle-at-point board x y) (cond [(empty? board) false] [else - (local [(define cell (first board)) - (define center (+ (cell-center-x (cell-p cell)) - (* (sqrt -1) (cell-center-y (cell-p cell))))) - (define p (+ x (* (sqrt -1) y)))] - (or (<= (magnitude (- center p)) circle-radius) - (point-in-circle? (rest board) x y)))])) -(check-expect (point-in-circle? empty 0 0) false) -(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) -(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false)) - 0 0) + (cond + [(point-in-this-circle? (cell-p (first board)) x y) + (cell-p (first board))] + [else + (circle-at-point (rest board) x y)])])) +(check-expect (circle-at-point empty 0 0) false) +(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + (make-posn 0 0)) +(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false)) + 0 0) + false) + + +;; point-in-a-circle? : board number number -> boolean +(define (point-in-a-circle? board x y) + (posn? (circle-at-point board x y))) +(check-expect (point-in-a-circle? empty 0 0) false) +(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + true) +(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) + 0 0) + false) + +;; point-in-this-circle? : posn number number -> boolean +(define (point-in-this-circle? p x y) + (local [(define center (+ (cell-center-x p) + (* (sqrt -1) (cell-center-y p)))) + (define p2 (+ x (* (sqrt -1) y)))] + (<= (magnitude (- center p2)) circle-radius))) + +(check-expect (point-in-this-circle? (make-posn 0 0) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + true) +(check-expect (point-in-this-circle? (make-posn 0 0) 0 0) false) - +;; change : world key-event -> world +(define (change w ke) + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (key=? ke #\h))) + +(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false) + #\h) + (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true)) +(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true) + 'release) + (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false)) + @@ -1204,7 +1582,9 @@ (make-posn (quotient board-size 2) (quotient board-size 2)) 'playing - board-size)) + board-size + (make-posn 0 0) + false)) (check-expect (empty-world 3) (make-world (list @@ -1217,7 +1597,9 @@ (make-cell (make-posn 2 2) false)) (make-posn 1 1) 'playing - 3)) + 3 + (make-posn 0 0) + false)) (define dummy (local @@ -1232,12 +1614,15 @@ (make-posn (quotient board-size 2) (quotient board-size 2)) 'playing - board-size))] + board-size + false + false))] (and (big-bang (world-width board-size) (world-height board-size) 1 initial-world) - (on-redraw world->image) + (on-redraw render-world) + (on-key-event change) (on-mouse-event clack)))) diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index 8f48886ccb..d5ba2790dc 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -11,6 +11,12 @@ that space, and the cat responds by taking a step. If the cat is completely boxed in and thus unable reach the border, you win. If the cat does reach the border, you lose. +To get some insight into the cat's behavior, hold down the ``h'' +key. It will show you the cells that are on the cat's shortest path to +the edge, assuming that the cell underneath the mouse has been +blocked, so you can experiment to see how the shortest paths change +by moving your mouse around. + The game was inspired by this one the one at @link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design} and has essentially the same rules. It also inspired the final @@ -60,4 +66,4 @@ the fall of 2008, as below. #:mode 'text)) @m[] -} \ No newline at end of file +} diff --git a/collects/guibuilder/tool.ss b/collects/guibuilder/tool.ss index 0c912944f7..ecdb0a7c6b 100644 --- a/collects/guibuilder/tool.ss +++ b/collects/guibuilder/tool.ss @@ -12,6 +12,8 @@ (provide tool@) + (define-syntax (name stx) (syntax-case stx () [(_ x e) #'(let ((x e)) x)])) + (define tool@ (unit (import drscheme:tool^) @@ -20,6 +22,7 @@ (define (phase2) (drscheme:get/extend:extend-unit-frame (lambda (drs:frame%) + (name guibuilder-frame% (class drs:frame% (inherit get-insert-menu get-edit-target-object) @@ -69,6 +72,6 @@ (send gb create-main-panel) (send gb set-caret-owner #f 'display)))))) (inherit register-capability-menu-item) - (register-capability-menu-item 'drscheme:special:insert-gui-tool (get-insert-menu)))))) + (register-capability-menu-item 'drscheme:special:insert-gui-tool (get-insert-menu))))))) (drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t)))) diff --git a/collects/handin-server/scribblings/checker.scrbl b/collects/handin-server/scribblings/checker.scrbl index 7eb714f4d2..98a45a4fa1 100644 --- a/collects/handin-server/scribblings/checker.scrbl +++ b/collects/handin-server/scribblings/checker.scrbl @@ -353,20 +353,24 @@ code.} Similar to @scheme[!procedure] and @scheme[!procedure*] for integers.} +@deftogether[( @defform*[((!test expr) - (!test/exn expr) (!test expr result) - (!test expr result equal?))]{ + (!test expr result equal?))] +@defform[(!test/exn expr)] +)]{ - The first form checks that the given expression evaluates to a - non-@scheme[#f] value in the submission context, throwing an error - otherwise. The second form checks that the given expression throws - an @scheme[exn:fail?] error, throwing an error otherwise. - The third form compares the result of evaluation, - requiring it to be equal to @scheme[result]. The fourth allows - specifying an equality procedure. Note that the @scheme[result] and - @scheme[equal?] forms are @italic{not} evaluated in the submission - context.} + The first @scheme[!test] form checks that the given expression + evaluates to a non-@scheme[#f] value in the submission context, + throwing an error otherwise. The second form compares the result of + evaluation, requiring it to be equal to @scheme[result]. The third + allows specifying an equality procedure. The @scheme[!test/exn] form + checks that the given expression throws an @scheme[exn:fail?] error, + throwing an error otherwise. + + For the latter two @scheme[!test] forms, note that the + @scheme[result] and @scheme[equal?] forms are @italic{not} evaluated + in the submission context.} @defform[(!eval expr)]{ diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index e2e987f815..7f48a8ddd3 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -903,9 +903,11 @@ Matthew (queue-callback (lambda () (with-handlers ([exn:break? break-handler][exn? exn-handler]) - (set! the-world (f the-world e)) - (add-event KEY e) - (redraw-callback)))))) + (let ([new-world (f the-world e)]) + (unless (equal? new-world the-world) + (set! the-world new-world) + (add-event KEY e) + (redraw-callback)))))))) ;; f : [World Nat Nat MouseEventType -> World] ;; esp : EventSpace @@ -920,7 +922,7 @@ Matthew (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) (with-handlers ([exn:break? break-handler][exn? exn-handler]) (let ([new-world (f the-world x y m)]) - (unless (eq? new-world the-world) + (unless (equal? new-world the-world) (set! the-world new-world) (add-event MOUSE x y m) (redraw-callback))))))))) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 486d2f4218..de17f770ea 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -662,11 +662,16 @@ data-class-names))))))))) (define (get-teachpack-from-user parent) - (define tp-dir (collection-path "teachpack" "htdp")) + (define tp-dirs (list (collection-path "teachpack" "htdp") + (collection-path "teachpack" "2htdp"))) (define columns 2) - (define tps (filter - (λ (x) (file-exists? (build-path tp-dir x))) - (directory-list tp-dir))) + (define tps (apply + append + (map (λ (tp-dir) + (filter + (λ (x) (file-exists? (build-path tp-dir x))) + (directory-list tp-dir))) + tp-dirs))) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) (define pre-installed-tps (sort tps sort-order)) (define dlg (new dialog% [parent parent] [label (string-constant drscheme)])) @@ -826,7 +831,7 @@ (define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t])) (define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons button-panel - (λ (b e) + (λ (b e) (set! answer (figure-out-answer)) (send dlg show #f)) (λ (b e) @@ -837,9 +842,15 @@ (cond [(send pre-installed-lb get-selection) => - (λ (i) `(lib ,(send pre-installed-lb get-string i) - "teachpack" - "htdp"))] + (λ (i) + (define f (send pre-installed-lb get-string i)) + (cond + [(file-exists? (build-path (collection-path "teachpack" "htdp") f)) + `(lib ,f "teachpack" "htdp")] + [(file-exists? (build-path (collection-path "teachpack" "2htdp") f)) + `(lib ,f "teachpack" "2htdp")] + [else (error 'figuer-out-answer "argh: ~a ~a" + (collection-path "teachpack" "htdp") f)]))] [(send user-installed-lb get-selection) => (λ (i) `(lib ,(send user-installed-lb get-string i) diff --git a/collects/lang/private/imageeq.ss b/collects/lang/private/imageeq.ss index 3bb66416ff..45f4aad475 100644 --- a/collects/lang/private/imageeq.ss +++ b/collects/lang/private/imageeq.ss @@ -12,132 +12,8 @@ (or (is-a? a image-snip%) (is-a? a cache-image-snip%))) - (define size-dc (delay (make-object bitmap-dc% (make-object bitmap% 1 1)))) - - (define (snip-size a) - (cond - [(is-a? a cache-image-snip%) - (send a get-size)] - [else - (let* ([dc (force size-dc)] - [wb (box 0)] - [hb (box 0)]) - (send a get-extent dc 0 0 wb hb #f #f #f #f) - (values (unbox wb) - (unbox hb)))])) - (define (image=? a-raw b-raw) (unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw)) (unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw)) - (let ([a (coerce-to-cache-image-snip a-raw)] - [b (coerce-to-cache-image-snip b-raw)]) - (let-values ([(aw ah) (snip-size a)] - [(bw bh) (snip-size b)] - [(apx apy) (send a get-pinhole)] - [(bpx bpy) (send b get-pinhole)]) - (and (= aw bw) - (= ah bh) - (= apx bpx) - (= apy bpy) - (same/alpha? (argb-vector (send a get-argb)) - (argb-vector (send b get-argb))))))) - - (define (same/alpha? v1 v2) - (let loop ([i (vector-length v1)]) - (or (zero? i) - (let ([a1 (vector-ref v1 (- i 4))] - [a2 (vector-ref v2 (- i 4))]) - (and (or (= a1 a2 255) - (and (= a1 a2) - (= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3))) - (= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2))) - (= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1))))) - (loop (- i 4))))))) - - - (define image-snip-cache (make-hash-table 'weak)) - ;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%) - (define (coerce-to-cache-image-snip snp) - (cond - [(hash-table-get image-snip-cache snp (λ () #f)) => values] - [(is-a? snp image-snip%) - (let* ([bmp (send snp get-bitmap)] - [cis - (if bmp - (let ([bmp-mask (or (send bmp get-loaded-mask) - (send snp get-bitmap-mask) - (bitmap->mask bmp))]) - (bitmaps->cache-image-snip (copy-bitmap bmp) - (copy-bitmap bmp-mask) - (floor (/ (send bmp get-width) 2)) - (floor (/ (send bmp get-height) 2)))) - (let-values ([(w h) (snip-size snp)]) - (let* ([bmp (make-object bitmap% - (inexact->exact (floor w)) - (inexact->exact (floor h)))] - [bdc (make-object bitmap-dc% bmp)]) - (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret) - (send bdc set-bitmap #f) - (bitmaps->cache-image-snip bmp - (bitmap->mask bmp) - (floor (/ w 2)) - (floor (/ h 2))))))]) - (hash-table-put! image-snip-cache snp cis) - cis)] - [else snp])) - - ;; copy-bitmap : bitmap -> bitmap - ;; does not copy the mask. - (define (copy-bitmap bitmap) - (let* ([w (send bitmap get-width)] - [h (send bitmap get-height)] - [copy (make-object bitmap% w h)] - [a-dc (make-object bitmap-dc% copy)]) - (send a-dc clear) - (send a-dc draw-bitmap bitmap 0 0) - (send a-dc set-bitmap #f) - copy)) - - ;; bitmap->mask : bitmap -> bitmap - (define (bitmap->mask bitmap) - (let* ([w (send bitmap get-width)] - [h (send bitmap get-height)] - [s (make-bytes (* 4 w h))] - [new-bitmap (make-object bitmap% w h)] - [dc (make-object bitmap-dc% new-bitmap)]) - (send dc clear) - (send dc draw-bitmap bitmap 0 0) - (send dc get-argb-pixels 0 0 w h s) - (let loop ([i (* 4 w h)]) - (unless (zero? i) - (let ([r (- i 3)] - [g (- i 2)] - [b (- i 1)]) - (unless (and (eq? 255 (bytes-ref s r)) - (eq? 255 (bytes-ref s g)) - (eq? 255 (bytes-ref s b))) - (bytes-set! s r 0) - (bytes-set! s g 0) - (bytes-set! s b 0)) - (loop (- i 4))))) - (send dc set-argb-pixels 0 0 w h s) - (begin0 - (send dc get-bitmap) - (send dc set-bitmap #f)))) - - (define (bitmaps->cache-image-snip color mask px py) - (let ([w (send color get-width)] - [h (send color get-height)]) - (new cache-image-snip% - [width w] - [height h] - [dc-proc - (lambda (dc dx dy) - (send dc draw-bitmap color dx dy 'solid - (send the-color-database find-color "black") - mask))] - [argb-proc - (lambda (argb-vector dx dy) - (overlay-bitmap argb-vector dx dy color mask))] - [px px] - [py py])))) + ;; Rely on image-snip% implementing equal<%>: + (equal? a-raw b-raw))) diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index d6c4aac2b4..6fdd3c5100 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -1,7 +1,7 @@ (module intermediate-funs scheme/base (require "teachprims.ss" mzlib/etc - mzlib/list + scheme/list syntax/docprovide (for-syntax scheme/base)) @@ -33,6 +33,12 @@ (ormap ((X -> boolean) (listof X) -> boolean) "(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))") + (argmin ((X -> real) (listof X) -> X) + "to find the (first) element of the list that minimizes the output of the function") + + (argmax ((X -> real) (listof X) -> X) + "to find the (first) element of the list that minimizes the output of the function") + (memf ((X -> boolean) (listof X) -> (union false (listof X))) "to determine whether the first argument produces true for some value in the second argument") (apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 83f7d48c25..97a25505ca 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -10,8 +10,7 @@ namespace. |# (module teachprims mzscheme - (require "../imageeq.ss" - mzlib/list + (require mzlib/list mzlib/etc) (define-syntax (define-teach stx) @@ -202,68 +201,25 @@ namespace. (hash-table-put! ht a prev) (loop v)))) prev)))))] - [union-equal? (lambda (a b) - (let ([a (union-find a)] - [b (union-find b)]) - (if (eq? a b) - #t - (begin - (hash-table-put! ht b a) - #f))))]) + [union-equal!? (lambda (a b) + (let ([a (union-find a)] + [b (union-find b)]) + (if (eq? a b) + #t + (begin + (hash-table-put! ht b a) + #f))))]) (let ? ([a a][b b]) - (or (eqv? a b) - (cond - [(box? a) - (and (box? b) - (? (unbox a) (unbox b)))] - [(pair? a) - (and (pair? b) - (or (union-equal? a b) - (and (? (car a) (car b)) - (? (cdr a) (cdr b)))))] - [(vector? a) - (and (vector? b) - (= (vector-length a) (vector-length b)) - (or (union-equal? a b) - (andmap ? - (vector->list a) - (vector->list b))))] - [(image? a) - (and (image? b) - (image=? a b))] - [(real? a) - (and epsilon - (real? b) - (beginner-=~ a b epsilon))] - [(struct? a) - (and (struct? b) - (let-values ([(ta sa?) (struct-info a)] - [(tb sb?) (struct-info b)]) - (and (not sa?) - (not sb?) - (eq? ta tb) - (or (union-equal? a b) - (? (struct->vector a) - (struct->vector b))))))] - [(hash-table? a) - (and (hash-table? b) - (eq? (immutable? a) (immutable? b)) - (eq? (hash-table? a 'weak) (hash-table? b 'weak)) - (eq? (hash-table? a 'equal) (hash-table? b 'equal)) - (let ([al (hash-table-map a cons)] - [bl (hash-table-map b cons)]) - (and (= (length al) (length bl)) - (or (union-equal? a b) - (andmap - (lambda (ai) - (? (hash-table-get b (car ai) (lambda () (not (cdr ai)))) - (cdr ai))) - al)))))] - [else (equal? a b)]))))) + (cond + [(real? a) + (and (real? b) + (beginner-=~ a b epsilon))] + [(union-equal!? a b) #t] + [else (equal?/recur a b ?)])))) (define-teach beginner equal? (lambda (a b) - (tequal? a b #f))) + (equal? a b))) (define-teach beginner =~ (lambda (a b c) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 04518e9d96..e21bfd92ae 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -47,7 +47,7 @@ (let ([defined null]) (lambda (stx) (syntax-case stx () - [(_ name print-name super args id ...) + [(_ name print-name super (intf ...) args id ...) (let ([nm (syntax-e (syntax name))] [sn (syntax-e (syntax super))] [ids (map syntax-e (syntax->list (syntax (id ...))))]) @@ -78,11 +78,11 @@ (syntax (define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) (make-primitive-class - (lambda (class prop:object preparer dispatcher) + (lambda (class prop:object preparer dispatcher more-props) (kernel:primitive-class-prepare-struct-type! - c prop:object class preparer dispatcher)) + c prop:object class preparer dispatcher more-props)) kernel:initialize-primitive-object - 'print-name super 'args + 'print-name super (list intf ...) 'args '(old ...) '(new ...) (list @@ -110,8 +110,8 @@ (define-a-class name intf super args id ...) (define intf (class->interface name)) (provide (protect intf))))]))) - (define-class object% #f #f) - (define-class window% object% #f + (define-class object% #f () #f) + (define-class window% object% () #f on-drop-file pre-on-event pre-on-char @@ -147,11 +147,11 @@ set-focus gets-focus? centre) - (define-class item% window% #f + (define-class item% window% () #f set-label get-label command) - (define-class message% item% #f + (define-class message% item% () #f get-font set-label on-drop-file @@ -160,7 +160,7 @@ on-size on-set-focus on-kill-focus) - (define-private-class editor% editor<%> object% #f + (define-private-class editor% editor<%> object% () #f dc-location-to-editor-location editor-location-to-dc-location set-inactive-caret-threshold @@ -300,7 +300,7 @@ (define-function write-editor-version) (define-function set-editor-print-margin) (define-function get-editor-print-margin) - (define-class bitmap% object% #f + (define-class bitmap% object% () #f get-argb-pixels get-gl-config set-gl-config @@ -313,7 +313,7 @@ get-width get-height get-depth) - (define-class button% item% #f + (define-class button% item% () #f set-border set-label on-drop-file @@ -322,7 +322,7 @@ on-size on-set-focus on-kill-focus) - (define-class choice% item% #f + (define-class choice% item% () #f set-selection get-selection number @@ -335,7 +335,7 @@ on-set-focus on-kill-focus) (define-function set-combo-box-font) - (define-class check-box% item% #f + (define-class check-box% item% () #f set-label set-value get-value @@ -345,7 +345,7 @@ on-size on-set-focus on-kill-focus) - (define-class canvas% window% #f + (define-class canvas% window% () #f on-drop-file pre-on-event pre-on-char @@ -373,7 +373,7 @@ on-char on-event on-paint) - (define-private-class dc% dc<%> object% #f + (define-private-class dc% dc<%> object% () #f get-alpha set-alpha glyph-exists? @@ -427,7 +427,7 @@ clear) (define-function draw-tab) (define-function draw-tab-base) - (define-class bitmap-dc% dc% () + (define-class bitmap-dc% dc% () () get-bitmap set-bitmap draw-bitmap-section-smooth @@ -435,13 +435,13 @@ get-argb-pixels set-pixel get-pixel) - (define-class post-script-dc% dc% ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t])) - (define-class printer-dc% dc% ([parent #f])) - (define-private-class gl-context% gl-context<%> object% #f + (define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t])) + (define-class printer-dc% dc% () ([parent #f])) + (define-private-class gl-context% gl-context<%> object% () #f call-as-current swap-buffers ok?) - (define-class gl-config% object% #f + (define-class gl-config% object% () #f get-double-buffered set-double-buffered get-stereo @@ -454,23 +454,23 @@ set-depth-size get-multisample-size set-multisample-size) - (define-class event% object% ([time-stamp 0]) + (define-class event% object% () ([time-stamp 0]) get-time-stamp set-time-stamp) - (define-class control-event% event% (event-type [time-stamp 0]) + (define-class control-event% event% () (event-type [time-stamp 0]) get-event-type set-event-type) - (define-class popup-event% control-event% #f + (define-class popup-event% control-event% () #f get-menu-id set-menu-id) - (define-class scroll-event% event% ([event-type thumb] [direction vertical] [position 0] [time-stamp 0]) + (define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0]) get-event-type set-event-type get-direction set-direction get-position set-position) - (define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f]) + (define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f]) set-other-caps-key-code get-other-caps-key-code set-other-shift-altgr-key-code @@ -498,7 +498,7 @@ get-y set-y) (define-function key-symbol-to-integer) - (define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f]) + (define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f]) moving? leaving? entering? @@ -528,7 +528,7 @@ set-x get-y set-y) - (define-class frame% window% #f + (define-class frame% window% () #f on-drop-file pre-on-event pre-on-char @@ -556,7 +556,7 @@ set-icon iconize set-title) - (define-class gauge% item% #f + (define-class gauge% item% () #f get-value set-value get-range @@ -567,7 +567,7 @@ on-size on-set-focus on-kill-focus) - (define-class font% object% #f + (define-class font% object% () #f screen-glyph-exists? get-font-id get-size-in-pixels @@ -578,32 +578,32 @@ get-style get-face get-family) - (define-class font-list% object% #f + (define-class font-list% object% () #f find-or-create-font) - (define-class color% object% #f + (define-class color% object% () #f blue green red set ok? copy-from) - (define-private-class color-database% color-database<%> object% #f + (define-private-class color-database% color-database<%> object% () #f find-color) - (define-class point% object% #f + (define-class point% object% () #f get-x set-x get-y set-y) - (define-class brush% object% #f + (define-class brush% object% () #f set-style get-style set-stipple get-stipple set-color get-color) - (define-class brush-list% object% #f + (define-class brush-list% object% () #f find-or-create-brush) - (define-class pen% object% #f + (define-class pen% object% () #f set-style get-style set-stipple @@ -616,11 +616,11 @@ get-cap set-width get-width) - (define-class pen-list% object% #f + (define-class pen-list% object% () #f find-or-create-pen) - (define-class cursor% object% #f + (define-class cursor% object% () #f ok?) - (define-class region% object% (dc) + (define-class region% object% () (dc) in-region? is-empty? get-bounding-box @@ -635,7 +635,7 @@ set-rounded-rectangle set-rectangle get-dc) - (define-class dc-path% object% #f + (define-class dc-path% object% () #f get-bounding-box append reverse @@ -653,7 +653,7 @@ open? close reset) - (define-private-class font-name-directory% font-name-directory<%> object% #f + (define-private-class font-name-directory% font-name-directory<%> object% () #f find-family-default-font-id find-or-create-font-id get-family @@ -686,7 +686,7 @@ (define-function get-display-depth) (define-function is-color-display?) (define-function file-selector) - (define-class list-box% item% #f + (define-class list-box% item% () #f get-label-font set-string set-first-visible-item @@ -710,7 +710,7 @@ on-size on-set-focus on-kill-focus) - (define-class editor-canvas% canvas% #f + (define-class editor-canvas% canvas% () #f on-char on-event on-paint @@ -741,7 +741,7 @@ set-editor get-wheel-step set-wheel-step) - (define-class editor-admin% object% #f + (define-class editor-admin% object% () #f modified refresh-delayed? popup-menu @@ -753,9 +753,9 @@ get-max-view get-view get-dc) - (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f + (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% () #f get-snip) - (define-class snip-admin% object% #f + (define-class snip-admin% object% () #f modified popup-menu update-cursor @@ -769,7 +769,7 @@ get-view-size get-dc get-editor) - (define-class snip-class% object% #f + (define-class snip-class% object% () #f reading-version write-header read-header @@ -778,13 +778,13 @@ set-classname get-version set-version) - (define-private-class snip-class-list% snip-class-list<%> object% #f + (define-private-class snip-class-list% snip-class-list<%> object% () #f nth number add find-position find) - (define-class keymap% object% #f + (define-class keymap% object% () #f remove-chained-keymap chain-to-keymap set-break-sequence-callback @@ -800,11 +800,11 @@ handle-key-event set-double-click-interval get-double-click-interval) - (define-class editor-wordbreak-map% object% #f + (define-class editor-wordbreak-map% object% () #f get-map set-map) (define-function get-the-editor-wordbreak-map) - (define-class text% editor% #f + (define-class text% editor% () #f call-clickback remove-clickback set-clickback @@ -958,7 +958,7 @@ on-event copy-self-to copy-self) - (define-class menu% object% #f + (define-class menu% object% () #f select get-font set-width @@ -973,30 +973,30 @@ delete-by-position delete append) - (define-class menu-bar% object% #f + (define-class menu-bar% object% () #f set-label-top number enable-top delete append) - (define-class menu-item% object% #f + (define-class menu-item% object% () #f id) (define-function id-to-menu-item) - (define-class editor-stream-in-base% object% #f + (define-class editor-stream-in-base% object% () #f read bad? skip seek tell) - (define-class editor-stream-out-base% object% #f + (define-class editor-stream-out-base% object% () #f write bad? seek tell) - (define-class editor-stream-in-bytes-base% editor-stream-in-base% #f) - (define-class editor-stream-out-bytes-base% editor-stream-out-base% #f + (define-class editor-stream-in-bytes-base% editor-stream-in-base% () #f) + (define-class editor-stream-out-bytes-base% editor-stream-out-base% () #f get-bytes) - (define-class editor-stream-in% object% #f + (define-class editor-stream-in% object% () #f ok? jump-to tell @@ -1009,19 +1009,19 @@ get-unterminated-bytes get-bytes get) - (define-class editor-stream-out% object% #f + (define-class editor-stream-out% object% () #f ok? pretty-finish jump-to tell put-fixed put) - (define-class timer% object% () + (define-class timer% object% () () stop start notify interval) - (define-private-class clipboard% clipboard<%> object% #f + (define-private-class clipboard% clipboard<%> object% () #f get-clipboard-bitmap set-clipboard-bitmap get-clipboard-data @@ -1030,12 +1030,12 @@ set-clipboard-client) (define-function get-the-x-selection) (define-function get-the-clipboard) - (define-class clipboard-client% object% () + (define-class clipboard-client% object% () () get-types add-type get-data on-replaced) - (define-class ps-setup% object% () + (define-class ps-setup% object% () () copy-from set-margin set-editor-margin @@ -1061,7 +1061,7 @@ get-command) (define-function show-print-setup) (define-function can-show-print-setup?) - (define-class pasteboard% editor% #f + (define-class pasteboard% editor% () #f set-scroll-step get-scroll-step set-selection-visible @@ -1177,7 +1177,7 @@ paste copy cut) - (define-class panel% window% #f + (define-class panel% window% () #f get-label-position set-label-position on-char @@ -1191,7 +1191,7 @@ on-kill-focus set-item-cursor get-item-cursor) - (define-class dialog% window% #f + (define-class dialog% window% () #f system-menu set-title on-drop-file @@ -1203,7 +1203,7 @@ enforce-size on-close on-activate) - (define-class radio-box% item% #f + (define-class radio-box% item% () #f button-focus enable set-selection @@ -1215,7 +1215,7 @@ on-size on-set-focus on-kill-focus) - (define-class slider% item% #f + (define-class slider% item% () #f set-value get-value on-drop-file @@ -1224,7 +1224,7 @@ on-size on-set-focus on-kill-focus) - (define-class snip% object% #f + (define-class snip% object% () #f previous next set-unmodified @@ -1262,7 +1262,7 @@ get-style get-snipclass set-snipclass) - (define-class string-snip% snip% #f + (define-class string-snip% snip% () #f read insert set-unmodified @@ -1289,7 +1289,7 @@ draw partial-offset get-extent) - (define-class tab-snip% string-snip% #f + (define-class tab-snip% string-snip% () #f set-unmodified get-scroll-step-offset find-scroll-step @@ -1314,7 +1314,11 @@ draw partial-offset get-extent) - (define-class image-snip% snip% #f + (define-class image-snip% snip% (equal<%>) #f + equal-secondary-hash-code-of + equal-hash-code-of + other-equal-to? + equal-to? set-offset get-bitmap-mask get-bitmap @@ -1346,7 +1350,7 @@ draw partial-offset get-extent) - (define-class editor-snip% snip% #f + (define-class editor-snip% snip% () #f get-inset set-inset get-margin @@ -1393,23 +1397,23 @@ get-extent set-editor get-editor) - (define-class editor-data-class% object% #f + (define-class editor-data-class% object% () #f read get-classname set-classname) - (define-private-class editor-data-class-list% editor-data-class-list<%> object% #f + (define-private-class editor-data-class-list% editor-data-class-list<%> object% () #f nth number add find-position find) - (define-class editor-data% object% #f + (define-class editor-data% object% () #f set-next write get-dataclass set-dataclass get-next) - (define-private-class mult-color% mult-color<%> object% #f + (define-private-class mult-color% mult-color<%> object% () #f set get get-r @@ -1418,7 +1422,7 @@ set-g get-b set-b) - (define-private-class add-color% add-color<%> object% #f + (define-private-class add-color% add-color<%> object% () #f set get get-r @@ -1427,7 +1431,7 @@ set-g get-b set-b) - (define-class style-delta% object% #f + (define-class style-delta% object% () #f copy collapse equal? @@ -1475,7 +1479,7 @@ set-alignment-on get-alignment-off set-alignment-off) - (define-private-class style% style<%> object% #f + (define-private-class style% style<%> object% () #f switch-to set-shift-style get-shift-style @@ -1502,7 +1506,7 @@ get-face get-family get-name) - (define-class style-list% object% #f + (define-class style-list% object% () #f forget-notification notify-on-change style-to-index @@ -1516,7 +1520,7 @@ number basic-style) (define-function get-the-style-list) - (define-class tab-group% item% #f + (define-class tab-group% item% () #f button-focus set set-label @@ -1532,7 +1536,7 @@ on-size on-set-focus on-kill-focus) - (define-class group-box% item% #f + (define-class group-box% item% () #f on-drop-file pre-on-event pre-on-char diff --git a/collects/mrlib/cache-image-snip.ss b/collects/mrlib/cache-image-snip.ss index 124561cf3b..91a799b1be 100644 --- a/collects/mrlib/cache-image-snip.ss +++ b/collects/mrlib/cache-image-snip.ss @@ -7,7 +7,11 @@ (provide cache-image-snip% cache-image-snip-class% - snip-class) + snip-class + + coerce-to-cache-image-snip + snip-size + bitmaps->cache-image-snip) ;; type argb = (make-argb (vectorof rational[between 0 & 255]) int int) (define-struct argb (vector width height)) @@ -38,9 +42,9 @@ an alpha of 1 means the pixel value is 0 an alpha of 0 means the pixel value is 255 |# - + (define cache-image-snip% - (class snip% + (class image-snip% ;; dc-proc : (union #f ((is-a?/c dc<%>) int[dx] int[dy] -> void)) ;; used for direct drawing @@ -85,7 +89,7 @@ ;; get-bitmap : -> bitmap or false ;; returns a bitmap showing what the image would look like, ;; if it were drawn - (define/public (get-bitmap) + (define/override (get-bitmap) (cond [(or (zero? width) (zero? height)) #f] @@ -141,6 +145,15 @@ (define/override (get-num-scroll-steps) (inexact->exact (+ (floor (/ height 20)) 1))) (define/override (find-scroll-step y) (inexact->exact (floor (/ y 20)))) (define/override (get-scroll-step-offset offset) (* offset 20)) + + (define/override (equal-to? snip recur) + (if (snip . is-a? . cache-image-snip%) + ;; Support extensions of cache-image-snip%: + (send snip other-equal-to? this recur) + ;; Use ths object's extension: + (other-equal-to? snip recur))) + (define/override (other-equal-to? snip recur) + (image=? this snip)) (super-new) (inherit set-snipclass) @@ -215,6 +228,139 @@ (lambda (argb dx dy) (overlay-bitmap argb size size dx dy bm bm))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; image equality + ;; + + (define size-dc (delay (make-object bitmap-dc% (make-object bitmap% 1 1)))) + + (define (snip-size a) + (cond + [(is-a? a cache-image-snip%) + (send a get-size)] + [else + (let* ([dc (force size-dc)] + [wb (box 0)] + [hb (box 0)]) + (send a get-extent dc 0 0 wb hb #f #f #f #f) + (values (unbox wb) + (unbox hb)))])) + + (define (image=? a-raw b-raw) + (let ([a (coerce-to-cache-image-snip a-raw)] + [b (coerce-to-cache-image-snip b-raw)]) + (let-values ([(aw ah) (snip-size a)] + [(bw bh) (snip-size b)] + [(apx apy) (send a get-pinhole)] + [(bpx bpy) (send b get-pinhole)]) + (and (= aw bw) + (= ah bh) + (= apx bpx) + (= apy bpy) + (same/alpha? (argb-vector (send a get-argb)) + (argb-vector (send b get-argb))))))) + + (define (same/alpha? v1 v2) + (let loop ([i (vector-length v1)]) + (or (zero? i) + (let ([a1 (vector-ref v1 (- i 4))] + [a2 (vector-ref v2 (- i 4))]) + (and (or (= a1 a2 255) + (and (= a1 a2) + (= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3))) + (= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2))) + (= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1))))) + (loop (- i 4))))))) + + (define image-snip-cache (make-hash-table 'weak)) + ;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%) + (define (coerce-to-cache-image-snip snp) + (cond + [(is-a? snp cache-image-snip%) snp] + [(hash-table-get image-snip-cache snp (λ () #f)) => values] + [(is-a? snp image-snip%) + (let* ([bmp (send snp get-bitmap)] + [cis + (if bmp + (let ([bmp-mask (or (send bmp get-loaded-mask) + (send snp get-bitmap-mask) + (bitmap->mask bmp))]) + (bitmaps->cache-image-snip (copy-bitmap bmp) + (copy-bitmap bmp-mask) + (floor (/ (send bmp get-width) 2)) + (floor (/ (send bmp get-height) 2)))) + (let-values ([(w h) (snip-size snp)]) + (let* ([bmp (make-object bitmap% + (inexact->exact (floor w)) + (inexact->exact (floor h)))] + [bdc (make-object bitmap-dc% bmp)]) + (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret) + (send bdc set-bitmap #f) + (bitmaps->cache-image-snip bmp + (bitmap->mask bmp) + (floor (/ w 2)) + (floor (/ h 2))))))]) + (hash-table-put! image-snip-cache snp cis) + cis)] + [else snp])) + + ;; copy-bitmap : bitmap -> bitmap + ;; does not copy the mask. + (define (copy-bitmap bitmap) + (let* ([w (send bitmap get-width)] + [h (send bitmap get-height)] + [copy (make-object bitmap% w h)] + [a-dc (make-object bitmap-dc% copy)]) + (send a-dc clear) + (send a-dc draw-bitmap bitmap 0 0) + (send a-dc set-bitmap #f) + copy)) + + ;; bitmap->mask : bitmap -> bitmap + (define (bitmap->mask bitmap) + (let* ([w (send bitmap get-width)] + [h (send bitmap get-height)] + [s (make-bytes (* 4 w h))] + [new-bitmap (make-object bitmap% w h)] + [dc (make-object bitmap-dc% new-bitmap)]) + (send dc clear) + (send dc draw-bitmap bitmap 0 0) + (send dc get-argb-pixels 0 0 w h s) + (let loop ([i (* 4 w h)]) + (unless (zero? i) + (let ([r (- i 3)] + [g (- i 2)] + [b (- i 1)]) + (unless (and (eq? 255 (bytes-ref s r)) + (eq? 255 (bytes-ref s g)) + (eq? 255 (bytes-ref s b))) + (bytes-set! s r 0) + (bytes-set! s g 0) + (bytes-set! s b 0)) + (loop (- i 4))))) + (send dc set-argb-pixels 0 0 w h s) + (begin0 + (send dc get-bitmap) + (send dc set-bitmap #f)))) + + (define (bitmaps->cache-image-snip color mask px py) + (let ([w (send color get-width)] + [h (send color get-height)]) + (new cache-image-snip% + [width w] + [height h] + [dc-proc + (lambda (dc dx dy) + (send dc draw-bitmap color dx dy 'solid + (send the-color-database find-color "black") + mask))] + [argb-proc + (lambda (argb-vector dx dy) + (overlay-bitmap argb-vector dx dy color mask))] + [px px] + [py py]))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; misc. utilities diff --git a/collects/mrlib/scribblings/cache-image-snip.scrbl b/collects/mrlib/scribblings/cache-image-snip.scrbl index 6013f3c297..245806c631 100644 --- a/collects/mrlib/scribblings/cache-image-snip.scrbl +++ b/collects/mrlib/scribblings/cache-image-snip.scrbl @@ -16,7 +16,22 @@ bitmap, but with alpha values. It has a maker, two selectors, and a predicate. -@defclass[cache-image-snip% snip% ()]{ +@defclass[cache-image-snip% image-snip% ()]{ + +The @scheme[cache-image-snip%] class is a subclass of +@scheme[image-snip%] simply so that its instances can be compared with +@scheme[image-snip%] using @scheme[equal?]. All @scheme[image-snip%] +functionality is overridden or ignored. + +@defmethod[#:mode overrride + (equal-to? [snip (is-a?/c image-snip%)] + [equal? (any/c any/c . -> . boolean?)]) + boolean?]{ + +Calls the @method[cache-image-snip% other-equal-to?] method of +@scheme[snip] if it is also a @scheme[cache-image-snip%] instance, +otherwise calls the @method[cache-image-snip% other-equal-to?] of +@this-obj[].} @defmethod[(get-argb) @@ -44,7 +59,8 @@ predicate. } -@defmethod[(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{ +@defmethod[#:mode override + (get-bitmap) (or/c false/c (is-a?/c bitmap%))]{ Builds (if not yet built) a bitmap corresponding to this snip and returns it. @@ -75,7 +91,15 @@ predicate. Returns the width and height for the image. -}} +} + +@defmethod[#:mode override + (other-equal-to? [snip (is-a?/c image-snip%)] + [equal? (any/c any/c . -> . boolean?)]) + boolean?]{ + +Refines the comparison of @xmethod[image-snip% other-equal-to?] to +exactly match alpha channels.}} @; ---------------------------------------- @@ -83,6 +107,7 @@ predicate. This snipclass is used for saved cache image snips.} + @defproc[(make-argb [vectorof (integer-in 0 255)] [width exact-nonnegative-integer?] [height exact-nonnegative-integer?]) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 767856da13..80197a5394 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -155,17 +155,17 @@ (raise-stx-err "not a unit definition" id)) u)) - ;; check-module-id-subset : (listof syntax-object) (listof identifier) syntax-object -> - ;; ensures each element of i1 is an identifier module-identifier=? to an identifier in i2 - (define (check-module-id-subset i1 i2) - (let ((ht (make-module-identifier-mapping))) + ;; check-bound-id-subset : (listof syntax-object) (listof identifier) syntax-object -> + ;; ensures each element of i1 is an identifier bound-identifier=? to an identifier in i2 + (define (check-bound-id-subset i1 i2) + (let ((ht (make-bound-identifier-mapping))) (for-each (lambda (id) - (module-identifier-mapping-put! ht id #t)) + (bound-identifier-mapping-put! ht id #t)) i2) (for-each (lambda (id) (check-id id) - (unless (module-identifier-mapping-get ht id (lambda () #f)) + (unless (bound-identifier-mapping-get ht id (lambda () #f)) (raise-stx-err "listed identifier not present in signature specification" id))) i1))) @@ -173,20 +173,20 @@ ;; internals and externals must both be of the form (x ...) ;; ensures that each x above is an identifier (define (do-rename sig internals externals) - (check-module-id-subset (syntax->list externals) + (check-bound-id-subset (syntax->list externals) (sig-int-names sig)) - (let ((ht (make-module-identifier-mapping))) + (let ((ht (make-bound-identifier-mapping))) (for-each (lambda (int ext) (check-id int) - (when (module-identifier-mapping-get ht ext (lambda () #f)) + (when (bound-identifier-mapping-get ht ext (lambda () #f)) (raise-stx-err "duplicate renamings" ext)) - (module-identifier-mapping-put! ht ext int)) + (bound-identifier-mapping-put! ht ext int)) (syntax->list internals) (syntax->list externals)) (map-sig (lambda (id) - (module-identifier-mapping-get ht id (lambda () id))) + (bound-identifier-mapping-get ht id (lambda () id))) (lambda (x) x) sig))) @@ -203,17 +203,17 @@ ;; do-only/except : sig (listof identifier) -> sig ;; ensures that only-ids are identifiers and are mentioned in the signature (define (do-only/except sig only/except-ids put get) - (check-module-id-subset only/except-ids + (check-bound-id-subset only/except-ids (sig-int-names sig)) - (let ((ht (make-module-identifier-mapping))) + (let ((ht (make-bound-identifier-mapping))) (for-each (lambda (id) - (module-identifier-mapping-put! ht id (put id))) + (bound-identifier-mapping-put! ht id (put id))) only/except-ids) (map-sig (lambda (id) - (module-identifier-mapping-get ht id - (lambda () - (get id)))) + (bound-identifier-mapping-get ht id + (lambda () + (get id)))) (lambda (x) x) sig))) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index b7773be917..01855154f4 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -378,13 +378,9 @@ (eq? 'windows (file-url-path-convention-type)) (not (equal? host "")))]) (when win-file? - (if (equal? "" port) - (set! path (string-append host ":" path)) - (set! path (if path - (if host - (string-append host "/" path) - path) - host))) + (set! path (cond [(equal? "" port) (string-append host ":" path)] + [(and path host) (string-append host "/" path)] + [else (or path host)])) (set! port #f) (set! host "")) (let* ([scheme (and scheme (string-downcase scheme))] diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index 8c166179c2..e44267bdc0 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -164,6 +164,8 @@ ;; quote has to create mpairs: (syntax-local-lift-expression (let loop ([form #'form]) (syntax-case form () + [(a ...) + #`(mlist . #,(map loop (syntax->list #'(a ...))))] [(a . b) #`(mcons #,(loop #'a) #,(loop #'b))] [#(a ...) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index b57539df09..db9c0c8562 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -11,8 +11,10 @@ (require (for-syntax (lib "name.ss" "syntax") "rewrite-side-conditions.ss" "term-fn.ss" + "underscore-allowed.ss" (lib "boundmap.ss" "syntax") - scheme/base)) + scheme/base + (prefix-in pattern- scheme/match))) (define (language-nts lang) (hash-map (compiled-lang-ht lang) (λ (x y) x))) @@ -440,16 +442,17 @@ (syntax->list (syntax (extras ...))) lang-id))] [((rhs-arrow rhs-from rhs-to) (lhs-arrow lhs-frm-id lhs-to-id)) - (let ([lang-nts (language-id-nts lang-id orig-name)]) + (let* ([lang-nts (language-id-nts lang-id orig-name)] + [rewrite-side-conds + (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))]) (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t (syntax rhs-from))]) (with-syntax ([(names ...) names] [(names/ellipses ...) names/ellipses] - [side-conditions-rewritten (rewrite-side-conditions/check-errs - lang-nts - orig-name - #t + [side-conditions-rewritten (rewrite-side-conds (rewrite-node-pat (syntax-e (syntax lhs-frm-id)) - (syntax->datum (syntax rhs-from))))] + (syntax rhs-from)))] + [fresh-rhs-from (rewrite-side-conds + (freshen-names #'rhs-from #'lhs-frm-id lang-nts orig-name))] [lang lang]) (map (λ (child-proc) @@ -460,19 +463,51 @@ (λ (bindings rhs-binder) (term-let ([lhs-to-id rhs-binder] [names/ellipses (lookup-binding bindings 'names)] ...) - (term rhs-to))) - #,child-proc)) + (term rhs-to))) + #,child-proc + `fresh-rhs-from)) (get-choices stx orig-name bm #'lang (syntax lhs-arrow) name-table lang-id - allow-zero-rules?)))))])) + allow-zero-rules?)))))])) (define (rewrite-node-pat id term) - (let loop ([term term]) - (cond - [(eq? id term) `(name ,id any)] - [(pair? term) (cons (loop (car term)) - (loop (cdr term)))] - [else term]))) + (let loop ([t term]) + (syntax-case t (side-condition) + [(side-condition p c) + #`(side-condition #,(loop #'p) c)] + [(p ...) + (map loop (syntax->list #'(p ...)))] + [else + (if (and (identifier? t) (eq? id (syntax-e t))) + `(name ,id any) + t)]))) + + (define (freshen-names pat hole-id nts what) + (define (fresh x) + (gensym + (if (or (memq x nts) (memq x underscore-allowed)) + (string-append (symbol->string x) "_") + x))) + (let-values ([(bound _) (extract-names nts what #t pat #f)]) + (let ([renames (make-bound-identifier-mapping)]) + (for-each + (λ (x) + (unless (bound-identifier=? x hole-id) + (bound-identifier-mapping-put! renames x (fresh (syntax-e x))))) + bound) + (let recur ([p pat]) + (syntax-case p (side-condition) + [(side-condition p c) + #`(side-condition + #,(recur #'p) + (term-let (#,@(bound-identifier-mapping-map renames (λ (x y) #`(#,x (term #,y))))) + c))] + [(p ...) + #`(#,@(map recur (syntax->list #'(p ...))))] + [else + (if (identifier? p) + (bound-identifier-mapping-get renames p (λ () p)) + p)]))))) (define (do-leaf stx orig-name lang name-table from to extras lang-id) (let ([lang-nts (language-id-nts lang-id orig-name)]) @@ -484,7 +519,7 @@ orig-name #t from)] - [to to] + [to to #;#`,(begin (printf "~s\n" #,name) (term #,to))] [name name] [lang lang] [(names ...) names] @@ -639,6 +674,18 @@ (cons (format " ~s" (syntax->datum (car stxs))) (loop (cdr stxs)))]))))) +(define (substitute from to pat) + (let recur ([p pat]) + (syntax-case p (side-condition) + [(side-condition p c) + #`(side-condition #,(recur #'p) c)] + [(p ...) + #`(#,@(map recur (syntax->list #'(p ...))))] + [else + (if (and (identifier? p) (bound-identifier=? p from)) + to + p)]))) + (define (verify-name-ok orig-name the-name) (unless (symbol? the-name) (error orig-name "expected a single name, got ~s" the-name))) @@ -679,7 +726,12 @@ (apply append (map reduction-relation-lws lst)) `any))) -(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc) +(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc rhs-from) + (define (subst from to in) + (let recur ([p in]) + (cond [(eq? from p) to] + [(pair? p) (map recur p)] + [else p]))) ;; need call to make-rewrite-proc ;; also need a test case here to check duplication of names. (make-rewrite-proc @@ -701,7 +753,8 @@ (λ (x) (f (rhs-proc (mtch-bindings (car mtchs)) x))) acc)))])) other-matches))))) - (rewrite-proc-name child-make-proc))) + (rewrite-proc-name child-make-proc) + (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from))) (define (do-leaf-match name pat proc) (make-rewrite-proc @@ -717,7 +770,8 @@ mtchs other-matches) other-matches))))) - name)) + name + pat)) (define-syntax (test-match stx) (syntax-case stx () @@ -758,7 +812,7 @@ (symbol->string (bind-name y)))))) (define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!) - (make-struct-type 'metafunc-proc #f 9 0 #f null (current-inspector) 0)) + (make-struct-type 'metafunc-proc #f 10 0 #f null (current-inspector) 0)) (define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1)) (define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2)) (define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3)) @@ -767,6 +821,7 @@ (define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6)) (define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7)) (define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 8)) +(define metafunc-proc-lhs-pats (make-struct-field-accessor metafunc-proc-ref 9)) (define-struct metafunction (proc)) (define-syntax (in-domain? stx) @@ -937,7 +992,8 @@ cps rhss (let ([name (lambda (x) (name-predicate x))]) name) - `dom-side-conditions-rewritten)) + `dom-side-conditions-rewritten + `(side-conditions-rewritten ...))) `dom-side-conditions-rewritten `codom-side-conditions-rewritten 'name)) @@ -1714,6 +1770,7 @@ metafunc-proc-rhss metafunc-proc-in-dom? metafunc-proc-dom-pat + metafunc-proc-lhs-pats (struct-out binds)) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index 8086c8725b..398b29f1f8 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -1,9 +1,10 @@ -(module rewrite-side-conditions mzscheme +(module rewrite-side-conditions scheme/base (require (lib "list.ss") "underscore-allowed.ss") - (require-for-template mzscheme - "term.ss" - "matcher.ss") + (require (for-template + mzscheme + "term.ss" + "matcher.ss")) (provide rewrite-side-conditions/check-errs extract-names @@ -85,7 +86,7 @@ (define-struct id/depth (id depth)) ;; extract-names : syntax syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...])) - (define (extract-names all-nts what bind-names? orig-stx) + (define (extract-names all-nts what bind-names? orig-stx [rhs-only? #t]) (let* ([dups (let loop ([stx orig-stx] [names null] @@ -115,8 +116,8 @@ [else (if (or (null? (cdr pats)) (not (identifier? (cadr pats))) - (not (or (module-identifier=? (quote-syntax ...) - (cadr pats)) + (not (or (free-identifier=? (quote-syntax ...) + (cadr pats)) (let ([inside (syntax-e (cadr pats))]) (regexp-match #rx"^\\.\\.\\._" (symbol->string inside)))))) (i-loop (cdr pats) @@ -125,7 +126,8 @@ (loop (car pats) names (+ depth 1))))]))] [x (and (identifier? (syntax x)) - (binds-in-right-hand-side? all-nts bind-names? (syntax x))) + ((if rhs-only? binds-in-right-hand-side? binds?) + all-nts bind-names? (syntax x))) (cons (make-id/depth (syntax x) depth) names)] [else names]))] [no-dups (filter-duplicates what orig-stx dups)]) @@ -141,14 +143,16 @@ [dots (quote-syntax ...)]) (syntax (rest dots)))]))) - - (define (binds-in-right-hand-side? nts bind-names? x) + (define (binds? nts bind-names? x) (or (and bind-names? (memq (syntax-e x) nts)) (and bind-names? (memq (syntax-e x) underscore-allowed)) - (let ([str (symbol->string (syntax-e x))]) - (and (regexp-match #rx"_" str) - (not (regexp-match #rx"^\\.\\.\\._" str)) - (not (regexp-match #rx"_!_" str)))))) + (regexp-match #rx"_" (symbol->string (syntax-e x))))) + + (define (binds-in-right-hand-side? nts bind-names? x) + (and (binds? nts bind-names? x) + (let ([str (symbol->string (syntax-e x))]) + (and (not (regexp-match #rx"^\\.\\.\\._" str)) + (not (regexp-match #rx"_!_" str)))))) (define (filter-duplicates what orig-stx dups) (let loop ([dups dups]) @@ -158,8 +162,8 @@ (cons (car dups) (filter (lambda (x) - (let ([same-id? (module-identifier=? (id/depth-id x) - (id/depth-id (car dups)))]) + (let ([same-id? (free-identifier=? (id/depth-id x) + (id/depth-id (car dups)))]) (when same-id? (unless (equal? (id/depth-depth x) (id/depth-depth (car dups))) @@ -167,7 +171,7 @@ (make-exn:fail:syntax (format "~a: found the same binder, ~s, at different depths, ~a and ~a" what - (syntax-object->datum (id/depth-id x)) + (syntax->datum (id/depth-id x)) (id/depth-depth x) (id/depth-depth (car dups))) (current-continuation-marks) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 836183f185..299eb3aa06 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -90,6 +90,21 @@ (test (pick-char 0 null (make-random 65)) #\a) (test (random-string null null 1 0 (make-random 65)) "a")) +(let () + (define-language L + (a 5 (x a) #:binds x a) + (b 4)) + (test ((pick-nt 'dontcare) 'a L '(x) 1) + (nt-rhs (car (compiled-lang-lang L)))) + (test ((pick-nt 'dontcare (make-random 1)) 'a L '(x) preferred-production-threshold) + (nt-rhs (car (compiled-lang-lang L)))) + (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))]) + (test ((pick-nt (make-immutable-hash `((a ,pref))) (make-random 0)) + 'a L '(x) preferred-production-threshold) + (list pref))) + (test ((pick-nt 'dontcare) 'sexp sexp null preferred-production-threshold) + (nt-rhs (car (compiled-lang-lang sexp))))) + (define-syntax exn:fail-message (syntax-rules () [(_ expr) @@ -101,7 +116,9 @@ (make-exn-not-raised))))])) (define (patterns . selectors) - (map (λ (selector) (λ (name prods vars size) (list (selector prods)))) + (map (λ (selector) + (λ (name lang vars size) + (list (selector (nt-rhs (nt-by-name lang name)))))) selectors)) (define (iterator name items) @@ -145,7 +162,7 @@ ;; Generate (λ (x) x) (test - (generate/decisions + (generate-term lc e 1 0 (decisions #:var (list (λ _ 'x) (λ _'x)) #:nt (patterns third first first first))) @@ -153,14 +170,14 @@ ;; Generate pattern that's not a non-terminal (test - (generate/decisions + (generate-term lc (x x x_1 x_1) 1 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)))) '(x x y y)) ; After choosing (e e), size decremented forces each e to x. (test - (generate/decisions + (generate-term lc e 1 0 (decisions #:nt (patterns first) #:var (list (λ _ 'x) (λ _ 'y)))) @@ -176,7 +193,7 @@ (let* ([x null] [prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))]) (test (begin - (generate/decisions lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!))) + (generate-term lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!))) x) '(x x)))) @@ -187,7 +204,7 @@ (x (variable-except λ))) (test (exn:fail-message - (generate/decisions + (generate-term postfix e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)) #:nt (patterns third second first first)))) @@ -198,7 +215,7 @@ (define-language var (e (variable-except x y))) (test - (generate/decisions + (generate-term var e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) 'z)) @@ -215,25 +232,25 @@ (n number) (z 4)) (test - (generate/decisions + (generate-term lang a 2 0 (decisions #:num (build-list 3 (λ (n) (λ (_) n))) #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1)))) `(0 1 2 "foo" "foo" "foo" "bar" #t)) - (test (generate/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0)))) + (test (generate-term lang b 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0)))) + (test (generate-term lang c 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) + (test (generate-term lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(4 4 4 4 (4 4) (4 4))) - (test (exn:fail-message (generate lang e 5)) + (test (exn:fail-message (generate-term lang e 5)) #rx"generate: unable to generate pattern e") - (test (generate/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (test (generate-term lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) + (test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) '((0 0 0) (0 0 0 0) (1 1 1))) - (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) @@ -247,7 +264,7 @@ ;; x and y bound in body (test (let/ec k - (generate/decisions + (generate-term lc e 10 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) #:nt (patterns first first first third first) @@ -257,7 +274,7 @@ (let () (define-language lang (e (variable-prefix pf))) (test - (generate/decisions + (generate-term lang e 5 0 (decisions #:var (list (λ _ 'x)))) 'pfx)) @@ -271,7 +288,7 @@ (define-language lang (e number (e_1 e_2 e e_1 e_2))) (test - (generate/decisions + (generate-term lang e 5 0 (decisions #:nt (patterns second first first first) #:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) @@ -283,7 +300,7 @@ (x variable)) (test (let/ec k - (generate/decisions + (generate-term lang e 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x))) @@ -294,17 +311,17 @@ (b (c_!_1 c_!_1 c_!_1)) (c 1 2)) (test - (generate/decisions + (generate-term lang a 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) (test - (generate/decisions + (generate-term lang (number_!_1 number_!_2 number_!_1) 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) (test - (exn:fail-message (generate lang b 5000)) + (exn:fail-message (generate-term lang b 5000)) #rx"unable")) (let () @@ -313,7 +330,7 @@ (f foo bar)) (test (let/ec k - (generate/decisions + (generate-term lang e 5 0 (decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?)))))))) (cons '(#\a #\b #\f #\o #\r) @@ -327,28 +344,28 @@ (d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x) (e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x)))) (x variable)) - (test (generate lang b 5) 43) - (test (generate lang (side-condition a (odd? (term a))) 5) 43) - (test (exn:fail-message (generate lang c 5)) + (test (generate-term lang b 5) 43) + (test (generate-term lang (side-condition a (odd? (term a))) 5) 43) + (test (exn:fail-message (generate-term lang c 5)) #rx"unable to generate") (test ; binding works for with side-conditions failure/retry (let/ec k - (generate/decisions + (generate-term lang d 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))))) '(y)) (test ; mismatch patterns work with side-condition failure/retry - (generate/decisions + (generate-term lang e 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y)))) '(y x y)) (test ; generate compiles side-conditions in pattern - (generate/decisions lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 + (generate-term lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)))) 'y) (test ; bindings within ellipses collected properly (let/ec k - (generate/decisions lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 + (generate-term lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4)) #:num (build-list 7 (λ (n) (λ (_) n)))))) '((0 1 2) (3 4 5 6)))) @@ -360,9 +377,9 @@ (c (side-condition (name x d) (zero? (term x)))) (d 2 1 0) (e ((side-condition (name d_1 d) (zero? (term d_1))) d_1))) - (test (generate lang a 5) 4) - (test (generate lang c 5) 0) - (test (generate lang e 5) '(0 0))) + (test (generate-term lang a 5) 4) + (test (generate-term lang c 5) 0) + (test (generate-term lang e 5) '(0 0))) (let () (define-language lang @@ -380,28 +397,28 @@ (y variable)) (test - (generate/decisions + (generate-term lang (in-hole A number ) 5 0 (decisions #:nt (patterns second second first first third first second first first) #:num (build-list 5 (λ (x) (λ (_) x))))) '(+ (+ 1 2) (+ 0 (+ 3 4)))) - (test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) - (test (generate lang (hole 4) 5) (term (hole 4))) - (test (generate/decisions lang (variable_1 (in-hole C variable_1)) 5 0 + (test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) + (test (generate-term lang (hole 4) 5) (term (hole 4))) + (test (generate-term lang (variable_1 (in-hole C variable_1)) 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) '(x x)) - (test (generate/decisions lang (variable_!_1 (in-hole C variable_!_1)) 5 0 + (test (generate-term lang (variable_!_1 (in-hole C variable_!_1)) 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) '(x y)) - (test (let/ec k (generate/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) + (test (let/ec k (generate-term lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x)) - (test (generate/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) + (test (generate-term lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) '((2 (1 1)) 1)) - (test (generate/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) + (test (generate-term lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) '(1 0)) - (test (generate/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) + (test (generate-term lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) '((2 ((3 (2 1)) 3)) 1))) (let () @@ -409,7 +426,7 @@ (e (e e) (+ e e) x v) (v (λ (x) e) number) (x variable-not-otherwise-mentioned)) - (test (generate/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) + (test (generate-term lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) 'x)) (let () @@ -423,14 +440,14 @@ (list four 'f)) (test (call-with-values (λ () (pick-any four (make-random 1))) list) (list sexp 'sexp)) - (test (generate/decisions four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) - (test (generate/decisions four any 5 0 + (test (generate-term four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) + (test (generate-term four any 5 0 (decisions #:any (list (λ _ (values sexp 'sexp))) #:nt (patterns fifth second second second) #:seq (list (λ _ 3)) #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) '("foo" "bar" "baz")) - (test (generate/decisions empty any 5 0 (decisions #:nt (patterns first) + (test (generate-term empty any 5 0 (decisions #:nt (patterns first) #:var (list (λ _ 'x)))) 'x)) @@ -438,7 +455,7 @@ (let () (define-language lang (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) - (test (generate lang e 5) (term (hole 1)))) + (test (generate-term lang e 5) (term (hole 1)))) (define (output-error-port thunk) (let ([port (open-output-string)]) @@ -452,14 +469,11 @@ (e x (e e) v) (v (λ (x) e)) (x variable-not-otherwise-mentioned)) - (test (generate/decisions lang (cross e) 3 0 + (test (generate-term lang (cross e) 3 0 (decisions #:nt (patterns fourth first first second first first first) #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) -; preferred productions - - ;; current-error-port-output : (-> (-> any) string) (define (current-error-port-output thunk) (let ([p (open-output-string)]) @@ -521,6 +535,52 @@ ;; OK -- generated from pattern (any ...) (test (check-metafunction-contract i) #t)) +;; check-reduction-relation +(let () + (define-language L + (e (+ e ...) number) + (E (+ number ... E* e ...)) + (E* hole E*)) + (define R + (reduction-relation + L + (==> (+ number ...) whatever) + (--> (side-condition number (even? (term number))) whatever) + with + [(--> (in-hole E a) whatever) + (==> a b)])) + (let ([generated null]) + (test (begin + (check-reduction-relation + R (λ (term) (set! generated (cons term generated))) + #:decisions (decisions #:seq (list (λ _ 0) (λ _ 0) (λ _ 0)) + #:num (list (λ _ 1) (λ _ 1) (λ _ 0))) + #:attempts 1) + generated) + (reverse '((+ (+)) 0)))) + (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) + (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t) + (test (current-error-port-output + (λ () (check-reduction-relation S (λ (x) #f)))) + "checking name failed after 1 attempts:\n1\n") + (test (current-error-port-output + (λ () (check-reduction-relation S (curry eq? 1)))) + "checking unnamed failed after 1 attempts:\n3\n"))) + +; check-metafunction +(let () + (define-language empty) + (define-metafunction empty + [(m 1) whatever] + [(m 2) whatever]) + (let ([generated null]) + (test (begin + (check-metafunction m (λ (t) (set! generated (cons t generated))) 1) + generated) + (reverse '((1) (2))))) + (test (current-error-port-output (λ () (check-metafunction m (curry eq? 1)))) + #rx"checking clause #1 failed after 1 attempt")) + ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (define-language lang (x variable)) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 4131ea1eef..834700ce45 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -20,6 +20,7 @@ To do a better job of not generating programs with free variables, "underscore-allowed.ss" "term.ss" "error.ss" + "struct.ss" (for-syntax "rewrite-side-conditions.ss") (for-syntax "term-fn.ss") (for-syntax "reduction-semantics.ss") @@ -83,13 +84,16 @@ To do a better job of not generating programs with free variables, (define (pick-string lang-chars lang-lits attempt [random random]) (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) -(define ((pick-nt pref-prods) nt prods bound-vars attempt) - (let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] +(define ((pick-nt pref-prods [random random]) name lang bound-vars attempt) + (let* ([prods (nt-rhs (nt-by-name lang name))] + [binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] [do-intro-binder? (and (null? bound-vars) (not (null? binders)) (try-to-introduce-binder?))]) (cond [do-intro-binder? binders] - [(preferred-production? attempt) (list (hash-ref pref-prods nt))] + [(and (not (eq? lang sexp)) + (preferred-production? attempt random)) + (hash-ref pref-prods name)] [else prods]))) (define (pick-from-list l [random random]) (list-ref l (random (length l)))) @@ -155,7 +159,7 @@ To do a better job of not generating programs with free variables, [zip (λ (l m) (map cons l m))]) (map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) -(define (generate* lang pat decisions@) +(define (generate lang decisions@) (define-values/invoke-unit decisions@ (import) (export decisions^)) @@ -164,19 +168,16 @@ To do a better job of not generating programs with free variables, (define base-table (find-base-cases lang)) (define (generate-nt name fvt-id bound-vars size attempt in-hole state) - (let*-values - ([(nt) (findf (λ (nt) (eq? name (nt-name nt))) - (append (compiled-lang-lang lang) - (compiled-lang-cclang lang)))] - [(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] + (let*-values + ([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] [(term _) (generate/pred name (λ () (let ([rhs (pick-from-list (if (zero? size) - (min-prods nt base-table) - ((next-non-terminal-decision) name (nt-rhs nt) bound-vars attempt)))]) + (min-prods (nt-by-name lang name) base-table) + ((next-non-terminal-decision) name lang bound-vars attempt)))]) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())))) (λ (_ env) (mismatches-satisfied? env)))]) @@ -289,7 +290,7 @@ To do a better job of not generating programs with free variables, [`(hide-hole ,pattern) ((recur pattern the-hole) state)] [`any (let*-values ([(lang nt) ((next-any-decision) lang)] - [(term _) ((generate* lang nt decisions@) size attempt)]) + [(term _) (((generate lang decisions@) nt) size attempt)]) (values term state))] [(? (is-nt? lang)) (generate-nt pat pat bound-vars size attempt in-hole state)] @@ -355,15 +356,17 @@ To do a better job of not generating programs with free variables, (state-fvt state)) (state-env state))) - (λ (size attempt) - (let-values ([(term state) - (generate/pred - (unparse-pattern pat) - (λ () - (((generate-pat null size attempt) pat the-hole) - (make-state null #hash()))) - (λ (_ env) (mismatches-satisfied? env)))]) - (values term (bindings (state-env state)))))) + (λ (pat) + (let ([unparsed (unparse-pattern pat)]) + (λ (size attempt) + (let-values ([(term state) + (generate/pred + unparsed + (λ () + (((generate-pat null size attempt) pat the-hole) + (make-state null #hash()))) + (λ (_ env) (mismatches-satisfied? env)))]) + (values term (bindings (state-env state)))))))) ;; find-base-cases : compiled-language -> hash-table (define (find-base-cases lang) @@ -446,6 +449,12 @@ To do a better job of not generating programs with free variables, (define (built-in? x) (and (memq x underscore-allowed) #t)) +;; nt-by-name : lang symbol -> nt +(define (nt-by-name lang name) + (findf (λ (nt) (eq? name (nt-name nt))) + (append (compiled-lang-lang lang) + (compiled-lang-cclang lang)))) + (define named-nt-rx #rx"^([^_]+)_[^_]*$") (define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$") (define named-ellipsis-rx #rx"^\\.\\.\\._[^_]*$") @@ -591,7 +600,7 @@ To do a better job of not generating programs with free variables, [(struct ellipsis (name sub-pat class vars)) (make-ellipsis name (recur sub-pat) (rewrite class) (map (λ (v) (if (class? v) (rewrite v) v)) vars))] - [(? list?) (map (λ (p) (recur p)) pat)] + [(? list?) (map recur pat)] [_ pat])))) ;; used in generating the `any' pattern @@ -610,15 +619,16 @@ To do a better job of not generating programs with free variables, (with-syntax ([(name ...) names] [(name/ellipses ...) names/ellipses]) (syntax/loc stx - (check-property - (term-generator lang pat random-decisions) - (λ (_ bindings) - (with-handlers ([exn:fail? (λ (_) #f)]) - (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) - property))) - attempts))))])) + (or (check-property + (term-generator lang pat random-decisions) + (λ (_ bindings) + (with-handlers ([exn:fail? (λ (_) #f)]) + (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) + property))) + attempts) + (void)))))])) -(define (check-property generate property attempts) +(define (check-property generate property attempts [source #f]) (let loop ([remaining attempts]) (if (zero? remaining) #t @@ -628,23 +638,21 @@ To do a better job of not generating programs with free variables, (if (property term bindings) (loop (sub1 remaining)) (begin - (fprintf (current-error-port) - "failed after ~s attempts:\n" - attempt) - (pretty-print term (current-error-port))))))))) + (when source + (fprintf (current-error-port) "checking ~a " source)) + (fprintf (current-error-port) "failed after ~s attempts:\n" attempt) + (pretty-print term (current-error-port)) + #f))))))) -(define-syntax generate +(define-syntax generate-term (syntax-rules () - [(_ lang pat size attempt) - (let-values ([(term _) ((term-generator lang pat random-decisions) size attempt)]) + [(_ lang pat size attempt decisions) + (let-values ([(term _) ((term-generator lang pat decisions) size attempt)]) term)] - [(_ lang pat size) (generate lang pat size 0)])) - -(define-syntax generate/decisions - (syntax-rules () - [(_ lang pat size attempt decisions@) - (let-values ([(term _) ((term-generator lang pat decisions@) size attempt)]) - term)])) + [(_ lang pat size attempt) + (generate-term lang pat size attempt random-decisions)] + [(_ lang pat size) + (generate-term lang pat size 1)])) (define-syntax (term-generator stx) (syntax-case stx () @@ -655,10 +663,14 @@ To do a better job of not generating programs with free variables, 'generate #t #'pat)]) (syntax/loc stx (let ([lang (parse-language lang)]) - (generate* - lang - (reassign-classes (parse-pattern `pattern lang 'top-level)) - (decisions lang)))))])) + ((generate lang (decisions lang)) + (reassign-classes (parse-pattern `pattern lang 'top-level))))))])) + +(define-for-syntax (metafunc name stx) + (let ([tf (syntax-local-value name (λ () #f))]) + (if (term-fn? tf) + (term-fn-get-id tf) + (raise-syntax-error #f "not a metafunction" stx name)))) (define-syntax (check-metafunction-contract stx) (syntax-case stx () @@ -666,22 +678,64 @@ To do a better job of not generating programs with free variables, (syntax/loc stx (check-metafunction-contract name random-decisions))] [(_ name decisions) (identifier? #'name) - (with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))]) - (if (term-fn? tf) - (term-fn-get-id tf) - (raise-syntax-error #f "not a metafunction" stx #'name)))]) + (with-syntax ([m (metafunc #'name stx)]) (syntax/loc stx (let ([lang (parse-language (metafunc-proc-lang m))] [dom (metafunc-proc-dom-pat m)]) (check-property - (generate* lang - (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)) - (decisions lang)) + ((generate lang (decisions lang)) + (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level))) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) (begin (term (name ,@t)) #t))) default-check-attempts))))])) +(define (check-property-many lang patterns ids prop decisions attempts) + (let* ([lang-gen (generate lang (decisions lang))] + [pat-gens (map (λ (pat) (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))) + patterns)]) + (for/and ([pat patterns] + [id ids]) + (check-property + (let ([gen (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))]) + (λ (size attempt) (gen size attempt))) + (λ (term _) (prop term)) + attempts + id)))) + +(define-syntax (check-metafunction stx) + (syntax-case stx () + [(_ name property) + (syntax/loc stx (check-metafunction name property default-check-attempts))] + [(_ name property attempts) + (syntax/loc stx (check-metafunction name property random-decisions attempts))] + [(_ name property decisions attempts) + (with-syntax ([m (metafunc #'name stx)]) + (syntax/loc stx + (or (check-property-many + (parse-language (metafunc-proc-lang m)) + (metafunc-proc-lhs-pats m) + (build-list (length (metafunc-proc-lhs-pats m)) + (compose (curry format "clause #~s") add1)) + property + decisions + attempts) + (void))))])) + +(define (check-reduction-relation + relation property + #:decisions [decisions random-decisions] + #:attempts [attempts default-check-attempts]) + (or (check-property-many + (parse-language (reduction-relation-lang relation)) + (map rewrite-proc-lhs (reduction-relation-make-procs relation)) + (map (λ (proc) (or (rewrite-proc-name proc) 'unnamed)) + (reduction-relation-make-procs relation)) + property + decisions + attempts) + (void))) + (define-signature decisions^ (next-variable-decision next-number-decision @@ -693,7 +747,7 @@ To do a better job of not generating programs with free variables, (define (random-decisions lang) (define preferred-productions (make-immutable-hasheq - (map (λ (nt) (cons (nt-name nt) (pick-from-list (nt-rhs nt)))) + (map (λ (nt) (cons (nt-name nt) (list (pick-from-list (nt-rhs nt))))) (append (compiled-lang-lang lang) (compiled-lang-cclang lang))))) (unit (import) (export decisions^) @@ -705,12 +759,13 @@ To do a better job of not generating programs with free variables, (define (next-string-decision) pick-string))) (provide pick-from-list pick-var min-prods decisions^ pick-sequence-length - is-nt? pick-char random-string pick-string check - pick-nt unique-chars pick-any sexp generate parse-pattern + is-nt? pick-char random-string pick-string check nt-by-name + pick-nt unique-chars pick-any sexp generate-term parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder) generate/decisions check-metafunction-contract - pick-number parse-language) + (struct-out binder) check-metafunction-contract + pick-number parse-language check-reduction-relation + preferred-production-threshold check-metafunction) (provide/contract [find-base-cases (-> compiled-lang? hash?)]) \ No newline at end of file diff --git a/collects/redex/private/struct.ss b/collects/redex/private/struct.ss index 794a3d1efe..27cba96f84 100644 --- a/collects/redex/private/struct.ss +++ b/collects/redex/private/struct.ss @@ -9,7 +9,7 @@ build-reduction-relation reduction-relation? empty-reduction-relation - make-rewrite-proc rewrite-proc? rewrite-proc-name + make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs (struct-out rule-pict)) (define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds)) @@ -20,13 +20,14 @@ ;; we want to avoid doing it multiple times, so it is cached in a reduction-relation struct -(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name) +(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs) (let () (define-values (type constructor predicate accessor mutator) - (make-struct-type 'rewrite-proc #f 2 0 #f '() #f 0)) + (make-struct-type 'rewrite-proc #f 3 0 #f '() #f 0)) (values constructor predicate - (make-struct-field-accessor accessor 1 'name)))) + (make-struct-field-accessor accessor 1 'name) + (make-struct-field-accessor accessor 2 'lhs)))) ;; lang : compiled-language ;; make-procs = (listof (compiled-lang -> proc)) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index a41fd809d0..db8b0ea187 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -1,6 +1,9 @@ (module tl-test mzscheme (require "../reduction-semantics.ss" - "test-util.ss") + "test-util.ss" + (only "matcher.ss" make-bindings make-bind) + scheme/match + "struct.ss") (reset-count) @@ -537,6 +540,19 @@ (list '((2 3) 20) '(6 (4 5)))) + ; shortcuts like this fail if compilation fails to preserve + ; lexical context for side-conditions expressions. + (test (let ([x #t]) + (apply-reduction-relation + (reduction-relation + grammar + (==> variable variable) + with + [(--> (a (side-condition number x)) b) + (==> a b)]) + '(x 4))) + '(x)) + (test (apply-reduction-relation/tag-with-names (reduction-relation grammar @@ -1099,4 +1115,48 @@ 'x) '(x1)) + (let ([r (reduction-relation + grammar + (->1 1 2) + (->2 3 4) + (->4 5 6) + with + [(--> (side-condition (a number) (even? (term number))) b) + (->1 a b)] + [(--> (X + (number number) + (X_1 X_1) + (M_!_1 M_!_1) + (1 ..._1 1 ..._1) + (1 ..._!_1 1 ..._!_1)) + b) + (->2 X b)] + [(--> (a 1) b) + (->3 a b)] + [(->3 (a 2) b) + (->4 a b)])]) + + ; test that names are properly bound for side-conditions in shortcuts + (let* ([lhs (rewrite-proc-lhs (first (reduction-relation-make-procs r)))] + [proc (third lhs)] + [name (cadadr lhs)] + [bind (λ (n) (make-bindings (list (make-bind name n))))]) + (test (and (proc (bind 4)) (not (proc (bind 3)))) #t)) + + ; test binder renaming + (let ([sym-mtch? (λ (rx) (λ (s) (and (symbol? s) (regexp-match? rx (symbol->string s)))))]) + (match (rewrite-proc-lhs (second (reduction-relation-make-procs r))) + [`(3 + (,(and n1 (? (sym-mtch? #px"^number_\\d+$"))) ,n1) + (,(and n2 (? (sym-mtch? #px"^X_1\\d+$"))) ,n2) + (,(and m1 (? (sym-mtch? #px"^M_!_1\\d+$"))) ,m1) + (1 ,(and ...1 (? (sym-mtch? #px"^\\.\\.\\._1\\d+$"))) 1 ,...1) + (1 ,(and ...!1 (? (sym-mtch? #px"^\\.\\.\\._!_1\\d+$"))) 1 ,...!1)) + #t] + [else #f])) + + ; test shortcut in terms of shortcut + (test (rewrite-proc-lhs (third (reduction-relation-make-procs r))) + '((5 2) 1))) + (print-tests-passed 'tl-test.ss)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 4bc7e7e213..360da14277 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -450,6 +450,12 @@ recursively matches the corresponding list element. There may be a single ellipsis in any list pattern; if one is present, the pattern before the ellipses may match multiple adjacent elements in the list value (possibly none). + +This form is a lower-level form in Redex, and not really designed to +be used directly. If you want a @scheme[let]-like form that uses +Redex's full pattern matching facilities, see @scheme[term-match] and +@scheme[term-match/single]. + } @defform[(term-match language [#, @|ttpattern| expression] ...)]{ @@ -460,6 +466,10 @@ function returns a list of the values of the expression where the pattern matches. If one of the patterns matches multiple times, the expression is evaluated multiple times, once with the bindings in the pattern for each match. + +When evaluating a @scheme[term-match] expression, the patterns are +compiled in an effort to speed up matching. Using the procedural +result multiple times to avoid compiling the patterns multiple times. } @defform[(term-match/single language [#, @|ttpattern| expression] ...)]{ @@ -472,6 +482,10 @@ is signaled. If no patterns match, an error is signaled. Raises an exception recognized by @scheme[exn:fail:redex?] if no clauses match or if one of the clauses matches multiple ways. + +When evaluating a @scheme[term-match/single] expression, the patterns +are compiled in an effort to speed up matching. Using the procedural +result multiple times to avoid compiling the patterns multiple times. } @defproc[(plug [context any?] [expression any?]) any]{ diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 9d390fdea7..801092bb94 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22dec2008") +#lang scheme/base (provide stamp) (define stamp "2jan2009") diff --git a/collects/rnrs/arithmetic/fixnums-6.ss b/collects/rnrs/arithmetic/fixnums-6.ss index fc18f106b2..31582279c4 100644 --- a/collects/rnrs/arithmetic/fixnums-6.ss +++ b/collects/rnrs/arithmetic/fixnums-6.ss @@ -62,16 +62,20 @@ (raise-type-error 'fxdiv-and-mod "fixnum" a)) (unless (fixnum? b) (raise-type-error 'fxdiv-and-mod "fixnum" b)) - (div-and-mod a b)) -(define-fx div fxdiv (a b) nocheck) + (let-values ([(d m) (div-and-mod a b)]) + (check d (implementation-restriction 'div-and-mod d)) + (values d m))) +(define-fx div fxdiv (a b) check) (define-fx mod fxmod (a b) nocheck) (define (fxdiv0-and-mod0 a b) (unless (fixnum? a) (raise-type-error 'fxdiv0-and-mod0 "fixnum" a)) (unless (fixnum? b) (raise-type-error 'fxdiv0-and-mod0 "fixnum" b)) - (div0-and-mod0 a b)) -(define-fx div0 fxdiv0 (a b) nocheck) + (let-values ([(d m) (div0-and-mod0 a b)]) + (check d (implementation-restriction 'div0-and-mod0 d)) + (values d m))) +(define-fx div0 fxdiv0 (a b) check) (define-fx mod0 fxmod0 (a b) nocheck) (define-syntax-rule (define-carry fx/carry (a b c) expr) diff --git a/collects/scheme/gui/dynamic.ss b/collects/scheme/gui/dynamic.ss index 08a259f8c2..9340639133 100644 --- a/collects/scheme/gui/dynamic.ss +++ b/collects/scheme/gui/dynamic.ss @@ -4,9 +4,10 @@ gui-dynamic-require) (define (gui-available?) - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (eq? (dynamic-require 'mred/private/dynamic 'kernel-initialized) - 'done))) + (and (zero? (variable-reference->phase (#%variable-reference))) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (eq? (dynamic-require 'mred/private/dynamic 'kernel-initialized) + 'done)))) (define-namespace-anchor anchor) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index 550faf8f3b..430b7bafd1 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -22,6 +22,9 @@ filter-map partition + argmin + argmax + ;; convenience append-map filter-not) @@ -278,3 +281,33 @@ (if (null? l) (reverse result) (loop (cdr l) (if (f (car l)) result (cons (car l) result)))))) + + +;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X +(define (mk-min cmp name f xs) + (unless (and (procedure? f) + (procedure-arity-includes? f 1)) + (raise-type-error name "procedure (arity 1)" f)) + (unless (and (list? xs) + (pair? xs)) + (raise-type-error name "non-empty list" xs)) + (let ([init-min-var (f (car xs))]) + (unless (real? init-min-var) + (raise-type-error name "procedure that returns real numbers" f)) + (let loop ([min (car xs)] + [min-var init-min-var] + [xs (cdr xs)]) + (cond + [(null? xs) min] + [else + (let ([new-min (f (car xs))]) + (unless (real? new-min) + (raise-type-error name "procedure that returns real numbers" f)) + (cond + [(cmp new-min min-var) + (loop (car xs) new-min (cdr xs))] + [else + (loop min min-var (cdr xs))]))])))) + +(define (argmin f xs) (mk-min < 'argmin f xs)) +(define (argmax f xs) (mk-min > 'argmax f xs)) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 47b5746e5a..3b92501f73 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -29,8 +29,8 @@ define-serializable-class define-serializable-class* class? mixin - interface interface? - object% object? externalizable<%> printable<%> + interface interface* interface? + object% object? externalizable<%> printable<%> equal<%> object=? new make-object instantiate send send/apply send* class-field-accessor class-field-mutator with-method @@ -2008,7 +2008,7 @@ [method-names (append (reverse public-names) super-method-ids)] [field-names (append public-field-names super-field-ids)] [super-interfaces (cons (class-self-interface super) interfaces)] - [i (interface-make name super-interfaces #f method-names #f)] + [i (interface-make name super-interfaces #f method-names #f null)] [methods (if no-method-changes? (class-methods super) (make-vector method-width))] @@ -2050,7 +2050,7 @@ ;; --- Make the new object struct --- (let*-values ([(prim-object-make prim-object? struct:prim-object) (if make-struct:prim - (make-struct:prim c prop:object preparer dispatcher) + (make-struct:prim c prop:object preparer dispatcher (get-properties interfaces)) (values #f #f #f))] [(struct:object object-make object? object-field-ref object-field-set!) (if make-struct:prim @@ -2058,21 +2058,14 @@ (values struct:prim-object prim-object-make prim-object? #f #f) ;; Normal struct creation: (make-struct-type obj-name - (class-struct:object super) + (add-properties (class-struct:object super) interfaces) 0 ;; No init fields ;; Fields for new slots: num-fields undefined ;; Map object property to class: (append (list (cons prop:object c)) - (if (interface-extension? i printable<%>) - (list (cons prop:custom-write - (lambda (obj port write?) - (if write? - (send obj custom-write port) - (send obj custom-display port))))) - null) - (if deserialize-id + (if deserialize-id (list (cons prop:serializable ;; Serialization: @@ -2329,6 +2322,33 @@ (for-class name)))) syms))) + (define (get-properties intfs) + (if (ormap (lambda (i) + (pair? (interface-properties i))) + intfs) + (let ([ht (make-hash)]) + ;; Hash on gensym to avoid providing the same property multiple + ;; times when it originated from a single interface. + (for-each (lambda (i) + (for-each (lambda (p) + (hash-set! ht (vector-ref p 0) p)) + (interface-properties i))) + intfs) + (hash-map ht (lambda (k v) (cons (vector-ref v 1) + (vector-ref v 2))))) + ;; No properties to add: + null)) + + (define (add-properties struct-type intfs) + (let ([props (get-properties intfs)]) + (if (null? props) + struct-type + ;; Create a new structure type to house the properties, so + ;; that they can't see any fields directly via guards: + (let-values ([(struct: make- ? -ref -set!) + (make-struct-type 'props struct-type 0 0 #f props #f)]) + struct:)))) + (define-values (prop:object object? object-ref) (make-struct-type-property 'object)) ;;-------------------------------------------------------------------- @@ -2337,10 +2357,10 @@ ;; >> Simplistic implementation for now << - (define-syntax _interface - (lambda (stx) - (syntax-case stx () - [(_ (interface-expr ...) var ...) + (define-for-syntax do-interface + (lambda (stx m-stx) + (syntax-case m-stx () + [((interface-expr ...) ([prop prop-val] ...) var ...) (let ([vars (syntax->list (syntax (var ...)))] [name (syntax-local-infer-name stx)]) (for-each @@ -2364,7 +2384,33 @@ (compose-interface 'name (list interface-expr ...) - `(var ...)))))]))) + `(var ...) + (list prop ...) + (list prop-val ...)))))]))) + + (define-syntax (_interface stx) + (syntax-case stx () + [(_ (interface-expr ...) var ...) + (do-interface stx #'((interface-expr ...) () var ...))])) + + (define-syntax (interface* stx) + (syntax-case stx () + [(_ (interface-expr ...) ([prop prop-val] ...) var ...) + (do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))] + [(_ (interface-expr ...) (prop+val ...) var ...) + (for-each (lambda (p+v) + (syntax-case p+v () + [(p v) (void)] + [_ (raise-syntax-error #f + "expected `[ ]'" + stx + p+v)])) + (syntax->list #'(prop+val ...)))] + [(_ (interface-expr ...) prop+vals . _) + (raise-syntax-error #f + "expected `([ ] ...)'" + stx + #'prop+vals)])) (define-struct interface (name ; symbol @@ -2373,18 +2419,27 @@ #:mutable] public-ids ; (listof symbol) (in any order?!?) [class ; (union #f class) -- means that anything implementing - #:mutable]) ; this interface must be derived from this class + #:mutable] ; this interface must be derived from this class + properties) ; (listof (vector gensym prop val)) #:inspector insp) - (define (compose-interface name supers vars) + (define (compose-interface name supers vars props vals) (for-each (lambda (intf) (unless (interface? intf) (obj-error 'interface - "superinterface expression returned a non-interface: ~a~a" + "superinterface expression returned a non-interface: ~e~a" intf (for-intf name)))) supers) + (for-each + (lambda (p) + (unless (struct-type-property? p) + (obj-error 'interface + "property expression returned a non-property: ~e~a" + p + (for-intf name)))) + props) (let ([ht (make-hasheq)]) (for-each (lambda (var) @@ -2405,24 +2460,38 @@ ""))))) (interface-public-ids super))) supers) - ;; Check for [conflicting] implementation requirements - (let ([class (get-implement-requirement supers 'interface (for-intf name))] - [interface-make (if name - (make-naming-constructor - struct:interface - (string->symbol (format "interface:~a" name))) - make-interface)]) - ;; Add supervars to table: - (for-each - (lambda (super) - (for-each - (lambda (var) (hash-set! ht var #t)) - (interface-public-ids super))) - supers) - ;; Done - (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class)]) - (setup-all-implemented! i) - i)))) + ;; Merge properties: + (let ([prop-ht (make-hash)]) + ;; Hash on gensym to avoid providing the same property multiple + ;; times when it originated from a single interface. + (for-each (lambda (i) + (for-each (lambda (p) + (hash-set! prop-ht (vector-ref p 0) p)) + (interface-properties i))) + supers) + (for-each (lambda (p v) + (let ([g (gensym)]) + (hash-set! prop-ht g (vector g p v)))) + props vals) + ;; Check for [conflicting] implementation requirements + (let ([class (get-implement-requirement supers 'interface (for-intf name))] + [interface-make (if name + (make-naming-constructor + struct:interface + (string->symbol (format "interface:~a" name))) + make-interface)]) + ;; Add supervars to table: + (for-each + (lambda (super) + (for-each + (lambda (var) (hash-set! ht var #t)) + (interface-public-ids super))) + supers) + ;; Done + (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class + (hash-map prop-ht (lambda (k v) v)))]) + (setup-all-implemented! i) + i))))) ;; setup-all-implemented! : interface -> void ;; Creates the hash table for all implemented interfaces @@ -2466,7 +2535,7 @@ make-)) (define object<%> ((make-naming-constructor struct:interface 'interface:object%) - 'object% null #f null #f)) + 'object% null #f null #f null)) (setup-all-implemented! object<%>) (define object% ((make-naming-constructor struct:class 'class:object%) 'object% @@ -3362,6 +3431,7 @@ prim-init ; primitive initializer: takes obj and list of name-arg pairs name ; symbol super ; superclass + intfs ; interfaces init-arg-names ; #f or list of syms and sym--value lists override-names ; overridden method names new-names ; new (public) method names @@ -3369,7 +3439,7 @@ new-methods) ; list of methods ; The `make-struct:prim' function takes prop:object, a - ; class, a preparer, and a dispatcher function, and produces: + ; class, a preparer, a dispatcher function, and a property assoc list, and produces: ; * a struct constructor (must have prop:object) ; * a struct predicate ; * a struct type for derived classes (mustn't have prop:object) @@ -3384,7 +3454,7 @@ (compose-class name (or super object%) - null + intfs #f #f #f @@ -3726,7 +3796,23 @@ (_interface () externalize internalize)) (define printable<%> - (_interface () custom-write custom-display)) + (interface* () + ([prop:custom-write (lambda (obj port write?) + (if write? + (send obj custom-write port) + (send obj custom-display port)))]) + custom-write custom-display)) + + (define equal<%> + (interface* () + ([prop:equal+hash (list + (lambda (obj obj2 base-equal?) + (send obj equal-to? obj2 base-equal?)) + (lambda (obj base-hash-code) + (send obj equal-hash-code-of base-hash-code)) + (lambda (obj base-hash2-code) + (send obj equal-secondary-hash-code-of base-hash2-code)))]) + equal-to? equal-hash-code-of equal-secondary-hash-code-of)) ;; Providing traced versions: (provide class-traced @@ -3768,8 +3854,8 @@ define-serializable-class define-serializable-class* class? mixin - (rename-out [_interface interface]) interface? - object% object? object=? externalizable<%> printable<%> + (rename-out [_interface interface]) interface* interface? + object% object? object=? externalizable<%> printable<%> equal<%> new make-object instantiate get-field field-bound? field-names send send/apply send* class-field-accessor class-field-mutator with-method diff --git a/collects/scheme/private/more-scheme.ss b/collects/scheme/private/more-scheme.ss index 66aa55ca94..35f3f25886 100644 --- a/collects/scheme/private/more-scheme.ss +++ b/collects/scheme/private/more-scheme.ss @@ -210,6 +210,35 @@ (define handler-prompt-key (make-continuation-prompt-tag)) + (define (call-handled-body bpz handle-proc body-thunk) + ;; Disable breaks here, so that when the exception handler jumps + ;; to run a handler, breaks are disabled for the handler + (with-continuation-mark + break-enabled-key + false-thread-cell + (call-with-continuation-prompt + (lambda (bpz body-thunk) + ;; Restore the captured break parameterization for + ;; evaluating the `with-handlers' body. In this + ;; special case, no check for breaks is needed, + ;; because bpz is quickly restored past call/ec. + ;; Thus, `with-handlers' can evaluate its body in + ;; tail position. + (with-continuation-mark + break-enabled-key + bpz + (with-continuation-mark + exception-handler-key + (lambda (e) + ;; Deliver the exception to the escape handler: + (abort-current-continuation + handler-prompt-key + e)) + (body-thunk)))) + handler-prompt-key + handle-proc + bpz body-thunk))) + (define-syntaxes (with-handlers with-handlers*) (let ([wh (lambda (disable-break?) @@ -222,44 +251,21 @@ [(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler) (syntax->list #'(handler ...))))]) (quasisyntax/loc stx - (let ([pred-name pred] ... - [handler-name handler] ...) - ;; Capture current break parameterization, so we can use it to - ;; evaluate the body - (let ([bpz (continuation-mark-set-first #f break-enabled-key)]) - ;; Disable breaks here, so that when the exception handler jumps - ;; to run a handler, breaks are disabled for the handler - (with-continuation-mark - break-enabled-key - false-thread-cell - (call-with-continuation-prompt - (lambda () - ;; Restore the captured break parameterization for - ;; evaluating the `with-handlers' body. In this - ;; special case, no check for breaks is needed, - ;; because bpz is quickly restored past call/ec. - ;; Thus, `with-handlers' can evaluate its body in - ;; tail position. - (with-continuation-mark - break-enabled-key - bpz - (with-continuation-mark - exception-handler-key - (lambda (e) - ;; Deliver a thunk to the escape handler: - (abort-current-continuation - handler-prompt-key - (lambda () - (#,(if disable-break? - #'select-handler/no-breaks - #'select-handler/breaks-as-is) - e bpz - (list (cons pred-name handler-name) ...))))) - (let () - expr1 expr ...)))) - handler-prompt-key - ;; On escape, apply the handler thunk - (lambda (thunk) (thunk))))))))])))]) + (let-values ([(pred-name) pred] ... + [(handler-name) handler] ...) + ;; Capture current break parameterization, so we can use it to + ;; evaluate the body + (let ([bpz (continuation-mark-set-first #f break-enabled-key)]) + (call-handled-body + bpz + (lambda (e) + (#,(if disable-break? + #'select-handler/no-breaks + #'select-handler/breaks-as-is) + e bpz + (list (cons pred-name handler-name) ...))) + (lambda () + expr1 expr ...))))))])))]) (values (wh #t) (wh #f)))) (define (call-with-exception-handler exnh thunk) diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss index 1cbaeaedf0..110aa0fc30 100644 --- a/collects/scribble/private/manual-proc.ss +++ b/collects/scribble/private/manual-proc.ss @@ -486,29 +486,33 @@ (define-syntax defstruct (syntax-rules () [(_ name fields #:mutable #:inspector #f desc ...) - (**defstruct name fields #f #t desc ...)] + (**defstruct name fields #f #t #f desc ...)] [(_ name fields #:mutable #:transparent desc ...) - (**defstruct name fields #f #t desc ...)] + (**defstruct name fields #f #t #f desc ...)] + [(_ name fields #:mutable #:prefab desc ...) + (**defstruct name fields #f #t #t desc ...)] [(_ name fields #:mutable desc ...) - (**defstruct name fields #f #f desc ...)] + (**defstruct name fields #f #f #f desc ...)] [(_ name fields #:inspector #f desc ...) - (**defstruct name fields #t #t desc ...)] + (**defstruct name fields #t #t #f desc ...)] [(_ name fields #:transparent desc ...) - (**defstruct name fields #t #t desc ...)] + (**defstruct name fields #t #t #f desc ...)] + [(_ name fields #:prefab desc ...) + (**defstruct name fields #t #t #t desc ...)] [(_ name fields desc ...) - (**defstruct name fields #t #f desc ...)])) + (**defstruct name fields #t #f #f desc ...)])) (define-syntax-rule (**defstruct name ([field field-contract] ...) immutable? - transparent? desc ...) + transparent? prefab? desc ...) (with-togetherable-scheme-variables () () (*defstruct (quote-syntax/loc name) 'name '([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...) - immutable? transparent? (lambda () (list desc ...))))) + immutable? transparent? prefab? (lambda () (list desc ...))))) -(define (*defstruct stx-id name fields field-contracts immutable? transparent? +(define (*defstruct stx-id name fields field-contracts immutable? transparent? prefab? content-thunk) (define (field-name f) ((if (pair? (car f)) caar car) f)) (define (field-view f) @@ -634,7 +638,9 @@ (list flow-spacer flow-spacer (to-flow (make-element #f - (list (to-element '#:transparent) + (list (if prefab? + (to-element '#:prefab) + (to-element '#:transparent)) (schemeparenfont ")")))) 'cont 'cont))] @@ -652,7 +658,9 @@ (list flow-spacer flow-spacer (to-flow (make-element #f - (list (to-element '#:transparent) + (list (if prefab? + (to-element '#:prefab) + (to-element '#:transparent)) (schemeparenfont ")")))) 'cont 'cont))] diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 595968b27e..44975a2e96 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -282,7 +282,9 @@ PLT Scheme's C API.} Similar to @scheme[_pointer], except that when an @scheme[_fpointer] is extracted from a pointer produced by @scheme[ffi-obj-ref], then a level of indirection is skipped. A level of indirection is similarly -skipped when extracting a pointer via @scheme[get-ffi-obj]. +skipped when extracting a pointer via @scheme[get-ffi-obj]. Also +unlike @scheme[_pointer], @scheme[_fpointer] does not convert +@scheme[#f] to @cpp{NULL}. A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], and normally @scheme[_cprocedure] should be used instead of @@ -439,9 +441,11 @@ For example, specifies a function that receives an integer and a string, but the foreign function receives the string first.} -@defproc[(function-ptr [ptr cpointer?] [fun-type ctype?]) cpointer?]{ +@defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)] + [fun-type ctype?]) + cpointer?]{ -Casts @scheme[ptr] to a function pointer of type @scheme[fun-type].} +Casts @scheme[ptr-or-proc] to a function pointer of type @scheme[fun-type].} @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/gui/image-snip-class.scrbl b/collects/scribblings/gui/image-snip-class.scrbl index ec80f69cca..d8cc0cf367 100644 --- a/collects/scribblings/gui/image-snip-class.scrbl +++ b/collects/scribblings/gui/image-snip-class.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "common.ss") -@defclass/title[image-snip% snip% ()]{ +@defclass/title[image-snip% snip% (equal<%>)]{ An @scheme[image-snip%] is a snip that can display bitmap images (usually loaded from a file). When the image file cannot be found, a @@ -24,6 +24,38 @@ Creates an image snip, loading the image @scheme[filename] if } + +@defmethod[(equal-hash-code [hash-code (any/c . -> . exact-integer?)]) + exact-integer?]{ + +Returns an integer that can be used as a @scheme[equal?]-based hash +code for @this-obj[] (using the same notion of @scheme[equal?] as +@method[image-snip% other-equal-to?]). + +See also @scheme[equal<%>].} + +@defmethod[(equal-secondary-hash-code [hash-code (any/c . -> . exact-integer?)]) + exact-integer?]{ + +Returns an integer that can be used as a @scheme[equal?]-based +secondary hash code for @this-obj[] (using the same notion of +@scheme[equal?] as @method[image-snip% other-equal-to?]). + +See also @scheme[equal<%>].} + + +@defmethod[(equal-to? [snip (is-a?/c image-snip%)] + [equal? (any/c any/c . -> . boolean?)]) + boolean?]{ + +Calls the @method[image-snip% other-equal-to?] method of @scheme[snip] +(to simulate multi-method dispatch) in case @scheme[snip] provides a +more specific equivalence comparison. + +See also @scheme[equal<%>].} + + + @defmethod[(get-bitmap) (or/c (is-a?/c bitmap%) false/c)]{ @@ -105,6 +137,20 @@ If @scheme[inline?] is not @scheme[#f], the image data will be saved } +@defmethod[(other-equal-to? [snip (is-a?/c image-snip%)] + [equal? (any/c any/c . -> . boolean?)]) + boolean?]{ + +Returns @scheme[#t] if @this-obj[] and @scheme[snip] both have bitmaps +and the bitmaps are the same dimensions. If either has a mask bitmap +with the same dimensions as the main bitmap, then the masks must be +the same (or if only one mask is present, it must correspond to a +solid mask). + +The given @scheme[equal?] function (for recursive comparisons) is not +used.} + + @defmethod[#:mode override (resize [w (and/c real? (not/c negative?))] [h (and/c real? (not/c negative?))]) diff --git a/collects/scribblings/guide/case.scrbl b/collects/scribblings/guide/case.scrbl index f38d4dd149..b0e26f8198 100644 --- a/collects/scribblings/guide/case.scrbl +++ b/collects/scribblings/guide/case.scrbl @@ -4,7 +4,7 @@ "guide-utils.ss" (for-label scheme/match)) -@title{Simple Dispatch: @scheme[case]} +@title[#:tag "case"]{Simple Dispatch: @scheme[case]} The @scheme[case] form dispatches to a clause by matching the result of an expression to the values for the clause: diff --git a/collects/scribblings/guide/forms.scrbl b/collects/scribblings/guide/forms.scrbl index 6d82094f9f..50a981099d 100644 --- a/collects/scribblings/guide/forms.scrbl +++ b/collects/scribblings/guide/forms.scrbl @@ -90,3 +90,4 @@ form, a @scheme[_thing] is either an identifier or a keyword. @include-section["quote.scrbl"] @include-section["qq.scrbl"] @include-section["case.scrbl"] +@include-section["parameterize.scrbl"] diff --git a/collects/scribblings/guide/parameterize.scrbl b/collects/scribblings/guide/parameterize.scrbl new file mode 100644 index 0000000000..8099f64beb --- /dev/null +++ b/collects/scribblings/guide/parameterize.scrbl @@ -0,0 +1,67 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "guide-utils.ss") + +@title[#:tag "parameterize"]{Dynamic Binding: @scheme[parameterize]} + +The @scheme[parameterize] form supports a kind of dynamic binding that +is useful for adjusting defaults or passing extra arguments through +layers of function calls. The settings that are adjusted by a +@scheme[parameterize] form are called @deftech{parameters}. + +@margin-note{The term ``parameter'' is sometimes used to refer to the + arguments of a function, but ``parameter'' in PLT Scheme + has the more specific meaning described here.} + +@specform[(parameterize ([parameter-expr value-expr] ...) + body ...+)] + +The result of a @scheme[parameterize] form is the result of the last +@scheme[_body] expression. While the @scheme[_body] expressions are +evaluated, the parameter produced by each @scheme[_parameter-expr] is +set to the result of the corresponding @scheme[_value-expr]. + +Many parameters are built in. For example, the +@scheme[error-print-width] parameter controls how many characters of a +value are printed in an error message (in case the printed form of the +value is very large): + +@interaction[ +(parameterize ([error-print-width 10]) + (car (expt 10 1024))) +(parameterize ([error-print-width 5]) + (car (expt 10 1024))) +] + +The @scheme[error-print-width] parameter acts like a kind of default +argument to the function that formats error messages. This +parameter-based argument can be configured far from the actual call to +the error-formatting function, which in this case is called deep +within the implementation of @scheme[car]. + +The @scheme[parameterize] form adjusts the value of a parameter only +while evaluating its body expressions. After the body produces a +value, the parameter reverts to its previous value. If control escapes +from the body due to an exception, as in the above example, then the +parameter value is restored in that case, too. Finally, parameter +values are thread-specific, so that multiple threads do not interfere +with each others' settings. + +Use @scheme[make-parameter] to create a new parameter that works with +@scheme[parameterize]. The argument to @scheme[make-parameter] is the +value of the parameter when it is not otherwise set by +@scheme[parameterize]. To access the current value of the parameter, +call it like a function. + +@interaction[ +(define favorite-flavor (make-parameter 'chocolate)) +(favorite-flavor) +(define (scoop) + `(scoop of ,(favorite-flavor))) +(define (ice-cream n) + (list (scoop) (scoop) (scoop))) +(parameterize ([favorite-flavor 'strawberry]) + (ice-cream 3)) +(ice-cream 3) +] diff --git a/collects/scribblings/more/more.scrbl b/collects/scribblings/more/more.scrbl index b1766264a1..f34735388b 100644 --- a/collects/scribblings/more/more.scrbl +++ b/collects/scribblings/more/more.scrbl @@ -4,6 +4,7 @@ scribble/eval "../quick/keep.ss" (for-label scheme + scheme/enter readline net/url xml @@ -422,7 +423,7 @@ To parse the incoming URL and to more easily format HTML output, we'll require two extra libraries: @schemeblock[ -(require net/url xml) +(require xml net/url) ] The @schememodname[xml] library gives us @scheme[xexpr->string], which @@ -582,15 +583,12 @@ connection. Inside @scheme[accept-and-handle], after the definition of @whole-prog["7"] -We're assuming that 50MB should be plenty for any servlet. Due to the -way that memory accounting is defined, @scheme[cust] might also be -charged for the core server implementation and all of the libraries -loaded on start-up, so the limit cannot be too small. Also, -garbage-collector overhead means that the actual memory use of the -system can be some small multiple of 50 MB. An important guarantee, -however, is that different connections will not be charged for each -other's memory use, so one misbehaving connection will not interfere -with a different one. +We're assuming that 50MB should be plenty for any +servlet. Garbage-collector overhead means that the actual memory use +of the system can be some small multiple of 50 MB. An important +guarantee, however, is that different connections will not be charged +for each other's memory use, so one misbehaving connection will not +interfere with a different one. So, with the new line above, and assuming that you have a couple of hundred megabytes available for the @exec{mzscheme} process to use, diff --git a/collects/scribblings/mzc/decompile.scrbl b/collects/scribblings/mzc/decompile.scrbl index 31d3803295..f0283401f4 100644 --- a/collects/scribblings/mzc/decompile.scrbl +++ b/collects/scribblings/mzc/decompile.scrbl @@ -1,7 +1,9 @@ #lang scribble/doc @(require scribble/manual "common.ss" - (for-label scheme/base)) + (for-label scheme/base + compiler/decompile + (only-in compiler/zo-parse compilation-top?))) @title[#:tag "decompile"]{Decompiling Bytecode} @@ -84,3 +86,18 @@ Many forms in the decompiled code, such as @scheme[module], syntax objects to a readable form.} ] + +@; ------------------------------------------------------------ + +@section{Scheme API for Decompiling} + +@defmodule[compiler/decompile] + +@defproc[(decompile [top compilation-top?]) any/c]{ + +Consumes the result of parsing bytecode and returns an S-expression +(as described above) that represents the compiled code.} + +@; ------------------------------------------------------------ + +@include-section["zo-parse.scrbl"] diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl new file mode 100644 index 0000000000..5f76caf1a2 --- /dev/null +++ b/collects/scribblings/mzc/zo-parse.scrbl @@ -0,0 +1,464 @@ +#lang scribble/doc +@(require scribble/manual + (for-label scheme/base + compiler/zo-parse)) + +@(define-syntax-rule (defstruct+ id fields . rest) + (defstruct id fields #:transparent . rest)) + +@title{Scheme API for Parsing Bytecode} + +@defmodule[compiler/zo-parse] + +@defproc[(zo-parse [in input-port?]) compilation-top?]{ + +Parses a port (typically the result of opening a @filepath{.zo} file) +containing byte. The parsed bytecode is returned in a +@scheme[compilation-top] structure. + +Beware that the structure types used to represent the bytecode are +subject to frequent changes across PLT Scheme versons.} + +@; -------------------------------------------------- +@section{Prefix} + +@defstruct+[compilation-top ([max-let-depth exact-nonnegative-integer?] + [prefix prefix?] + [code (or/c form? indirect? any/c)])]{ + +Wraps compiled code. The @scheme[max-let-depth] field indicates the +maximum stack depth that @scheme[code] creates (not counting the +@scheme[prefix] array). The @scheme[prefix] field describes top-level +variables, module-level variables, and quoted syntax-objects accessed +by @scheme[code]. The @scheme[code] field contains executable code; it +is normally a @scheme[form], but a literal value is represented as +itself.} + + +@defstruct+[prefix ([num-lifts exact-nonnegative-integer?] + [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] + [stxs (listof stx?)])]{ + +Represents a ``prefix'' that is pushed onto the stack to initiate +evaluation. The prefix is an array, where buckets holding the values +for @scheme[toplevels] are first, then a bucket for another array if +@scheme[stxs] is non-empty, then @scheme[num-lifts] extra buckets for +lifted local procedures. + +In @scheme[toplevels], each element is one of the following: + +@itemize[ + + @item{a @scheme[#f], which indicates a dummy variable that is used to + access the enclosing module/namespace at run time;} + + @item{a symbol, which is a reference to a variable defined in the + enclosing module;} + + @item{a @scheme[global-bucket], which is a top-level variable + (appears only outside of modules); or} + + @item{a @scheme[module-variable], which indicates a variable imported + from another module.} + +] + +The variable buckets and syntax objects that are recorded in a prefix +are accessed by @scheme[toplevel] and @scheme[topsyntax] expression +forms.} + + +@defstruct+[global-bucket ([name symbol?])]{ + +Represents a top-level variable, and used only in a @scheme[prefix].} + + +@defstruct+[module-variable ([modidx module-path-index?] + [sym symbol?] + [pos exact-integer?] + [phase (or/c 0 1)])]{ + +Represents a top-level variable, and used only in a @scheme[prefix]. +The @scheme[pos] may record the variable's offset within its module, +or it can be @scheme[-1] if the variable is always located by name. +The @scheme[phase] indicates the phase level of the definition within +its module.} + + +@defstruct+[stx ([encoded wrapped?])]{ + +Wraps a syntax object in a @scheme[prefix].} + + +@; -------------------------------------------------- +@section{Forms} + +@defstruct+[form ()]{ + +A supertype for all forms that can appear in compiled code (including +@scheme[expr]s), except for literals that are represented as +themselves and @scheme[indirect] structures to create cycles.} + +@defstruct+[(def-values form) ([ids (listof toplevel?)] + [rhs (or/c expr? seq? indirect? any/c)])]{ + +Represents a @scheme[define-values] form. Each element of @scheme[ids] +will reference via the prefix either a top-level variable or a local +module variable. + +After @scheme[rhs] is evaluated, the stack is restored to its depth +from before evaluating @scheme[rhs].} + +@deftogether[( +@defstruct+[(def-syntaxes form) ([ids (listof toplevel?)] + [rhs (or/c expr? seq? indirect? any/c)] + [prefix prefix?] + [max-let-depth nonnegative-exact-integer?])] +@defstruct+[(def-for-syntax form) ([ids (listof toplevel?)] + [rhs (or/c expr? seq? indirect? any/c)] + [prefix prefix?] + [max-let-depth nonnegative-exact-integer?])] +)]{ + +Represents a @scheme[define-syntaxes] or +@scheme[define-values-for-syntax] form. The @scheme[rhs] expression +has its own @scheme[prefix], which is pushed before evaluating +@scheme[rhs]; the stack is restored after obtaining the result +values. The @scheme[max-let-depth] field indicates the maximum size of +the stack that will be created by @scheme[rhs] (not counting +@scheme[prefix]).} + +@defstruct+[(req form) ([reqs (listof module-path?)] + [dummy toplevel?])]{ + +Represents a top-level @scheme[require] form (but not one in a +@scheme[module] form). The @scheme[dummy] variable is used to access +to the top-level namespace.} + + +@defstruct+[(mod form) ([name symbol?] + [self-modidx module-path-index?] + [prefix prefix?] + [provides (listof symbol?)] + [requires (listof (cons/c (or/c exact-integer? #f) + (listof module-path-index?)))] + [body (listof (or/c form? indirect? any/c))] + [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] + [max-let-depth exact-nonnegative-integer?])]{ + +Represents a @scheme[module] declaration. The @scheme[body] forms use +@scheme[prefix], rather than any prefix in place for the module +declaration itself (and each @scheme[syntax-body] has its own +prefix). The @scheme[body] field contains the module's run-time code, +and @scheme[syntax-body] contains the module's compile-time code. The +@scheme[max-let-depth] field indicates the maximum stack depth created +by @scheme[body] forms (not counting the @scheme[prefix] array). + +After each form in @scheme[body] is evaluated, the stack is restored +to its depth from before evaluating the form.} + + +@defstruct+[(seq form) ([forms (listof (or/c form? indirect? any/c))])]{ + +Represents a @scheme[begin] form, either as an expression or at the +top level (though the latter is more commonly a @scheme[splice] form). +When a @scheme[seq] appears in an expression position, its +@scheme[forms] are expressions. + +After each form in @scheme[forms] is evaluated, the stack is restored +to its depth from before evaluating the form.} + + +@defstruct+[(splice form) ([forms (listof (or/c form? indirect? any/c))])]{ + +Represents a top-level @scheme[begin] form where each evaluation is +wrapped with a continuation prompt. + +After each form in @scheme[forms] is evaluated, the stack is restored +to its depth from before evaluating the form.} + + +@; -------------------------------------------------- +@section{Expressions} + +@defstruct+[(expr form) ()]{ + +A supertype for all expression forms that can appear in compiled code, +except for literals that are represented as themselves, +@scheme[indirect] structures to create cycles, and some @scheme[seq] +structures (which can appear as an expression as long as it contains +only other things that can be expressions).} + + +@defstruct+[(lam expr) ([name (or/c symbol? vector?)] + [flags exact-integer?] + [num-params exact-nonnegative-integer?] + [rest? boolean?] + [closure-map (vectorof exact-nonnegative-integer?)] + [max-let-depth exact-nonnegative-integer?] + [body (or/c expr? seq? indirect? any/c)])]{ + +Represents a @scheme[lambda] form. The @scheme[name] field is a name +for debugging purposes. The @scheme[num-params] field indicates the +number of arguments accepted by the procedure, not counting a rest +argument; the @scheme[rest?] field indicates whether extra arguments +are accepted and collected into a ``rest'' variable. The +@scheme[closure-map] field is a vector of stack positions that are +captured when evaluating the @scheme[lambda] form to create a closure. + +When the function is called, the rest-argument list (if any) is pushed +onto the stack, then the normal arguments in reverse order, then the +closure-captured values in reverse order. Thus, when @scheme[body] is +run, the first value on the stack is the first value captured by the +@scheme[closure-map] array, and so on. + +The @scheme[max-let-depth] field indicates the maximum stack depth +created by @scheme[body] (not including arguments and closure-captured +values pushed onto the stack). The @scheme[body] field is the +expression for the closure's body.} + + +@defstruct+[(closure expr) ([code lam?] [gen-id symbol?])]{ + +A @scheme[lambda] form with an empty closure, which is a procedure +constant. The procedure constant can appear multiple times in the +graph of expressions for bytecode, and the @scheme[code] field can +refer back to the same @scheme[closure] through an @scheme[indirect] +for a recursive constant procedure; the @scheme[gen-id] is different +for each such constant.} + + +@defstruct[indirect ([v closure?]) #:mutable #:prefab]{ + +An indirection used in expression positions to form cycles.} + + +@defstruct+[(case-lam expr) ([name (or/c symbol? vector?)] + [clauses (listof lam?)])]{ + +Represents a @scheme[case-lambda] form as a combination of +@scheme[lambda] forms that are tried (in order) based on the number of +arguments given.} + + +@defstruct+[(let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] + [body (or/c expr? seq? indirect? any/c)])]{ + +Pushes an uninitialized slot onto the stack, evaluates @scheme[rhs] +and puts its value into the slot, and then runs @scheme[body]. + +After @scheme[rhs] is evaluated, the stack is restored to its depth +from before evaluating @scheme[rhs]. Note that the new slot is created +before evaluating @scheme[rhs].} + + +@defstruct+[(let-void expr) ([count nonnegative-exact-integer?] + [boxes? boolean?] + [body (or/c expr? seq? indirect? any/c)])]{ + +Pushes @scheme[count] uninitialized slots onto the stack and then runs +@scheme[body]. If @scheme[boxes?] is @scheme[#t], then the slots are +filled with boxes that contain @|undefined-const|.} + + +@defstruct+[(install-value expr) ([count nonnegative-exact-integer?] + [pos nonnegative-exact-integer?] + [boxes? boolean?] + [rhs (or/c expr? seq? indirect? any/c)] + [body (or/c expr? seq? indirect? any/c)])]{ + +Runs @scheme[rhs] to obtain @scheme[count] results, and installs them +into existing slots on the stack in order, skipping the first +@scheme[pos] stack positions. If @scheme[boxes?] is @scheme[#t], then +the values are put into existing boxes in the stack slots. + +After @scheme[rhs] is evaluated, the stack is restored to its depth +from before evaluating @scheme[rhs].} + + +@defstruct+[(let-rec expr) ([procs (listof lam?)] + [body (or/c expr? seq? indirect? any/c)])]{ + +Represents a @scheme[letrec] form with @scheme[lambda] bindings. It +allocates a closure shell for each @scheme[lambda] form in +@scheme[procs], pushes them onto the stack in reverse order, fills out +each shell's closure using the created shells, and then evaluates +@scheme[body].} + + +@defstruct+[(boxenv expr) ([pos nonnegative-exact-integer?] + [body (or/c expr? seq? indirect? any/c)])]{ + +Skips @scheme[pos] elements of the stack, setting the slot afterward +to a new box containing the slot's old value, and then runs +@scheme[body]. This form appears when a @scheme[lambda] argument is +mutated using @scheme[set!] within its body; calling the function +initially pushes the value directly on the stack, and this form boxes +the value so that it can be mutated later.} + + +@defstruct+[(localref expr) ([unbox? boolean?] + [pos nonnegative-exact-integer?] + [clear? boolean?])]{ + +Represents a local-variable reference; it accesses the value in the +stack slot after the first @scheme[pos] slots. If @scheme[unbox?] is +@scheme[#t], the stack slot contains a box, and a value is extracted +from the box. If @scheme[clear?] is @scheme[#t], then after the value +is obtained, the stack slot is cleared (to avoid retaining a reference +that can prevent reclamation of the value as garbage).} + + +@defstruct+[(toplevel expr) ([depth nonnegative-exact-integer?] + [pos nonnegative-exact-integer?] + [const? boolean?] + [ready? boolean?])]{ + +Represents a reference to a top-level or imported variable via the +@scheme[prefix] array. The @scheme[depth] field indicates the number +of stack slots to skip to reach the prefix array, and @scheme[pos] is +the offset into the array. + +If @scheme[const?] is @scheme[#t], then the variable definitely will +be defined, and its value stays constant. If @scheme[ready?] is +@scheme[#t], then the variable definitely will be defined (but its +value might change in the future). If @scheme[const?] and +@scheme[ready?] are both @scheme[#f], then a check is needed to +determine whether the variable is defined.} + + +@defstruct+[(topsyntax expr) ([depth nonnegative-exact-integer?] + [pos nonnegative-exact-integer?] + [midpt nonnegative-exact-integer?])]{ + +Represents a reference to a quoted syntax object via the +@scheme[prefix] array. The @scheme[depth] field indicates the number +of stack slots to skip to reach the prefix array, and @scheme[pos] is +the offset into the array. The @scheme[midpt] value is used internally +for lazy calculation of syntax information.} + + +@defstruct+[(application expr) ([rator (or/c expr? seq? indirect? any/c)] + [rands (listof (or/c expr? seq? indirect? any/c))])]{ + +Represents a function call. The @scheme[rator] field is the expression +for the function, and @scheme[rands] are the argument +expressions. Before any of the expressions are evaluated, +@scheme[(length rands)] uninitialized stack slots are created (to be +used as temporary space).} + + +@defstruct+[(branch expr) ([test (or/c expr? seq? indirect? any/c)] + [then (or/c expr? seq? indirect? any/c)] + [else (or/c expr? seq? indirect? any/c)])]{ + +Represents an @scheme[if] form. + +After @scheme[test] is evaluated, the stack is restored to its depth +from before evaluating @scheme[test].} + + +@defstruct+[(with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)] + [val (or/c expr? seq? indirect? any/c)] + [body (or/c expr? seq? indirect? any/c)])]{ + +Represents a @scheme[with-continuation-mark] expression. + +After each of @scheme[key] and @scheme[val] is evaluated, the stack is +restored to its depth from before evaluating @scheme[key] or +@scheme[val].} + +@defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])]{ + +Represents a @scheme[begin0] expression. + +After each expression in @scheme[seq] is evaluated, the stack is +restored to its depth from before evaluating the expression.} + + +@defstruct+[(varref expr) ([toplevel toplevel?])]{ + +Represents a @scheme[#%variable-reference] form.} + + +@defstruct+[(assign expr) ([id toplevel?] + [rhs (or/c expr? seq? indirect? any/c)] + [undef-ok? boolean?])]{ + +Represents a @scheme[set!] expression that assigns to a top-level or +module-level variable. (Assignments to local variables are represented +by @scheme[install-value] expressions.) + +After @scheme[rhs] is evaluated, the stack is restored to its depth +from before evaluating @scheme[rhs].} + + +@defstruct+[(apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] + [args-expr (or/c expr? seq? indirect? any/c)])]{ + +Represents @scheme[(call-with-values (lambda () args-expr) proc)], +which is handled specially by the run-time system.} + + +@defstruct+[(primval expr) ([id symbol?])]{ + +Represents a direct reference to a variable imported from the run-time +kernel.} + +@; -------------------------------------------------- +@section{Syntax Objects} + +@defstruct+[wrapped ([datum any/c] + [wraps (listof wrap?)] + [certs list?])]{ + +Represents a syntax object, where @scheme[wraps] contain the lexical +information and @scheme[certs] is certificate information. When the +@scheme[datum] part is itself compound, its pieces are wrapped, too.} + + +@defstruct+[wrap ()]{ + +A supertype for lexical-information elements.} + + +@defstruct+[(lexical-rename wrap) ([alist (listof (cons/c identifier? identifier?))])]{ + +A local-binding mapping from symbols to binding-set names.} + + +@defstruct+[(phase-shift wrap) ([amt exact-integer?] + [src module-path-index?] + [dest module-path-index?])]{ + +Shifts module bindings later in the wrap set.} + +@defstruct+[(module-rename wrap) ([phase exact-integer?] + [kind (or/c 'marked 'normal)] + [set-id any/c] + [unmarshals (listof make-all-from-module?)] + [renames (listof module-binding?)] + [mark-renames any/c] + [plus-kern? boolean?])]{ + +Represents a set of module and import bindings.} + +@defstruct+[all-from-module ([path module-path-index?] + [phase (or/c exact-integer? #f)] + [src-phase (or/c exact-integer? #f)] + [exceptions (listof symbol?)] + [prefix symbol?])]{ + +Represents a set of simple imports from one module within a +@scheme[module-rename].} + +@defstruct+[module-binding ([path module-path-index?] + [mod-phase (or/c exact-integer? #f)] + [import-phase (or/c exact-integer? #f)] + [id symbol?] + [nominal-path module-path-index?] + [nominal-phase (or/c exact-integer? #f)] + [nominal-id (or/c exact-integer? #f)])]{ + +Represents a single identifier import (i.e., the general case) within +a @scheme[module-rename].} diff --git a/collects/scribblings/reference/booleans.scrbl b/collects/scribblings/reference/booleans.scrbl index 0e758c7638..60d36ac334 100644 --- a/collects/scribblings/reference/booleans.scrbl +++ b/collects/scribblings/reference/booleans.scrbl @@ -14,13 +14,24 @@ See also: @scheme[and], @scheme[or], @scheme[andmap], @scheme[ormap]. @defproc[(boolean? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is @scheme[#t] or @scheme[#f], -@scheme[#f] otherwise.} +@scheme[#f] otherwise. + +@examples[ +(boolean? #f) +(boolean? #t) +(boolean? 'true) +]} @defproc[(not [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is @scheme[#f], @scheme[#f] otherwise. -} + +@examples[ +(not #f) +(not #t) +(not 'we-have-no-bananas) +]} @defproc[(equal? [v1 any/c] [v2 any/c]) boolean?]{ @@ -33,7 +44,15 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, hash tables, and inspectable structures. In the last five cases, equality is recursively defined; if both @scheme[v1] and @scheme[v2] contain reference cycles, they are equal when the infinite unfoldings of the -values would be equal. See also @scheme[prop:equal+hash].} +values would be equal. See also @scheme[prop:equal+hash]. + +@examples[ +(equal? 'yes 'yes) +(equal? 'yes 'no) +(equal? (expt 2 100) (expt 2 100)) +(equal? 2 2.0) +(equal? (make-string 3 #\z) (make-string 3 #\z)) +]} @defproc[(eqv? [v1 any/c] [v2 any/c]) boolean?]{ @@ -41,14 +60,47 @@ values would be equal. See also @scheme[prop:equal+hash].} Two values are @scheme[eqv?] if and only if they are @scheme[eq?], unless otherwise specified for a particular datatype. -The number and character datatypes are the only ones for which -@scheme[eqv?] differs from @scheme[eq?].} +The @tech{number} and @tech{character} datatypes are the only ones for which +@scheme[eqv?] differs from @scheme[eq?]. + +@examples[ +(eqv? 'yes 'yes) +(eqv? 'yes 'no) +(eqv? (expt 2 100) (expt 2 100)) +(eqv? 2 2.0) +(eqv? (integer->char #x3BB) (integer->char #x3BB)) +(eqv? (make-string 3 #\z) (make-string 3 #\z)) +]} @defproc[(eq? [v1 any/c] [v2 any/c]) boolean?]{ Return @scheme[#t] if @scheme[v1] and @scheme[v2] refer to the same -object, @scheme[#f] otherwise. See also @secref["model-eq"].} +object, @scheme[#f] otherwise. See also @secref["model-eq"]. + +@examples[ +(eq? 'yes 'yes) +(eq? 'yes 'no) +(let ([v (mcons 1 2)]) (eq? v v)) +(eq? (mcons 1 2) (mcons 1 2)) +(eq? (make-string 3 #\z) (make-string 3 #\z)) +]} + + +@defproc[(equal?/recur [v1 any/c] [v2 any/c] [recur-proc (any/c any/c -> any/c)]) boolean?]{ + +Like @scheme[equal?], but using @scheme[recur-proc] for recursive +comparisons (which means that reference cycles are not handled +automatically). Non-@scheme[#f] results from @scheme[recur-proc] are +converted to @scheme[#t] before being returned by +@scheme[equal?/recur]. + +@examples[ +(equal?/recur 1 1 (lambda (a b) #f)) +(equal?/recur '(1) '(1) (lambda (a b) #f)) +(equal?/recur '#(1 1 1) '#(1 1.2 3/4) + (lambda (a b) (<= (abs (- a b)) 0.25))) +]} @defproc[(immutable? [v any/c]) boolean?]{ @@ -74,7 +126,9 @@ type. The property value must be a list of three procedures: The third argument is an @scheme[equal?] predicate to use for recursive equality checks; use the given predicate instead of @scheme[equal?] to ensure that data cycles are handled - properly. + properly and to work with @scheme[equal?/recur] (but beware + that an arbitrary function can be provided to + @scheme[equal?/recur]). The @scheme[_equal-proc] is called for a pair of structures only when they are not @scheme[eq?], and only when they both diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 7da30e2c3e..adbb77410c 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -75,9 +75,9 @@ @title[#:tag "mzlib:class" #:style 'toc]{Classes and Objects} -@note-lib[scheme/class #:use-sources (scheme/private/class-internal)] +@guideintro["classes"]{classes and objects} -@local-table-of-contents[] +@note-lib[scheme/class #:use-sources (scheme/private/class-internal)] A @deftech{class} specifies @@ -152,6 +152,8 @@ Classes, objects, and interfaces are all values. However, a class or interface is not an object (i.e., there are no ``meta-classes'' or ``meta-interfaces''). +@local-table-of-contents[] + @; ------------------------------------------------------------------------ @section[#:tag "createinterface"]{Creating Interfaces} @@ -184,6 +186,23 @@ is the most specific requirement from its superinterfaces. If the superinterfaces specify inconsistent derivation requirements, the @exnraise[exn:fail:object].} +@defform[(interface* (super-interface-expr ...) + ([property-expr val-expr] ...) + id ...)]{ + +Like @scheme[interface], but also associates to the interface the +structure-type properties produced by the @scheme[property-expr]s with +the corresponding @scheme[val-expr]s. + +Whenever the resulting interface (or a sub-interface derived from it) +is explicitly implemented by a class through the @scheme[class*] form, +each property is attached with its value to a structure type that +instantiated by instances of the class. Specifically, the property is +attached to a structure type with zero immediate fields, which is +extended to produce the internal structure type for instances of the +class (so that no information about fields is accessible to the +structure type property's guard, if any).} + @; ------------------------------------------------------------------------ @section[#:tag "createclass"]{Creating Classes} @@ -1456,6 +1475,60 @@ Returns a flat-contract that recognizes classes that are subclasses of @scheme[class].} +@; ------------------------------------------------------------------------ + +@section[#:tag "objectequality"]{Object Equality and Hashing} + +But default, objects that are instances of different classes or that +are instances of a non-transparent class are @scheme[equal?] only if +they are @scheme[eq?]. Like transparent structures, two objects that +are instances of the same transparent class (i.e., every superclass of +the class has @scheme[#f] as its inspector) are @scheme[equal?] when +their field values are @scheme[equal?]. + +To customize the way that a class instance is compared to other +instances by @scheme[equal?], implement the @scheme[equal<%>] +interface. + +@definterface[equal<%> ()]{} + +The @scheme[equal<%>] interface includes three methods, which are +analogous to the functions provided for a structure type with +@scheme[prop:equal+hash]: + +@itemize[ + + @item{@scheme[equal-to?] --- Takes two arguments. The first argument + is an object that is an instance of the same class (or a subclass + that does not re-declare its implementation of @scheme[equal<%>]) + and that is being compared to the target object. The second argument + is a @scheme[equal?]-like procedure of two arguments that should be + used for recursive equality testing. The result should be a true + value if the object and the first argument of the method are equal, + @scheme[#f] otherwise.} + + @item{@scheme[equal-hash-code-of] --- Takes one argument, which is a + procedure of one argument that should be used for recursive hash-code + computation. The result should be an exact integer representing the + target object's hash code.} + + @item{@scheme[equal-secondary-hash-code-of] --- Takes one argument, + which is a procedure of one argument that should be used for + recursive hash-code computation. The result should be an exact + integer representing the target object's secondary hash code.} + +] + +The @scheme[equal<%>] interface is unusual in that declaring the +implementation of the interface is different from inheriting the +interface. Two objects can be equal only if they are instances of +classes whose most specific ancestor to explicitly implement +@scheme[equal<%>] is the same ancestor. + +See @scheme[prop:equal+hash] for more information on equality +comparisons and hash codes. The @scheme[equal<%>] interface is +implemented with @scheme[interface*] and @scheme[prop:equal+hash]. + @; ------------------------------------------------------------------------ @section[#:tag "objectserialize"]{Object Serialization} @@ -1533,11 +1606,11 @@ Like @scheme[define-serializable-class*], but with not interface expressions (analogous to @scheme[class]).} -@defthing[externalizable<%> interface?]{ +@definterface[externalizable<%> ()]{} The @scheme[externalizable<%>] interface includes only the @scheme[externalize] and @scheme[internalize] methods. See -@scheme[define-serializable-class*] for more information.} +@scheme[define-serializable-class*] for more information. @; ------------------------------------------------------------------------ @@ -1556,8 +1629,11 @@ a single argument, which is the destination port to @scheme[write] or Calls to the @scheme[custom-write] or @scheme[custom-display] are like calls to a procedure attached to a structure type through the @scheme[prop:custom-write] property. In particular, recursive printing -can trigger an escape from the call. See @scheme[prop:custom-write] -for more information.} +can trigger an escape from the call. + +See @scheme[prop:custom-write] for more information. The +@scheme[printable<%>] interface is implemented with +@scheme[interface*] and @scheme[prop:custom-write].} @; ------------------------------------------------------------------------ diff --git a/collects/scribblings/reference/cont.scrbl b/collects/scribblings/reference/cont.scrbl index ddaead02b8..bbfc74f87a 100644 --- a/collects/scribblings/reference/cont.scrbl +++ b/collects/scribblings/reference/cont.scrbl @@ -43,17 +43,18 @@ between the application and the current continuation. @defproc[(call-with-continuation-prompt - [thunk (-> any)] + [proc procedure?] [prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)] - [handler (or/c procedure? #f) #f]) + [handler (or/c procedure? #f) #f] + [arg any/c] ...) any]{ -Calls @scheme[thunk] with the current continuation extended by a -prompt. The prompt is tagged by @scheme[prompt-tag], which must be a -result from either @scheme[default-continuation-prompt-tag] (the -default) or @scheme[make-continuation-prompt-tag]. The result of -@scheme[thunk] is the result of the -@scheme[call-with-continuation-prompt] call. +Applies @scheme[proc] to the given @scheme[arg]s with the current +continuation extended by a prompt. The prompt is tagged by +@scheme[prompt-tag], which must be a result from either +@scheme[default-continuation-prompt-tag] (the default) or +@scheme[make-continuation-prompt-tag]. The result of @scheme[proc] is +the result of the @scheme[call-with-continuation-prompt] call. The @scheme[handler] argument specifies a handler procedure to be called in tail position with respect to the @@ -62,8 +63,8 @@ is the target of a @scheme[abort-current-continuation] call with @scheme[prompt-tag]; the remaining arguments of @scheme[abort-current-continuation] are supplied to the handler procedure. If @scheme[handler] is @scheme[#f], the default handler -accepts a single @scheme[abort-thunk] argument and calls -@scheme[(call-with-continuation-prompt abort-thunk prompt-tag #f)]; +accepts a single @scheme[_abort-thunk] argument and calls +@scheme[(call-with-continuation-prompt _abort-thunk prompt-tag #f)]; that is, the default handler re-installs the prompt and continues with a given thunk.} diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index ff8c1b6ff0..11a5cea81d 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -363,7 +363,7 @@ results or completely unspecified results (the latter when @scheme[any] is specified). Each @scheme[dom-expr] is a contract on an argument to a -function, and each @scheme[res-expr] is a contract on a +function, and each @scheme[range-expr] is a contract on a result of the function. @margin-note{Using an @scheme[->] between two whitespace-delimited @@ -395,7 +395,7 @@ contract checking is performed on the result of the function, and thus any number of values is legal (even different numbers on different invocations of the function). -If @scheme[(values res-expr ...)] is used as the last sub-form of +If @scheme[(values range-expr ...)] is used as the last sub-form of @scheme[->], the function must produce a result for each contract, and each values must match its respective contract.} @@ -494,10 +494,10 @@ just like that for @scheme[->] and @scheme[->*]. } -@defform[(unconstrained-domain-> res-expr ...)]{ +@defform[(unconstrained-domain-> range-expr ...)]{ Constructs a contract that accepts a function, but makes no constraint -on the function's domain. The @scheme[res-expr]s determine the number +on the function's domain. The @scheme[range-expr]s determine the number of results and the contract for each result. Generally, this contract must be combined with another contract to diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index 8fa05d1d29..37a1879cac 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -138,7 +138,8 @@ message.} @defproc[(raise-syntax-error [name (or/c symbol? #f)] [message string?] [expr any/c #f] - [sub-expr any/c #f]) + [sub-expr any/c #f] + [extra-sources (listof syntax?) null]) any]{ Creates an @scheme[exn:fail:syntax] value and @scheme[raise]s it as an @@ -151,12 +152,19 @@ is provided; it is described in more detail below. The The optional @scheme[expr] argument is the erroneous source syntax object or S-expression. The optional @scheme[sub-expr] argument is a syntax object or S-expression within @scheme[expr] that more precisely -locates the error. If @scheme[sub-expr] is provided, it is used (in -syntax form) for the @scheme[exprs] field of the generated exception -record, else the @scheme[expr] is used if provided, otherwise the -@scheme[exprs] field is the empty list. Source location information in -the error-message text is similarly extracted from @scheme[sub-expr] -or @scheme[expr], when at least one is a syntax object. +locates the error. Both may appear in the generated error-message +text if @scheme[error-print-source-location] is @scheme[#t]. Source +location information in the error-message text is similarly extracted +from @scheme[sub-expr] or @scheme[expr] when at least one is a syntax +object and @scheme[error-print-source-location] is @scheme[#t]. + +If @scheme[sub-expr] is provided, it is used (in syntax form) for the +@scheme[exprs] field of the generated exception record, else the +@scheme[expr] is used if provided. In either case, the syntax object +is @scheme[cons]ed onto @scheme[extra-sources] to produce the +@scheme[exprs] field, or @scheme[extra-sources] is used directly for +@scheme[exprs] if neither @scheme[expr] nor @scheme[sub-expr] is +provided. The form name used in the generated error message is determined through a combination of the @scheme[name], @scheme[expr], and @@ -177,9 +185,7 @@ through a combination of the @scheme[name], @scheme[expr], and @item{@scheme[symbol]: When @scheme[name] is a symbol, then the symbol is used as the form name in the generated error message.} -} - -See also @scheme[error-print-source-location].} +}} @;------------------------------------------------------------------------ @section{Handling Exceptions} diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index 9ce8a15150..2c692cd4af 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -8,6 +8,8 @@ @title[#:tag "match"]{Pattern Matching} +@guideintro["match"]{pattern matching} + The @scheme[match] form and related forms support general pattern matching on Scheme values. See also @secref["regexp"] for information on regular-expression matching on strings, bytes, and streams. diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index acdd768839..bda29a70ea 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -672,6 +672,28 @@ returns @scheme[#f]. (filter-not even? '(1 2 3 4 5 6)) ]} +@defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ + +This returns the first element in the list @scheme[lst] that minimizes +the result of @scheme[proc]. + +@mz-examples[#:eval list-eval +(argmin car '((3 pears) (1 banana) (2 apples))) +(argmin car '((1 banana) (1 orange))) +] +} + +@defproc[(argmax [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ + +This returns the first element in the list @scheme[lst] that maximizes +the result of @scheme[proc]. + +@mz-examples[#:eval list-eval +(argmax car '((3 pears) (1 banana) (2 apples))) +(argmax car '((3 pears) (3 oranges))) +] +} + @close-eval[list-eval] @; ---------------------------------------- diff --git a/collects/scribblings/reference/parameters.scrbl b/collects/scribblings/reference/parameters.scrbl index 263de8ec40..8a04c40e6f 100644 --- a/collects/scribblings/reference/parameters.scrbl +++ b/collects/scribblings/reference/parameters.scrbl @@ -3,6 +3,8 @@ @title[#:tag "parameters"]{Parameters} +@guideintro["parameterize"]{parameters} + See @secref["parameter-model"] for basic information on the parameter model. Parameters correspond to @defterm{preserved thread fluids} in Scsh @cite["Gasbichler02"]. @@ -45,6 +47,8 @@ applied to the initial @scheme[v].} @defform[(parameterize ((parameter-expr value-expr) ...) body ...+)]{ +@guideintro["parameterize"]{@scheme[parameterize]} + The result of a @scheme[parameterize] expression is the result of the last @scheme[body]. The @scheme[parameter-expr]s determine the parameters to set, and the @scheme[value-expr]s determine the diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 75a4f93b97..68557ca14f 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -46,6 +46,15 @@ function consumes. ((compose list split-path) (bytes->path #"/a" 'unix)) ]} +@defproc[(procedure-rename [proc procedure?] + [name symbol?]) + procedure?]{ + +Returns a procedure that is like @scheme[proc], except that its name +as returned by @scheme[object-name] (and as printed for debugging) is +@scheme[name].} + + @; ---------------------------------------- @section{Keywords and Arity} diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index 97df718550..9201c4bc19 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -23,7 +23,7 @@ port, it matches UTF-8 encodings (see @secref["encodings"]) of matching character streams; if a byte regexp is used with a character string, it matches bytes in the UTF-8 encoding of the string. -Regular expressions can be compiled into a @defterm{regexp value} for +Regular expressions can be compiled into a @deftech{regexp value} for repeated matches. The @scheme[regexp] and @scheme[byte-regexp] procedures convert a string or byte string (respectively) into a regexp value using one syntax of regular expressions that is most @@ -103,25 +103,25 @@ arbitrarily large sequence). @defproc[(regexp? [v any/c]) boolean?]{ -Returns @scheme[#t] if @scheme[v] is a regexp value created by +Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by @scheme[regexp] or @scheme[pregexp], @scheme[#f] otherwise.} @defproc[(pregexp? [v any/c]) boolean?]{ -Returns @scheme[#t] if @scheme[v] is a regexp value created by +Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by @scheme[pregexp] (not @scheme[regexp]), @scheme[#f] otherwise.} @defproc[(byte-regexp? [v any/c]) boolean?]{ -Returns @scheme[#t] if @scheme[v] is a regexp value created by +Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by @scheme[byte-regexp] or @scheme[byte-pregexp], @scheme[#f] otherwise.} @defproc[(byte-pregexp? [v any/c]) boolean?]{ -Returns @scheme[#t] if @scheme[v] is a regexp value created by +Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by @scheme[byte-pregexp] (not @scheme[byte-regexp]), @scheme[#f] otherwise.} @@ -129,15 +129,15 @@ otherwise.} @defproc[(regexp [str string?]) regexp?]{ Takes a string representation of a regular expression (using the -syntax in @secref["regexp-syntax"]) and compiles it into a regexp -value. Other regular expression procedures accept either a string or a -regexp value as the matching pattern. If a regular expression string +syntax in @secref["regexp-syntax"]) and compiles it into a @tech{regexp +value}. Other regular expression procedures accept either a string or a +@tech{regexp value} as the matching pattern. If a regular expression string is used multiple times, it is faster to compile the string once to a -regexp value and use it for repeated matches instead of using the +@tech{regexp value} and use it for repeated matches instead of using the string each time. The @scheme[object-name] procedure returns -the source string for a regexp value. +the source string for a @tech{regexp value}. @examples[ (regexp "ap*le") @@ -160,10 +160,10 @@ Like @scheme[regexp], except that it uses a slightly different syntax Takes a byte-string representation of a regular expression (using the syntax in @secref["regexp-syntax"]) and compiles it into a -byte-regexp value. +byte-@tech{regexp value}. The @scheme[object-name] procedure -returns the source byte string for a regexp value. +returns the source byte string for a @tech{regexp value}. @examples[ (byte-regexp #"ap*le") @@ -210,8 +210,8 @@ case-sensitively. (listof (or/c bytes? #f)) #f)]{ -Attempts to match @scheme[pattern] (a string, byte string, regexp -value, or byte-regexp value) once to a portion of @scheme[input]. The +Attempts to match @scheme[pattern] (a string, byte string, @tech{regexp +value}, or byte-@tech{regexp value}) once to a portion of @scheme[input]. The matcher finds a portion of @scheme[input] that matches and is closest to the start of the input (after @scheme[start-pos]). @@ -236,7 +236,7 @@ end-of-input @litchar{$} refers to the @scheme[end-pos]th position or If the match fails, @scheme[#f] is returned. If the match succeeds, a list containing strings or byte string, and possibly @scheme[#f], is returned. The list contains strings only if @scheme[input] is a string -and @scheme[pattern] is not a byte regexp value. Otherwise, the list +and @scheme[pattern] is not a byte regexp. Otherwise, the list contains byte strings (substrings of the UTF-8 encoding of @scheme[input], if @scheme[input] is a string). diff --git a/collects/scribblings/reference/rx.ss b/collects/scribblings/reference/rx.ss index 7122674c85..10d8e3e587 100644 --- a/collects/scribblings/reference/rx.ss +++ b/collects/scribblings/reference/rx.ss @@ -49,20 +49,26 @@ Range ::= ] Range contains _]_ only | Mrange- Range contains _-_ and everything in Mrange #co Mrange ::= ]Lrange Mrange contains _]_ and everything in Lrange #co | -Lrange Mrange contains _-_ and everything in Lrange #co - | Lrange Mrange contains everything in Lrange #co -Lrange ::= Rliteral Lrange contains a literal character #co + | Srange Mrange contains everything in Srange #co +Srange ::= Sliteral Srange contains a literal character #co + | Sliteral-Rliteral Srange contains Unicode range inclusive #co + | SrangeLrange Srange contains everything in both #co +Lrange ::= ^ Lrange contains _^_ #co | Rliteral-Rliteral Lrange contains Unicode range inclusive #co - | LrangeLrange Lrange contains everything in both #co + | ^Lrange Lrange contains _^_ and more #co + | Srange Lrange contains everything in Srange #co Look ::= (?=Regexp) Match if Regexp matches #mode | (?!Regexp) Match if Regexp doesn't match #mode | (?<=Regexp) Match if Regexp matches preceeding #mode | (?vector] to the structs are @scheme[equal?]. (Consequently, @scheme[equal?] testing for structures depends on the current inspector.) +@local-table-of-contents[] + @;------------------------------------------------------------------------ @include-section["define-struct.scrbl"] diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 365eb9ce7e..75baa630ce 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -1335,6 +1335,7 @@ position with respect to the @scheme[if] form. @mz-examples[ (if (positive? -5) (error "doesn't get here") 2) (if (positive? 5) 1 (error "doesn't get here")) +(if 'we-have-no-bananas "yes" "no") ]} @defform/subs[#:literals (else =>) diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 43cc47e1f9..cb0ee2376a 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -89,24 +89,25 @@ ways: As an export, this form causes definitions using the @scheme[id] prefix to satisfy the exports required by @scheme[sig-spec].} - @item{@scheme[(rename sig-spec (id id) ...)] as - an import binds the same as @scheme[sig-spec], except that the first @scheme[id] - is used for the binding instead of the second @scheme[id] (where - @scheme[sig-spec] by itself must imply a binding for the second @scheme[id]). - As an export, this form causes a definition for the first @scheme[id] - to satisfy the export named by the second @scheme[id] in @scheme[sig-spec].} + @item{@scheme[(rename sig-spec (id id) ...)] as an import binds the + same as @scheme[sig-spec], except that the first @scheme[id] is used + for the binding instead of the second @scheme[id] (where + @scheme[sig-spec] by itself must imply a bindingthat is + @scheme[bound-identifier=?] to second @scheme[id]). As an export, + this form causes a definition for the first @scheme[id] to satisfy + the export named by the second @scheme[id] in @scheme[sig-spec].} - @item{@scheme[(only sig-spec id ...)] as - an import binds the same as @scheme[sig-spec], but restricted to just the - listed @scheme[id]s (where - @scheme[sig-spec] by itself must imply a binding for each @scheme[id]). - This form is not allowed for an export.} + @item{@scheme[(only sig-spec id ...)] as an import binds the same as + @scheme[sig-spec], but restricted to just the listed @scheme[id]s + (where @scheme[sig-spec] by itself must imply a binding that is + @scheme[bound-identifier=?] to each @scheme[id]). This form is not + allowed for an export.} - @item{@scheme[(except sig-spec id ...)] as - an import binds the same as @scheme[sig-spec], but excluding all listed - @scheme[id]s (where - @scheme[sig-spec] by itself must imply a binding for each @scheme[id]). - This form is not allowed for an export.} + @item{@scheme[(except sig-spec id ...)] as an import binds the same + as @scheme[sig-spec], but excluding all listed @scheme[id]s (where + @scheme[sig-spec] by itself must imply a binding that is + @scheme[bound-identifier=?] to each @scheme[id]). This form is not + allowed for an export.} } diff --git a/collects/teachpack/2htdp/scribblings/balls.ss b/collects/teachpack/2htdp/scribblings/balls.ss new file mode 100644 index 0000000000..a0e3bda180 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/balls.ss @@ -0,0 +1,59 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname balls) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(require (lib "world.ss" "htdp")) + +;; constants +(define height 50) +(define delta 80) +(define width (+ delta (* 2 height))) + +(define left (quotient height 2)) +(define right (+ height delta left)) + +;; World = (make-posn left Number) | (make-posn right Number) + +(define server (text "server" 11 'black)) +(define server* (overlay server (nw:rectangle (image-width server) (image-height server) 'outline 'black))) + +;; visual constants +(define bg + (place-image + (text "universe" 11 'green) + 60 0 + (place-image + server* + (+ height 15) 20 + (place-image + (text "left" 11 'blue) + 10 10 + (place-image + (text "right" 11 'red) + (+ height delta 10) 10 + (place-image + (nw:rectangle delta height 'solid 'white) + height 0 + (place-image + (nw:rectangle width height 'solid 'gray) + 0 0 + (empty-scene width height)))))))) + +(define ball (circle 3 'solid 'red)) + +;; World -> Scene +(define (draw w) + (place-image ball (posn-x w) (posn-y w) bg)) + + +;; World -> World +(define (tick w) + (local ((define y (posn-y w)) + (define x (posn-x w))) + (cond + [(> y 0) (make-posn x (- y 1))] + [(= x left) (make-posn right height)] + [(= x right) (make-posn left height)]))) + +(big-bang width height 1/66 (make-posn left height) true) +(on-redraw draw) +(on-tick-event tick) diff --git a/collects/teachpack/2htdp/scribblings/fsa.ss b/collects/teachpack/2htdp/scribblings/fsa.ss new file mode 100644 index 0000000000..6fd029e6a5 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/fsa.ss @@ -0,0 +1,59 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 40) +(define FT 12) + +; (fsa "unlock" "lock" "push" "tick") +(define (fsa L C O unlock lock push tick) + (define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ 10 (pict-height t)))) + (cc-superimpose t e)) + + (define locked (make-state L)) + (define closed (make-state C)) + (define open (make-state O)) + + (define bg (rectangle (+ (pict-width locked) (* 2 DELTA)) + (+ (pict-height locked) + (pict-height closed) + (pict-height open) + (* 3 DELTA)))) + + (define width (pict-width bg)) + + (define (center base state y) + (define w (pict-width state)) + (define d (quotient (- width w) 2)) + (pin-over base d y state)) + + (define nx + (center + (center + (center + bg locked (/ DELTA 2)) + closed + (+ (/ DELTA 2) (pict-height locked) DELTA)) + open + (+ (/ DELTA 2) DELTA (pict-height locked) DELTA (pict-height closed)))) + + (define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + + (define l1 (add-labeled-arrow nx locked lb-find closed lt-find unlock)) + (define l2 (add-labeled-arrow l1 closed lb-find open lt-find push)) + (define l3 (add-labeled-arrow l2 open rt-find closed rb-find tick)) + (define l4 (add-labeled-arrow l3 closed rt-find locked rb-find lock)) + l4) + +(fsa "locked" "closed" "open" "unlock" "lock" "push" "time") +(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick") \ No newline at end of file diff --git a/collects/teachpack/2htdp/scribblings/nuworld.ss b/collects/teachpack/2htdp/scribblings/nuworld.ss new file mode 100644 index 0000000000..56a536a350 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/nuworld.ss @@ -0,0 +1,119 @@ +#lang slideshow + +(require slideshow/pict mred/mred) + +(define DELTA 80) +(define FT 12) + +(define txt + '("(big-bang World_0" + " (on-draw render WIDTH HEIGHT)" + " (on-tick tock RATE)" + " (on-mouse click)" + " (on-key react))" + )) + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) txt))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +(define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))) + (cc-superimpose t e)) + +(define False (text "FALSE" '() FT)) +(define True (text "TRUE" '() FT)) +(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False)))) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (define s (if b + (cc-superimpose + (rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t))) + t) + t)) + (define w + (cc-superimpose + s + (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + ;; add the boolean + (define bb (cc-superimpose (if b True False) BOOL)) + (define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done")) + (define scene (text "Scene" '() FT)) + (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene))))) + (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render")) + br) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define arrows + (vc-append (h-labeled-arrow "tock") + (h-labeled-arrow "click") + (h-labeled-arrow "react"))) + +(define state0 (make-state0 "World_0" #f)) +(define state1 (make-state0 "World_1" #f)) +(define dots (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))) +(define state2 (make-state0 "World_N-1" #f)) +(define stateN (make-state0 "World_N" #t)) +(define states (list state0 arrows state1 arrows dots arrows state2 arrows stateN)) + +(define bg (blank (+ (apply + (map pict-width states)) + DELTA #;(* (length states) DELTA)) + (+ (pict-height state0) DELTA))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- width w) 2)) + (pin-over base x d state)) + +(define width (pict-height bg)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states))) + +(define the-image (ct-superimpose xx Program)) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "nuworld.png" 'png) + +the-image diff --git a/collects/teachpack/2htdp/scribblings/server2.ss b/collects/teachpack/2htdp/scribblings/server2.ss new file mode 100644 index 0000000000..427a7c22ed --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/server2.ss @@ -0,0 +1,181 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 80) +(define FT 12) + +(define initialize "register") +(define proc-msg "process") + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) + (list (format "(universe ~a ~a)" initialize proc-msg))))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define message (text "Message" '() FT)) +(define (make-Message) + (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message))))) + +(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi)))) +(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) +(define MessageI (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) + +(define M (rb-superimpose Message (blank DELTA DELTA))) +(define K (rb-superimpose MessageK (blank DELTA DELTA))) +(define I (rb-superimpose MessageI (blank DELTA DELTA))) + +(define (make-arrows M lbl) + (define Tock (h-labeled-arrow lbl)) + (values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M))) + +(define-values (TockM arrowsR) (make-arrows M proc-msg)) +(define-values (TockK arrowsL) (make-arrows K proc-msg)) +(define-values (init arrows) (make-arrows I initialize)) + +(define state0 (make-state0 "Server_0" #f)) +(define state2 (make-state0 "Server_N-1" #f)) +(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT )))) +(define dots (vc-append + (blank (pict-width state2) (quotient (pict-height state2) 1)) + (text "..." '() FT) + (blank (pict-width state2) (* (pict-height state2))) + Univrs)) + +(define states (list arrows + state0 + arrowsL + dots + arrowsR + state2 + (h-labeled-arrow proc-msg))) + +(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- (pict-height bg) w) 2)) + (pin-over base x d state)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map pict-width states))) + +(define zz (ct-superimpose xx Program)) + +(require mred/mred) + +(define the-image + (lt-superimpose + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz MessageK)) + (define-values (tx ty) (ct-find zz MessageK)) + (define-values (ix iy) (ct-find zz MessageI)) + (define-values (jx jy) (cb-find zz MessageI)) + (define-values (sx sy) (lc-find zz Univrs)) + (define-values (tockx tocky) (lb-find zz TockK)) + (define-values (initx inity) (lb-find zz init)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (max rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (min sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + (set! dcp (make-object dc-path%)) + (set! cx (min sx jx)) + (set! cy (max sy jy)) + (send dc set-smoothing 'aligned) + (send dcp move-to jx jy) + (send dcp curve-to jx jy cx cy sx sy) + (send dc draw-path dcp) +;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + (set! tx ix) (set! ty iy) + (add-curve initx inity) + ;; --- + dc) + (pict-width zz) (pict-height zz)) + (lt-superimpose + zz + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz Message)) + (define-values (tx ty) (ct-find zz Message)) + (define-values (sx sy) (rc-find zz Univrs)) + (define-values (tockx tocky) (rb-find zz TockM)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (min rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (max sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + ;; --- + dc) + (pict-width zz) (pict-height zz))))) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "server2.png" 'png) + +the-image \ No newline at end of file diff --git a/collects/teachpack/2htdp/scribblings/shared.ss b/collects/teachpack/2htdp/scribblings/shared.ss new file mode 100644 index 0000000000..8bdc62c027 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/shared.ss @@ -0,0 +1,10 @@ +#lang scheme/base + +(require scribble/manual) + +(provide teachpack) + +(define (teachpack tp . name) + (apply title #:tag tp + `(,@name ": " ,(filepath (format "~a.ss" tp)) + ,(index (format "~a teachpack" tp))))) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl new file mode 100644 index 0000000000..c95ddeabc8 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -0,0 +1,1536 @@ +#lang scribble/doc + +@(require scribble/manual "shared.ss" + (for-label scheme ; lang/htdp-beginner + (only-in lang/htdp-beginner check-expect) + "../universe.ss" + teachpack/htdp/image)) +@(require scribble/struct) + +@(define (table* . stuff) + ;; (list paragraph paragraph) *-> Table + (define (flow* x) (make-flow (list x))) + (make-blockquote 'blockquote + (list + (make-table (make-with-attributes 'boxed + '((cellspacing . "6"))) + ;list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) + +@; ----------------------------------------------------------------------------- + +@title{Worlds and the Universe} + +@author{Matthias Felleisen} + +This @tt{universe.ss} teachpack implements and provides the functionality + for creating interactive, graphical programs that consist of plain + mathematical functions. We refer to such programs as @deftech{world} + programs. In addition, world programs can also become a part of a + @deftech{universe}, a collection of worlds that can exchange messages. + +The purpose of this documentation is to give experienced Schemers and HtDP + teachers a concise overview for using the library. The first part of the + documentation focuses on @tech{world} programs. Section @secref["world-example"] + presents an illustration of how to design such programs for a simple + domain; it is suited for a novice who knows how to design conditional + functions for symbols. The second half of the documentation focuses on + @tech{universe} programs: how it is managed via a server, how @tech{world} + programs register with the server, etc. The last two sections show how to + design a simple universe of two communicating worlds. + +@emph{Note}: For a quick and educational introduction to just worlds, see + @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How + to Design Programs, Second Edition: Prologue}. As of August 2008, we also + have a series of projects available as a small booklet on + @link["http://world.cs.brown.edu/"]{How to Design Worlds}. + +@declare-exporting["../universe.ss" #:use-sources (teachpack/htdp/image)] + +@; ----------------------------------------------------------------------------- + +@section[#:tag "basics"]{Basics} + +The teachpack assumes working knowledge of the basic image manipulation + primitives and supports several functions that require a special kind of + image, called a @deftech{scene}, , which are images whose pinholes are at + position @scheme[(0,0)]. For example, the teachpack displays only + @tech{scene}s in its canvas. + +@defproc[(scene? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @tech{scene}.} + +@defproc[(empty-scene [width natural-number/c] + [height natural-number/c]) + scene?]{ + creates a plain white, @scheme[width] x @scheme[height] @tech{scene}.} + +@defproc[(place-image [img image?] [x number?] [y number?] + [s scene?]) + scene?]{ + creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; + @scheme[(x,y)] are computer graphics coordinates, i.e., they count right and + down from the upper-left corner.} + +@; ----------------------------------------------------------------------------- +@section[#:tag "simulations"]{Simple Simulations} + +The simplest kind of animated @tech{world} program is a time-based + simulation, which is a series of scenes. The programmer's task is to + supply a function that creates a scene for each natural number. By handing + this function to the teachpack displays the simulation. + +@defproc[(run-simulation [create-image (-> natural-number/c scene)]) + true]{ + + opens a canvas and starts a clock that tick 28 times per second + seconds. Every time the clock ticks, drscheme applies + @scheme[create-image] to the number of ticks passed since this function + call. The results of these applications are displayed in the canvas. +} + +Example: +@schemeblock[ +(define (create-UFO-scene height) + (place-image UFO 50 height (empty-scene 100 100))) + +(define UFO + (overlay (circle 10 'solid 'green) + (rectangle 40 4 'solid 'green))) + +(run-simulation create-UFO-scene) +] + +@;----------------------------------------------------------------------------- +@section[#:tag "interactive"]{Interactions} + +The step from simulations to interactive programs is relatively + small. Roughly speaking, a simulation designates one function, + @emph{create-image}, as a handler for one kind of event: clock ticks. In + addition to clock ticks, @tech{world} programs can also deal with two + other kinds of events: keyboard events and mouse events. A keyboard event + is triggered when a computer user presses or releases a key on the + keyboard. Similarly, a mouse event is the movement of the mouse, a click + on a mouse button, the crossing of a boundary by a mouse movement, etc. + +Your program may deal with such events via the @emph{designation} of + @emph{handler} functions. Specifically, the teachpack provides for the + installation of three event handlers: @scheme[on-tick], @scheme[on-key], + and @scheme[on-mouse]. In addition, a @tech{world} program may specify a + @emph{draw} function, which is called every time your program should + visualize the current world, and a @emph{stop?} predicate, which is used + to determine when the @tech{world} program should shut down. + +Each handler function consumes the current state of the @tech{world} and + optionally a data representation of the event. It produces a new state of + the @tech{world}. + +The following picture provides an intuitive overview of the workings of a + @tech{world} program in the form of a state transition diagram. + +@image["nuworld.png"] + + The @scheme[big-bang] form installs @emph{World_0} as the initial + world. The handlers @emph{tock}, @emph{react}, and @emph{click} transform + one world into another one; each time an event is handled, @emph{done} is + used to check whether the world is final, in which case the program is + shut down; and finally, @emph{draw} renders each world as a scene, which + is then displayed on an external canvas. + +@deftech{World} : @scheme[any/c] The design of a world program demands that + you come up with a data definition of all possible states. We use + @tech{World} to refer to this collection of data, using a capital W to + distinguish it from the program. In principle, there are no constraints + on this data definition though it mustn't be an instance of the + @tech{Package} structure (see below). You can even keep it implicit, even + if this violates the Design Recipe. + +@defform/subs[#:id big-bang + #:literals + (on-tick on-draw on-key on-mouse on-receive + stop-when register record?) + (big-bang state-expr clause ...) + ([clause + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-key key-expr) + (on-mouse key-expr) + (on-draw draw-expr) + (on-draw draw-expr width-expr height-expr) + (stop-when stop-expr) + (record? boolean-expr) + (on-receive rec-expr) + (register IP-expr) + (register IP-expr name-expr) + ])]{ + + starts a @tech{world} program in the initial state specified with + @scheme[state-expr], which must of course evaluate to an element of + @tech{World}. Its behavior is specified via the handler functions + designated in the optional @scheme[spec] clauses, especially how the + @tech{world} program deals with clock ticks, with key events, with mouse + events, and eventually with messages from the universe; how it renders + itself as a scene; when the program must shut down; where to register the + world with a universe; and whether to record the stream of events. A world + specification may not contain more than one @scheme[on-tick], + @scheme[on-draw], or @scheme[register] clause.} + +@itemize[ + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{ + +tell DrScheme to call the @scheme[tick-expr] function on the current +world every time the clock ticks. The result of the call becomes the +current world. The clock ticks at the rate of 28 times per second.}} + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] + [rate-expr natural-number/c])]{ +tell DrScheme to call the @scheme[tick-expr] function on the current +world every time the clock ticks. The result of the call becomes the +current world. The clock ticks at the rate of @scheme[rate-expr].}} + +@item{An @tech{KeyEvent} represents key board events, e.g., keys pressed or + released. + +@deftech{KeyEvent} : @scheme[(or/c char? symbol?)] + +A @tech{Char} is used to signal that the user has hit an alphanumeric + key. A @tech{Symbol} denotes arrow keys or special events: + +@itemize[ + +@item{@scheme['left] is the left arrow,} + +@item{@scheme['right] is the right arrow,} + +@item{@scheme['up] is the up arrow,} + +@item{@scheme['down] is the down arrow, and} + +@item{@scheme['release] is the event of releasing a key.} +] + +@defproc[(key-event? [x any]) boolean?]{ + determines whether @scheme[x] is a @tech{KeyEvent}} + +@defproc[(key=? [x key-event?][y key-event?]) boolean?]{ + compares two @tech{KeyEvent} for equality} + +@defform[(on-key + [change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{ + tell DrScheme to call @scheme[change-expr] function on the current world and a + @tech{KeyEvent} for every keystroke the user of the computer makes. The result + of the call becomes the current world. + + Here is a typical key-event handler: +@(begin +#reader scribble/comment-reader +(schemeblock +(define (change w a-key) + (cond + [(key=? a-key 'left) (world-go w -DELTA)] + [(key=? a-key 'right) (world-go w +DELTA)] + [(char? a-key) w] ;; to demonstrate order-free checking + [(key=? a-key 'up) (world-go w -DELTA)] + [(key=? a-key 'down) (world-go w +DELTA)] + [else w])) +)) + } + The omitted, auxiliary function @emph{world-go} is supposed to consume a + world and a number and produces a world. +} + +@item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements + or mouse clicks, by the computer's user. + +@deftech{MouseEvent} : @scheme[(one-of/c 'button-down 'button-up 'drag 'move 'enter 'leave)] + +All @tech{MouseEvent}s are represented via symbols: +@itemize[ + +@item{@scheme['button-down] + signals that the computer user has pushed a mouse button down;} +@item{@scheme['button-up] + signals that the computer user has let go of a mouse button;} +@item{@scheme['drag] + signals that the computer user is dragging the mouse;} +@item{@scheme['move] + signals that the computer user has moved the mouse;} +@item{@scheme['enter] + signals that the computer user has moved the mouse into the canvas area; and} +@item{@scheme['leave] + signals that the computer user has moved the mouse out of the canvas area.} +] + +@defproc[(mouse-event? [x any]) boolean?]{ + determines whether @scheme[x] is a @tech{KeyEvent}} + +@defproc[(key=? [x mouse-event?][y mouse-event?]) boolean?]{ + compares two @tech{KeyEvent} for equality} + +@defform[(on-mouse + [clack-expr + (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{ + tell DrScheme to call @scheme[clack-expr] on the current world, the current + @scheme[x] and @scheme[y] coordinates of the mouse, and and a + @tech{MouseEvent} for every (noticeable) action of the mouse by the + computer user. The result of the call becomes the current world. + + Note: the computer's software doesn't really notice every single movement + of the mouse (across the mouse pad). Instead it samples the movements and + signals most of them.} +} + +@item{ + +@defform[(on-draw + [render-expr (-> (unsyntax @tech{World}) scene?)])]{ + + tell DrScheme to call the function @scheme[render-expr] whenever the + canvas must be drawn. The external canvas is usually re-drawn after DrScheme has + dealt with an event. Its size is determined by the size of the first + generated @tech{scene}.} + +@defform[(on-draw + [render-expr (-> (unsyntax @tech{World}) scene?)] + [width-expr natural-number/c] + [height-expr natural-number/c])]{ + + tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr] + canvas instead of one determine by the first generated @tech{scene}. +} +} + +@item{ + +@defform[(stop-when + [last-world? (-> (unsyntax @tech{World}) boolean?)])]{ + tell DrScheme to call the @scheme[last-world?] function whenever the canvas is + drawn. If this call produces @scheme[true], the world program is shut + down. Specifically, the clock is stopped; no more + tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to + the respective handlers. +}} + +@item{ + +@defform[(record? + [boolean-expr boolean?])]{ + tell DrScheme to record all events and to enable a replay of the entire + interaction. The replay action also generates one png image per scene and + an animated gif for the entire sequence. +}} +] + +The following example shows that @scheme[(run-simulation create-UFO-scene)] is +a short-hand for three lines of code: + +@(begin +#reader scribble/comment-reader +@schemeblock[ +(define (create-UFO-scene height) + (place-image UFO 50 height (empty-scene 100 100))) + +(define UFO + (overlay (circle 10 'solid 'green) + (rectangle 40 4 'solid 'green))) + +;; (run-simulation create-UFO-scene) is short for: +(big-bang 0 + (on-tick add1) + (on-draw create-UFO-scene)) +]) + +Exercise: Add a condition for stopping the flight of the UFO when it +reaches the bottom. + +@; ----------------------------------------------------------------------------- +@section[#:tag "scenes-and-images"]{Scenes and Images} + +For the creation of scenes from the world, use the functions from +@secref["image"]. The teachpack adds the following two functions, which +are highly useful for creating scenes. + +@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{ + creates a @scheme[width] by @scheme[height] rectangle, solid or outlined as specified by + @scheme[solid-or-filled] and colored according to @scheme[c], with a pinhole at the upper left + corner.} + +@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{ + creates a scene by placing a line of color @scheme[c] from @scheme[(x0,y0)] to + @scheme[(x1,y1)] into @scheme[scene]; + @scheme[(x,y)] are computer graphics coordinates. + In contrast to the @scheme[add-line] function, @scheme[scene+line] cuts + off those portions of the line that go beyond the boundaries of + the given @scheme[s].} + +@; ----------------------------------------------------------------------------- +@section[#:tag "world-example"]{A First Sample World} + +This section uses a simple example to explain the design of worlds. The + first subsection introduces the sample domain, a door that closes + automatically. The second subsection is about the design of @tech{world} + programs in general, the remaining subsections implement a simulation of + the door. + +@subsection{Understanding a Door} + +Say we wish to design a @tech{world} program that simulates the working of + a door with an automatic door closer. If this kind of door is locked, you + can unlock it with a key. While this doesn't open the door per se, it is + now possible to do so. That is, an unlocked door is closed and pushing at + the door opens it. Once you have passed through the door and you let go, + the automatic door closer takes over and closes the door again. When a + door is closed, you can lock it again. + +Here is a diagram that translates our words into a graphical + representation: + +@image["door-real.png"] + +Like the picture of the general workings of a @tech{world} program, this + diagram displays a so-called "state machine". The three circled words are + the states that our informal description of the door identified: locked, + closed (and unlocked), and open. The arrows specify how the door can go + from one state into another. For example, when the door is open, the + automatic door closer shuts the door as time passes. This transition is + indicated by the arrow labeled "time passes." The other arrows represent + transitions in a similar manner: + +@itemize[ + +@item{"push" means a person pushes the door open (and let's go);} + +@item{"lock" refers to the act of inserting a key into the lock and turning +it to the locked position; and} + +@item{"unlock" is the opposite of "lock".} + +] + +@; ----------------------------------------------------------------------------- +@subsection{Hints on Designing Worlds} + +Simulating any dynamic behavior via a @tech{world} program demands two + different activities. First, we must tease out those portions of our + domain that change over time or in reaction to actions, and we must + develop a data representation @deftech{D} for this information. Keep in + mind that a good data definition makes it easy for readers to map data to + information in the real world and vice versa. For all others aspects of + the world, we use global constants, including graphical or visual + constants that are used in conjunction with the rendering operations. + +Second, we must translate the actions in our domain---the arrows in the + above diagram---into interactions with the computer that the universe + teachpack can deal with. Once we have decided to use the passing of time + for one aspect, key presses for another, and mouse movements for a third, + we must develop functions that map the current state of the + world---represented as data from @tech{D}---into the next state of the + world. Put differently, we have just created a wish list with three + handler functions that have the following general contract and purpose + statements: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; tick : @tech{D} -> @tech{D} +;; deal with the passing of time +(define (tick w) ...) + +;; click : @tech{D} @emph{Number} @emph{Number} @tech{MouseEvent} -> @tech{D} +;; deal with a mouse click at @emph{(x,y)} of kind @emph{me} +;; in the current world @emph{w} +(define (click w x y me) ...) + +;; control : @tech{D} @tech{KeyEvent} -> @tech{D} +;; deal with a key event (symbol, char) @emph{ke} +;; in the current world @emph{w} +(define (control w ke) ...) +)) + +That is, the contracts of the various handler designations dictate what the + contracts of our functions are, once we have defined how to represent the + domain with data in our chosen language. + +A typical program does not use all three of these functions. Furthermore, + the design of these functions provides only the top-level, initial design + goal. It often demands the design of many auxiliary functions. The + collection of all these functions is your @tech{world} program. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Data} + +Our first and immediate goal is to represent the world as data. In this + specific example, the world consists of our door and what changes about + the door is whether it is locked, unlocked but closed, or open. We use + three symbols to represent the three states: + +@deftech{SD} : state of door + +@(begin +#reader scribble/comment-reader +(schemeblock +;; The state of the door (SD) is one of: +;; -- @scheme['locked] +;; -- @scheme['closed] +;; -- @scheme['open] +)) + +Symbols are particularly well-suited here because they directly express + the state of the door. + +Now that we have a data definition, we must also decide which computer + interactions should model the various actions on the door. Our pictorial + representation of the door's states and transitions, specifically the + arrow from @tt{open} to @tt{closed} suggests the use of a function that + simulates time. For the other three arrows, we could use either keyboard + events or mouse clicks or both. Our solution uses three keystrokes: + @scheme[#\u] for unlocking the door, @scheme[#\l] for locking it, and + @scheme[#\space] for pushing it open. We can express these choices + graphically by translating the above state-machine diagram from the world + of information into the world of data. + +@table*[ @list[ @t{@image["door-sim.png"]} @t{@image["door-real.png"]}] ] + +For completeness, we have repeated the original diagram on the right so +that you can see which computer interaction corresponds to which domain +action. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Functions} + +Our analysis and data definition leaves us with three functions to design: + +@itemize[ + +@item{@emph{automatic-closer}, which closes the time during one tick;} + +@item{@emph{door-actions}, which manipulates the time in response to +pressing a key; and} + +@item{@emph{render}, which translates the current state of the door into +a visible scene.} + +] + +Let's start with @emph{automatic-closer}. Substituting @tech{SD} for +@tech{D} and @emph{automatic-closer} for @emph{tick}, we get its contract, +and it is easy to refine the purpose statement, too: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : @tech{SD} -> @tech{SD} +;; closes an open door over the period of one tick +(define (automatic-closer state-of-door) ...) +)) + + Making up examples is trivial when the world can only be in one of three + states: + +@table*[ + @list[@t{ given state } @t{ desired state }] + @list[@t{ @scheme['locked] } @t{ @scheme['locked] }] + @list[@t{ @scheme['closed] } @t{ @scheme['closed] }] + @list[@t{ @scheme['open] } @t{ @scheme['closed] }] +] + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : @tech{SD} -> @tech{SD} +;; closes an open door over the period of one tick + +(check-expect (automatic-closer 'locked) 'locked) +(check-expect (automatic-closer 'closed) 'closed) +(check-expect (automatic-closer 'open) 'closed) + +(define (automatic-closer state-of-door) ...) +)) + + The template step demands a conditional with three clauses: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) ...] + [(symbol=? 'closed state-of-door) ...] + [(symbol=? 'open state-of-door) ...])) +)) + + The examples basically dictate what the outcomes of the three cases must + be: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) 'locked] + [(symbol=? 'closed state-of-door) 'closed] + [(symbol=? 'open state-of-door) 'closed])) +)) + + Don't forget to run the example-tests. + +For the remaining three arrows of the diagram, we design a function that + reacts to the three chosen keyboard events. As mentioned, functions that + deal with keyboard events consume both a world and a keyevent: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; door-actions : @tech{SD} @tech{KeyEvent} -> @tech{SD} +;; key events simulate actions on the door +(define (door-actions s k) ...) +)) + +@table*[ + @list[@t{ given state } @t{ given keyevent } @t{ desired state }] + +@list[ @t{ @scheme['locked] } @t{ @scheme[#\u]} @t{@scheme['closed]}] +@list[ @t{ @scheme['closed] } @t{ @scheme[#\l]} @t{@scheme['locked]}] +@list[ @t{ @scheme['closed] } @t{ @scheme[#\space]} @t{@scheme['open] }] +@list[ @t{ @scheme['open] } @t{ --- } @t{@scheme['open] }]] + + The examples combine what the above picture shows and the choices we made + about mapping actions to keyboard events. + +From here, it is straightforward to turn this into a complete design: + +@schemeblock[ +(define (door-actions s k) + (cond + [(and (symbol=? 'locked s) (key=? #\u k)) 'closed] + [(and (symbol=? 'closed s) (key=? #\l k)) 'locked] + [(and (symbol=? 'closed s) (key=? #\space k)) 'open] + [else s])) + +(check-expect (door-actions 'locked #\u) 'closed) +(check-expect (door-actions 'closed #\l) 'locked) +(check-expect (door-actions 'closed #\space) 'open) +(check-expect (door-actions 'open 'any) 'open) +(check-expect (door-actions 'closed 'any) 'closed) +] + +Last but not least we need a function that renders the current state of the +world as a scene. For simplicity, let's just use a large text for this +purpose: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; render : @tech{SD} -> @tech{scene} +;; translate the current state of the door into a large text +(define (render s) + (text (symbol->string s) 40 'red)) + +(check-expect (render 'closed) (text "closed" 40 'red)) +)) + The function @scheme[symbol->string] translates a symbol into a string, + which is needed because @scheme[text] can deal only with the latter, not + the former. A look into the language documentation revealed that this + conversion function exists, and so we use it. + +Once everything is properly designed, it is time to @emph{run} the +program. In the case of the universe teachpack, this means we must specify +which function takes care of tick events, key events, and drawing: + +@schemeblock[ +(big-bang 'locked + (on-tick automatic-closer) + (on-key door-actions) + (on-draw render)) +] + +Now it's time for you to collect the pieces and run them in DrScheme to see +whether it all works. + +Exercise: Design a data representation that closes the door over two (or +three or more) clock ticks instead of one. + +@; ----------------------------------------------------------------------------- +@section[#:tag "world2"]{The World is not Enough} + +The library facilities covered so far are about designing individual + programs with interactive graphical user interfaces (simulations, + animations, games, etc.). In this section, we introduce capabilities for + designing a distributed program, which is really a number of programs that + coordinate their actions in some fashion. Each of the individual programs + may run on any computer in the world (as in our planet and the spacecrafts + that we sent out), as long as it is on the internet and as long as the + computer allows the program to send and receive messages (via TCP). We + call this arrangement a @tech{universe} and the program that coordinates + it all a @emph{universe server} or just @tech{server}. + +This section explains what messages are, how to send them from a + @tech{world} program, how to receive them, and how to connect a + @tech{world} program to a @tech{universe}. + +@; ----------------------------------------------------------------------------- + +@subsection{Messages} + +After a world program has become a part of a universe, it may send messages + and receive them. In terms of data, a message is just an + @tech{S-expression}. + +@deftech{S-expression} An S-expression is roughly a nested list of basic +data; to be precise, an S-expression is one of: + +@itemize[ + @item{a string,} + @item{a symbol,} + @item{a number,} + @item{a boolean,} + @item{a char, or} + @item{a list of S-expressions.} +] +Note the last clause includes @scheme[empty] of course. + +@defproc[(sexp? [x any/c]) boolean?]{ + determines whether @scheme[x] is an @tech{S-expression}.} + +@subsection{Sending Messages} + +Each world-producing callback in a world program---those for handling clock + tick events, keyboard events, and mouse events---may produce a + @tech{Package} in addition to just a @tech{World}. + +@deftech{Package} represents a pair consisting of a @tech{World} (state) + and a message from a @tech{world} program to the @tech{server}. Because + programs only send messages via @tech{Package}, the teachpack does not + provide the selectors for the structure, only the constructor and a + predicate. + +@defproc[(package? [x any/c]) boolean?]{ + determine whether @scheme[x] is a @deftech{Package}.} + +@defproc[(make-package [w any/c][m sexp?]) package?]{ + create a @tech{Package} from a @tech{World} and an @tech{S-expression}.} + +As mentioned, all event handlers may return @tech{World}s or @tech{Package}s; +here are the revised specifications: + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ +} + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] + [rate-expr natural-number/c])]{ +} + +@defform[(on-key + [change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ +} + +@defform[(on-mouse + [clack + (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) + (or/c (unsyntax @tech{World}) package?))])]{ +} + +If one of these event handlers produces a @tech{Package}, the content of the world + field becomes the next world and the message field specifies what the + world sends to the universe. This distinction also explains why the data + definition for @tech{World} may not include a @tech{Package}. + +@subsection{Connecting with the Universe} + +Messages are sent to the universe program, which runs on some computer in + the world. The next section is about constructs for creating such a universe + server. For now, we just need to know that it exists and that it is the recipient + of messages. + +@deftech{IP} @scheme[string?] + +Before a world program can send messages, it must register with the + server. Registration must specify the internet address of the computer on which + the server runs, also known as an @tech{IP} address or a host. Here a + @tech{IP} address is a string of the right shape, e.g., @scheme["192.168.1.1"] + or @scheme["www.google.com"]. + +@defthing[LOCALHOST string?]{the @tech{IP} of your computer. Use it while you + are developing a distributed program, especially while you are + investigating whether the participating world programs collaborate in an + appropriate manner. This is called @emph{integration testing} and differs + from unit testing quite a bit.} + +A @scheme[big-bang] description of a world program that wishes to communicate +with other programs must contain a @scheme[register] clause of one of the +following shapes: + +@itemize[ + +@item{ +@defform[(register [ip-expr string?])]{ + connect this world to a universe server at the specified @scheme[ip-expr] + address and set up capabilities for sending and receiving messages.} +} + +@item{ +@defform[(register [ip-expr string?] + [name-expr (or/c symbol? string?)])]{ + connect this world to a universe server @emph{under a specific} @scheme[name-expr].} +} + +] + +When a world program registers with a universe program and the universe program +stops working, the world program stops working, too. + +@subsection{Receiving Messages} + +Finally, the receipt of a message from the server is an event, just like + tick events, keyboard events, and mouse events. Dealing with the receipt of a + message works exactly like dealing with any other event. DrScheme + applies the event handler that the world program specifies; if there is no + clause, the message is discarded. + +The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handler + for message receipts. + +@defform[(on-receive + [receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{ + tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current + @tech{World} and the received message. The result of the call becomes the current + @tech{World}. + + Because @scheme[receive-expr] is (or evaluates to) a world-transforming + function, it too can produce a @tech{Package} instead of just a + @tech{World}. If the result is a @tech{Package}, its message content is + sent to the @tech{server}.} + +The diagram below summarizes the extensions of this section in graphical form. + +@image["universe.png"] + +A registered world program may send a message to the universe server + at any time by returning a @tech{Package} from an event handler. The + message is transmitted to the server, which may forward it to some + other world program as given or in some massaged form. The arrival of a + message is just another event that a world program must deal with. Like + all other event handlers @emph{receive} accepts a @tech{World} and some + auxiliary arguments (a message in this case) and produces a + @tech{World} or a @tech{Package}. + +When messages are sent from any of the worlds to the universe or vice versa, + there is no need for the sender and receiver to synchronize. Indeed, a sender + may dispatch as many messages as needed without regard to whether the + receiver has processed them yet. The messages simply wait in queue until + the receiving @tech{server} or @tech{world} program take care of them. + +@; ----------------------------------------------------------------------------- + +@section[#:tag "universe-server"]{The Universe Server} + +A @deftech{server} is the central control program of a @tech{universe} and + deals with receiving and sending of messages between the world + programs that participate in the @tech{universe}. Like a @tech{world} + program, a server is a program that reacts to events, though to different + events. There are two primary kinds of events: when a new @tech{world} + program joins the @tech{universe} that the server controls and when a + @tech{world} sends a message. + +The teachpack provides a mechanism for designating event handlers for + servers that is quite similar to the mechanism for describing @tech{world} + programs. Depending on the designated event handlers, the server takes on + distinct roles: + +@itemize[ + +@item{A server may be a "pass through" channel between two worlds, in which case + it has no other function than to communicate whatever message it receives + from one world to the other, without any interference.} + +@item{A server may enforce a "back and forth" protocol, i.e., it may force two + (or more) worlds to engage in a civilized tit-for-tat exchange. Each + world is given a chance to send a message and must then wait + to get a reply before it sends anything again.} + +@item{A server may play the role of a special-purpose arbiter, e.g., the referee + or administrator of a game. It may check that each world "plays" by the rules, + and it administrate the resources of the game.} + +] + +As a matter of fact, a pass-through @tech{server} can become basically +invisible, making it appear as if all communication goes from peer +@tech{world} to peer in a @tech{universe}. + +This section first introduces some basic forms of data that the + @tech{server} uses to represent @tech{world}s and other matters. Second, + it explains how to describe a server program. + +@; ----------------------------------------------------------------------------- +@subsection{Worlds and Messages} + +Understanding the server's event handling functions demands three + concepts. + +@itemize[ + +@item{The @tech{server} and its event handlers must agree on a + data representation of the @tech{world}s that participate in the + universe. + +@defproc[(world? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{world}. Because the universe server + represents worlds via structures that collect essential information about + the connections, the teachpack does not export any constructor or selector + functions on worlds.} + +@defproc[(world=? [u world?][v world?]) boolean?]{ + compares two @emph{world}s for equality.} + +@defthing[world1 world?]{a world for testing your programs} +@defthing[world2 world?]{another world for testing your programs} +@defthing[world3 world?]{and a third one} + +The three sample worlds are provided so that you can test your functions +for universe programs. For example: + +@schemeblock[ +(check-expect (world=? world1 world2) false) +(check-expect (world=? world2 world2) true) +] +} + +@item{A @emph{mail} represents a message from an event handler to a +world. The teachpack provides only a predicate and a constructor for these +structures: + +@defproc[(mail? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{mail}.} + +@defproc[(make-mail [to world?] [content sexp?]) mail?]{ + creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.} +} + +@item{Each event handler produces a @emph{bundle}, which is a structure +that contains the @tech{server}'s state and a list of mails to other +worlds. Again, the teachpack provides only the predicate and a constructor: + +@defproc[(bundle? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{bundle}.} + +@defproc[(make-bundle [state any/c] [mails (listof mail?)]) bundle?]{ + creates a @emph{bundle} from a piece of data that represents a server + state and a list of mails.} + +} +] + +@; ----------------------------------------------------------------------------- +@subsection{Universe Descriptions} + +A @tech{server} keeps track of information about the @tech{universe} that + it manages. Of course, what kind of information it tracks and how it is + represented depends on the situation and the programmer, just as with + @tech{world} programs. + +@deftech{Universe} @scheme[any/c] represent the server's state For running +@tech{universe}s, the teachpack demands that you come up with a data +definition for (your state of the) @tech{server}. Any piece of data can +represent the state. We just assume that you introduce a data definition +for the possible states and that your transformation functions are designed +according to the design recipe for this data definition. + +The @tech{server} itself is created with a description that includes the + first state and a number of clauses that specify functions for dealing + with @tech{universe} events. + +@defform/subs[#:id universe + #:literals + (start stop max-worlds on-new on-msg on-tick + on-disconnect to-string) + (universe state-expr clause ...) + ([clause + (on-new new-expr) + (on-msg msg-expr) + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-disconnect dis-expr) + (to-string render-expr) + ])]{ + +creates a server with a given state, @scheme[state-expr]. The +behavior is specified via handler functions through mandatory and optional +@emph{clause}s. These functions govern how the server deals with the +registration of new worlds, how it disconnects worlds, how it sends +messages from one world to the rest of the registered worlds, and how it +renders its current state as a string.} + +A @scheme[universe] expression starts a server. Visually it opens + a console window on which you can see that worlds join, which messages are + received from which world, and which messages are sent to which world. For + convenience, the console also has two buttons: one for shutting down a + universe and another one for re-starting it. The latter functionality is + especially useful during the integration of the various pieces of a + distributed program. + + +Now it is possible to explain the clauses in a @scheme[universe] server +description. Two of them are mandatory: + +@itemize[ + +@item{ + @defform[(on-new + [new-expr (-> (unsyntax @tech{Universe}) world? + (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ + tell DrScheme to call the function @scheme[new-expr] every time another world joins the + universe.}} + +@item{ + @defform[(on-msg + [msg-expr (-> (unsyntax @tech{Universe}) world? sexp? + (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ + + tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world + that sent the message, and the message itself. The handler must produce a state of the + universe and a list of mails.} + } +] + +The following picture provides a graphical overview of the server's workings. + +@image["server2.png"] + +In addition to the mandatory handlers, a program may wish to add some +optional handlers: + +@itemize[ + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ + tell DrScheme to apply @scheme[tick-expr] to the current state of the + universe. The handler is expected to produce a bundle of the new state of + the universe and a list of mails. + } + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)] + [rate-expr natural-number/c])]{ + tell DrScheme to apply @scheme[tick-expr] as above but use the specified + clock tick rate instead of the default. + } +} + +@item{ + @defform[(on-disconnect + [dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{ + tell DrScheme to invoke @scheme[dis-expr] every time a participating + @tech{world} drops its connection to the server. The first argument is the + current state of the universe; the second one is the world that got + disconnected. + } +} + +@item{ + @defform[(to-string + [render-expr (-> (unsyntax @tech{Universe}) string?)])]{ + tell DrScheme to render the state of the universe after each event and to + display this string in the universe console. + } +} + +] + +@; ----------------------------------------------------------------------------- +@section[#:tag "universe-sample"]{A First Sample Universe} + +This section uses a simple example to explain the design of a universe, + especially its server and some participating worlds. The first subsection + explains the example, the second introduces the general design plan for + such universes. The remaining sections present the full-fledged solution. + +@subsection{Two Ball Tossing Worlds} + +Say we want to represent a universe that consists of a number of worlds and + that gives each world a "turn" in a round-robin fashion. If a world is + given its turn, it displays a ball that ascends from the bottom of a + canvas to the top. It relinquishes its turn at that point and the server + gives the next world a turn. + +Here is an image that illustrates how this universe would work if two + worlds participated: + +@image["balls.gif"] + + The two @tech{world} programs could be located on two distinct computers + or on just one. A @tech{server} mediates between the two worlds, including + the initial start-up. + +@; ----------------------------------------------------------------------------- +@subsection{Hints on Designing Universes} + +The first step in designing a @tech{universe} is to understand the + coordination of the @tech{world}s from a global perspective. To some + extent, it is all about knowledge and the distribution of knowledge + throughout a system. We know that the @tech{universe} doesn't exist until + the server starts and the @tech{world}s are joining. Because of the nature + of computers and networks, however, we may assume little else. Our network + connections ensure that if some @tech{world} sends two messages in some + order, they arrive in the same order at the server. In contrast, it is + generally impossible to ensure whether one world joins before another or + whether a message from one world gets to the server before another world's + message gets there. It is therefore the designer's task to establish a + protocol that enforces a certain order onto a universe and this activity + is called @emph{protocol design}. + +From the perspective of the @tech{universe}, the design of a protocol is + about the design of data representations for tracking universe information + in the server and the participating worlds and the design of a data + representation for messages. As for the latter, we know that they must be + @tech{S-expression}s, but of course @tech{world} programs don't send all + kinds of @tech{S-expression}s. The data definitions for messages must + therefore select a subset of suitable @tech{S-expression}s. As for the + state of the server and the worlds, they must reflect how they currently + relate to the universe. Later, when we design their "local" behavior, we + may add more components to their state space. + +In summary, the first step of a protocol design is to introduce: + +@itemize[ + +@item{a data definition for the information about the universe that the +server tracks, call it @tech{Universe};} + +@item{a data definition for the world(s) about their current relationship +to the universe;} + +@item{data definitions for the messages that are sent from the server to +the worlds and vice versa. Let's call them @deftech{MsgS2W} for messages +from the server to the worlds and @deftech{MsgW2S} for the other direction; +in the most general case you may need one pair per world.} +] + +If all the worlds exhibit the same behavior over time, a single data +definition suffices for step 2. If they play different roles, we may need +one data definition per world. + +Of course, as you define these collections of data always keep in mind what +the pieces of data mean, what they represent from the universe's +perspective. + +The second step of a protocol design is to figure out which major + events---the addition of a world to the universe, the arrival of a message + at the server or at a world---to deal with and what they imply for the + exchange of messages. Conversely, when a server sends a message to a + world, this may have implications for both the state of the server and the + state of the world. A good tool for writing down these agreements is an + interaction diagram. + +(interaction diagrams: tbd) + +The design of the protocol, especially the data definitions, have direct +implications for the design of event handling functions. For example, in +the server we may wish to deal with two kinds of events: the joining of a +new world and the receipt of a message from one of the worlds. This +translates into the design of two functions with the following headers, + +@(begin +#reader scribble/comment-reader +(schemeblock +;; @tech{Universe} World -> (make-bundle @tech{Universe} [Listof mail?]) +;; create new @tech{Universe} when world w is joining the universe, +;; which is in state s; also send mails as needed +(define (add-world s w) ...) + +;; @tech{Universe} World MsgW2U -> (make-bundle @tech{Universe} [Listof mail?]) +;; create new @tech{Universe} when world w is sending message m +;; to universe in state s; also send mails as needed +(define (process s p m) ...) +)) + +Note how both functions return a bundle. + +Finally, we must also decide how the messages affect the states of the + worlds; which of their callback may send messages and when; and what to do + with the messages a world receives. Because this step is difficult to + explain in the abstract, we move on to the protocol design for the + universe of ball worlds. + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball Universe} + +Running the ball @tech{universe} has a simple overall goal: to ensure that at any + point in time, one @tech{world} is active and all others are passive. The active + @tech{world} displays a moving ball, and the passive @tech{world}s should display + something, anything that indicates that it is some other @tech{world}'s turn. + +As for the server's state, it must obviously keep track of all @tech{world}s that + joined the @tech{universe}, and it must know which one is active and which ones + are passive. Of course, initially the @tech{universe} is empty, i.e., there are + no @tech{world}s and, at that point, the server has nothing to track. + +While there are many different useful ways of representing such a @tech{universe}, + we choose to introduce @tech{Universe} as a list of @tech{world}s, and we + interpret non-empty lists as those where the first @tech{world} is active and the + remainder are the passive @tech{world}s. As for the two possible events, +@itemize[ + +@item{it is natural to add new @tech{world}s to the end of the list; and} + +@item{it is natural to move an active @tech{world} that relinquishes its turn to +the end of the list, too.} +] + +The server should send messages to the first @tech{world} of its list as + long as it wishes this @tech{world} to remain active. In turn, it should + expect to receive messages only from this one active @tech{world} and no + other @tech{world}. The content of these two messages is nearly irrelevant + because a message from the server to a @tech{world} means that it is the + @tech{world}'s turn and a message from the @tech{world} to the server + means that the turn is over. Just so that we don't confuse ourselves, we + use two distinct symbols for these two messages: +@itemize[ +@item{A @defterm{GoMessage} is @scheme['it-is-your-turn].} +@item{A @defterm{StopMessage} is @scheme['done].} +] + +From the @tech{universe}'s perspective, each @tech{world} is in one of two states: +@itemize[ +@item{A passive @tech{world} is @emph{resting}. We use @scheme['resting] for this state.} +@item{An active @tech{world} is not resting. We delay choosing a representation +for this part of a @tech{world}'s state until we design its "local" behavior.} +] + It is also clear that an active @tech{world} may receive additional messages, + which it may ignore. When it is done with its turn, it will send a + message. + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball Server} + +The preceding subsection dictates that our server program starts like this: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; teachpack: universe.ss + +;; Universe is [Listof world?] +;; StopMessage is 'done. +;; GoMessage is 'it-is-your-turn. +]) + + The design of a protocol has immediate implications for the design of the + event handling functions of the server. Here we wish to deal with two + events: the appearance of a new world and the receipt of a message. Based + on our data definitions and based on the general contracts of the event + handling functions spelled out in this documentation, we get two functions + for our wish list: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; Result is (make-bundle Universe (list (make-mail world? GoMessage))) + +;; Universe world? -> Result +;; add world w to the universe, when server is in state u +(define (add-world u w) ...) + +;; Universe world? StopMessage -> Result +;; world w sent message m when server is in state u +(define (switch u w m) ...) +]) + +Although we could have re-used the generic contracts from this +documentation, we also know from our protocol that our server sends a +message to exactly one world. For this reason, both functions return the +same kind of result: a bundle that contains the new state of the server +(@tech{Universe}) and a list that contains a single mail. These contracts +are just refinements of the generic ones. (A type-oriented programmer would +say that the contracts here are subtypes of the generic ones.) + +The second step of the design recipe calls for functional examples: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; an obvious example for adding a world: +(check-expect + (add-world '() world1) + (make-bundle (list world1) + (list (make-mail world1 'it-is-your-turn)))) + +;; an example for receiving a message from the active world: +(check-expect + (switch (list world1 world2) world1 'it-is-your-turn) + (make-bundle (list world2 world1) + (list (make-mail world2 'it-is-your-turn)))) +]) + + Note that our protocol analysis dictates this behavior for the two + functions. Also note how we use @scheme[world1], @scheme[world2], and + @scheme[world3] because the teachpack applies these event handlers to real + worlds. + +Exercise: Create additional examples for the two functions based on our +protocol. + +The protocol tells us that @emph{add-world} just adds the given +@emph{world} structure---recall that this a data representation of the +actual @tech{world} program---to the @tech{Universe} and then sends a +message to the first world on this list to get things going: + +@(begin +#reader scribble/comment-reader +[schemeblock +(define (add-world univ wrld) + (local ((define univ* (append univ (list wrld)))) + (make-bundle univ* + (list (make-mail (first univ*) 'it-is-your-turn))))) +]) + +Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to +create a mail to @scheme[(first univ*)]. Of course, this same reasoning +also implies that if @emph{univ} isn't empty, its first element is an +active world and has already received such a message. + +Similarly, the protocol says that when @emph{switch} is invoked because a + @tech{world} program sends a message, the data representation of the + corresponding world is moved to the end of the list and the next world on + the (resulting) list is sent a message: + +@(begin +#reader scribble/comment-reader +[schemeblock +(define (switch univ wrld m) + (local ((define univ* (append (rest univ) (list (first univ))))) + (make-bundle univ* (list (make-mail (first univ*) 'it-is-your-turn))))) +]) + + As before, appending the first world to the end of the list guarantees + that there is at least this one world on the next @tech{Universe} + (state). It is therefore acceptable to create a mail for this world. + +Exercise: The function definition simply assumes that @emph{wrld} is + @scheme[world=?] to @scheme[(first univ)] and that the received message + @emph{m} is @scheme['it-is-your-turn]. Modify the function definition so that it + checks these assumptions and raises an error signal if either of them is + wrong. Start with functional examples. If stuck, re-read the section on + checked functions from HtDP. (Note: in a @tech{universe} it is quite + possible that a program registers with a @tech{server} but fails to stick + to the agreed-upon protocol. How to deal with such situations properly + depends on the context. For now, stop the @tech{universe} at this point, + but consider alternative solutions, too.) + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball World} + +The final step is to design the ball @tech{world}. Recall that each world + is in one of two possible states: active or passive. The second kind of + @tech{world} moves a ball upwards, decreasing the ball's @emph{y} + coordinate; the first kind of @tech{world} displays something that says + it's someone else's turn. Assuming the ball always moves along a vertical + line and that the vertical line is fixed, the state of the world is an + enumeration of two cases: + +@(begin #reader scribble/comment-reader +(schemeblock +;; teachpack: universe.ss + +;; World is one of +;; -- Number %% representing the @emph{y} coordinate +;; -- @scheme['resting] + +(define WORLD0 'resting) +)) + The definition says that initially a @tech{world} is passive. + +The communication protocol and the refined data definition of @tech{World} + imply a number of contract and purpose statements: + +@(begin +#reader scribble/comment-reader +(schemeblock + +;; World GoMessage -> World or (make-package World StopMessage) +;; make sure the ball is moving +(define (receive w n) ...) + +;; World -> World or (make-package World StopMessage) +;; move this ball upwards for each clock tick +;; or stay @scheme['resting] +(define (move w) ...) + +;; World -> Scene +;; render the world as a scene +(define (render w) ...) +)) + +Let's design one function at a time, starting with @emph{receive}. Since + the protocol doesn't spell out what @emph{receive} is to compute, let's + create a good set of functional examples, exploiting the structure of the + data organization of @tech{World}: + +@(begin +#reader scribble/comment-reader +(schemeblock +(check-expect (receive 'resting 'it-is-your-turn) HEIGHT) +(check-expect (receive (- HEIGHT 1) 'it-is-your-turn) ...) +)) + +Since there are two kinds of states, we make up at least two kinds of + examples: one for a @scheme['resting] state and another one for a numeric + state. The dots in the result part of the second unit test reveal the + first ambiguity; specifically it isn't clear what the result should be + when an active @tech{world} receives another message to activate itself. The + second ambiguity shows up when we study additional examples, which are + suggested by our approach to designing functions on numeric intervals + (HtDP, section 3). That is we should consider the following three inputs + to @emph{receive}: + +@itemize[ +@item{@scheme[HEIGHT] when the ball is at the bottom of the scene;} +@item{@scheme[(- HEIGHT 1)] when the ball is properly inside the scene; and} +@item{@scheme[0] when the ball has hit the top of the scene.} +] + + In the third case the function could produce three distinct results: + @scheme[0], @scheme['resting], or @scheme[(make-package 'resting + 'done)]. The first leaves things alone; the second turns the active @tech{world} + into a resting one; the third does so, too, and tells the universe about + this switch. + +We choose to design @emph{receive} so that it ignores the message and + returns the current state of an active @tech{world}. This ensures that the ball + moves in a continuous fashion and that the @tech{world} remains active. + +Exercise: One alternative design is to move the ball back to the bottom of +the scene every time @scheme['it-is-your-turn] is received. Design this function, too. + +@(begin +#reader scribble/comment-reader +(schemeblock + +(define (receive w m) + (cond + [(symbol=? 'resting w) HEIGHT] + [else w])) +)) + + Our second function to design is @emph{move}, the function that computes + the ball movement. We have the contract and the second step in the design + recipe calls for examples: + +@(begin +#reader scribble/comment-reader +(schemeblock +; World -> World or @scheme[(make-package 'resting 'done)] +; move the ball if it is flying + +(check-expect (move 'resting) 'resting) +(check-expect (move HEIGHT) (- HEIGHT 1)) +(check-expect (move (- HEIGHT 1)) (- HEIGHT 2)) +(check-expect (move 0) (make-package 'resting 'done)) + +(define (move x) ...) +)) + + Following HtDP again, the examples cover four typical situations: + @scheme['resting], two end points of the specified numeric interval, and + one interior point. They tell us that @emph{move} leaves a passive @tech{world} + alone and that it otherwise moves the ball until the @emph{y} coordinate + becomes @scheme[0]. In the latter case, the result is a package that + renders the @tech{world} passive and tells the server about it. + + Turning these thoughts into a complete definition is straightforward now: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (move x) + (cond + [(symbol? x) x] + [(number? x) (if (<= x 0) (make-package 'resting 'done) (sub1 x))])) +)) + + Exercise: what could happen if we had designed @emph{receive} so that it + produces @scheme['resting] when the state of the world is @scheme[0]? Use + your answer to explain why you think it is better to leave this kind of + state change to the tick event handler instead of the message receipt + handler? + +Finally, here is the third function, which renders the state as a scene: + +@(begin +#reader scribble/comment-reader +(schemeblock +; World -> Scene +; render the state of the world as a scene + +(check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT)) +(check-expect (render 'resting) + (place-image (text "resting" 11 'red) 10 10 MT)) + +(define (render name) + (place-image + (text name 11 'black) 5 85 + (cond + [(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)] + [(number? w) (place-image BALL 50 w MT)]))) + +)) + + Here is an improvement that adds a name to the scene and abstracts over + the name at the same time: + +@(begin +#reader scribble/comment-reader +(schemeblock +; String -> (World -> Scene) +; render the state of the world as a scene + +(check-expect + ((draw "Carl") 100) + (place-image (text "Carl" 11 'black) + 5 85 + (place-image BALL 50 100 MT))) + +(define (draw name) + (lambda (w) + (place-image + (text name 11 'black) 5 85 + (cond + [(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)] + [(number? w) (place-image BALL 50 w MT)])))) + +)) + + By doing so, we can use the same program to create many different + @tech{world}s that register with a @tech{server} on your computer: +@(begin +#reader scribble/comment-reader +(schemeblock + +; String -> World +; create and hook up a world with the @scheme[LOCALHOST] server +(define (create-world name) + (big-bang WORLD0 + (on-receive receive) + (on-draw (draw name)) + (on-tick move) + (register LOCALHOST name))) +)) + + Now you can use @scheme[(create-world 'carl)] and @scheme[(create-world 'same)], + respectively, to run two different worlds, after launching a @tech{server} + first. + +Exercise: Design a function that takes care of a world to which the + universe has lost its connection. Is @emph{Result} the proper contract for + the result of this function? + diff --git a/collects/teachpack/2htdp/scribblings/universe.ss b/collects/teachpack/2htdp/scribblings/universe.ss new file mode 100644 index 0000000000..f9c397e534 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/universe.ss @@ -0,0 +1,200 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 80) +(define FT 12) + +(define prgm + '("(big-bang World_0" + " (on-draw render WIDTH HEIGHT)" + " (on-tick tock RATE)" + " (on-mouse click)" + " (on-key react)" + " (on-receive receive)" + " (register LOCALHOST 'jimbob))")) + + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +(define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))) + (cc-superimpose t e)) + +(define False (text "FALSE" '() FT)) +(define True (text "TRUE" '() FT)) +(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False)))) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (define s (if b + (cc-superimpose + (rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t))) + t) + t)) + (define w + (cc-superimpose + s + (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + ;; add the boolean + (define bb (cc-superimpose (if b True False) BOOL)) + (define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done")) + (define scene (text "Scene" '() FT)) + (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene))))) + (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render")) + br) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define message (text "Message" '() FT)) +(define (make-Message) + (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message))))) + +(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi)))) +(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) + +(define M (rb-superimpose Message (blank DELTA DELTA))) +(define K (rb-superimpose MessageK (blank DELTA DELTA))) + +(define (make-arrows M) + (define Tock (h-labeled-arrow "tock")) + (define Click (h-labeled-arrow "click")) + (define Clack (h-labeled-arrow "react")) + (define Receive (h-labeled-arrow "receive")) + (values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M))) + +(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M)) +(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K)) + +(define state0 (make-state0 "World_0" #f)) +(define state1 (make-state0 "World_1" #f)) +(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "SERVER" '() FT )))) +(define dots (vc-append + (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT)) + Server)) +(define state2 (make-state0 "World_N-1" #f)) +(define stateN (make-state0 "World_N" #t)) +(define states (list state1 arrowsL dots arrowsR state2)) + +(define bg (blank (+ (apply + (map pict-width states)) DELTA) + (+ (pict-height state0) DELTA))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- width w) 2)) + (pin-over base x d state)) + +(define width (pict-height bg)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states))) + +(define zz xx) + +(require mred/mred) + +(define the-image + (ct-superimpose Program + (lt-superimpose + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz MessageK)) + (define-values (tx ty) (ct-find zz MessageK)) + (define-values (sx sy) (lc-find zz Server)) + (define-values (tockx tocky) (lb-find zz TockK)) + (define-values (clickx clicky) (lb-find zz ClickK)) + (define-values (clackx clacky) (lb-find zz ClackK)) + (define-values (rx ry) (lb-find zz ReceiveK)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (max rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (min sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + (add-curve clickx clicky) + (add-curve clackx clacky) + (add-curve rx ry) + ;; --- + dc) + (pict-width zz) (pict-height zz)) + (lt-superimpose + zz + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz Message)) + (define-values (tx ty) (ct-find zz Message)) + (define-values (sx sy) (rc-find zz Server)) + (define-values (rx ry) (rb-find zz ReceiveM)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (max sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (set! dcp (make-object dc-path%)) + (set! cx (min rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp) + ;; --- + dc) + (pict-width zz) (pict-height zz)))))) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "universe.png" 'png) + +the-image diff --git a/collects/teachpack/2htdp/universe.ss b/collects/teachpack/2htdp/universe.ss new file mode 100644 index 0000000000..34dd9d540e --- /dev/null +++ b/collects/teachpack/2htdp/universe.ss @@ -0,0 +1,3 @@ +(module universe mzscheme + (provide (all-from 2htdp/universe)) + (require 2htdp/universe)) diff --git a/collects/teachpack/balls.gif b/collects/teachpack/balls.gif new file mode 100644 index 0000000000..5f883d373d Binary files /dev/null and b/collects/teachpack/balls.gif differ diff --git a/collects/teachpack/nuworld.png b/collects/teachpack/nuworld.png new file mode 100644 index 0000000000..2b215663af Binary files /dev/null and b/collects/teachpack/nuworld.png differ diff --git a/collects/teachpack/server2.png b/collects/teachpack/server2.png new file mode 100644 index 0000000000..99f02cea21 Binary files /dev/null and b/collects/teachpack/server2.png differ diff --git a/collects/teachpack/universe.png b/collects/teachpack/universe.png new file mode 100644 index 0000000000..81cb2ef2db Binary files /dev/null and b/collects/teachpack/universe.png differ diff --git a/collects/teachpack/universe2.png b/collects/teachpack/universe2.png new file mode 100644 index 0000000000..8757563664 Binary files /dev/null and b/collects/teachpack/universe2.png differ diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index b5c28efa6e..13fe3d5e31 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -59,7 +59,7 @@ the settings above should match r5rs (test-expression "'|.|" "|.|") (test-expression '("(equal? (list " image ") (list " image "))") - "#f") + "#t") (test-expression "(define x 1)(define x 2)" "") (test-expression "(define-struct spider (legs))(make-spider 4)" "#") @@ -159,7 +159,7 @@ the settings above should match r5rs (test-expression "'|.|" "|.|") (test-expression '("(equal? (list " image ") (list " image "))") - "#f") + "#t") (test-expression "(define x 1)(define x 2)" "") (test-expression diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index da173fe978..f7ffc265ae 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -2366,7 +2366,9 @@ (check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1)) (check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))]) (check-all-but-one +) + (check-all-but-one (procedure-rename + 'plus)) (check-all-but-one (lambda args (apply + args))) + (check-all-but-one (procedure-rename (lambda args (apply + args)) 'PLUS)) (check-all-but-one (case-lambda [() 0] [(a b . args) (apply + a b args)])) @@ -2386,6 +2388,12 @@ [() 0] [(a b c d . e) (apply + a b c d e)])))) +(test '+ object-name (procedure-reduce-arity + 3)) +(test 'plus object-name (procedure-rename + 'plus)) +(test 'again object-name (procedure-rename (procedure-rename + 'plus) 'again)) +(test 'again object-name (procedure-rename (procedure-reduce-arity + 3) 'again)) +(test 3 procedure-arity (procedure-rename (procedure-reduce-arity + 3) 'again)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index de263a5da9..4b0469c9d9 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -1021,6 +1021,10 @@ (image? image-snip2)) (test #t 'bs-image=? + (image=? image-snip1 (send image-snip1 copy))) +(test #f + 'bs-image=? + ;; They have different masks: (image=? image-snip1 image-snip2)) (test 2 'bs-image-width diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 6938d9a641..ad9152bc63 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -270,6 +270,61 @@ (test '(1 2 3) am list '(1 2 3)) (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3))) +;; ---------- argmin & argmax ---------- + +(let () + + (define ((check-regs . regexps) exn) + (and (exn:fail? exn) + (andmap (λ (reg) (regexp-match reg (exn-message exn))) + regexps))) + + (test 'argmin object-name argmin) + (test 1 argmin (lambda (x) 0) (list 1)) + (test 1 argmin (lambda (x) x) (list 1 2 3)) + (test 1 argmin (lambda (x) 1) (list 1 2 3)) + + (test 3 + 'argmin-makes-right-number-of-calls + (let ([c 0]) + (argmin (lambda (x) (set! c (+ c 1)) 0) + (list 1 2 3)) + c)) + + (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples))) + + (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure")) + (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list")) + (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + + (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list")) + + (test 'argmax object-name argmax) + (test 1 argmax (lambda (x) 0) (list 1)) + (test 3 argmax (lambda (x) x) (list 1 2 3)) + (test 1 argmax (lambda (x) 1) (list 1 2 3)) + + (test 3 + 'argmax-makes-right-number-of-calls + (let ([c 0]) + (argmax (lambda (x) (set! c (+ c 1)) 0) + (list 1 2 3)) + c)) + + (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples))) + + (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure")) + (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list")) + (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + + (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list"))) + + + ;; ---------- check no collisions with srfi/1 ---------- (test (void) eval '(module foo scheme/base (require scheme/base srfi/1/list)) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index e5850aaf96..ee2d968c91 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -6,7 +6,7 @@ (require scheme/class) (Section 'object) - + ;; ------------------------------------------------------------ ;; Test syntax errors @@ -1413,6 +1413,63 @@ (check #f #t) (check #t #t)) +;; ---------------------------------------- +;; Implementing equal<%> + +(let () + (define c% + (class* object% (equal<%>) + (init-field x) + + (define/public (get-x) x) + (define/public (set-x v) (set! x v)) + + (define/public (equal-to? other recur-equal?) + (recur-equal? x (send other get-x))) + (define/public (equal-hash-code-of recur-hash-code) + (+ 1 (recur-hash-code x))) + (define/public (equal-secondary-hash-code-of recur-hash-code) + (+ 1 (recur-hash-code x))) + (super-new))) + (test #t equal? (new c% [x 10]) (new c% [x 10])) + (test #f equal? (new c% [x 10]) (new c% [x 12])) + + (let ([o (new c% [x 10])] + [o2 (new c% [x 10])]) + (send o set-x o) + (send o2 set-x o2) + (test #t equal? o o2) + (test #t equal? o (new c% [x o])) + (test #f equal? o (new c% [x 10])) + (let ([ht (make-hash)]) + (hash-set! ht o o) + (hash-set! ht (new c% [x "hello"]) 'hi) + (test #t eq? o (hash-ref ht o2)) + (test #f hash-ref ht (new c% [x 10]) #f) + (test 'hi hash-ref ht (new c% [x "hello"])) + (let ([d% (class c% + (super-new [x "hello"]))]) + (test 'hi hash-ref ht (new d%) #f)) + (let ([d% (class* c% (equal<%>) + (super-new [x "hello"]))]) + (test 'nope hash-ref ht (new d%) 'nope))))) + +;; ---------------------------------------- +;; Implementing new properties + +(let () + (define proc<%> + (interface* () + ([prop:procedure (lambda (o . args) + (send/apply o apply args))]) + apply)) + (define c% + (class* object% (proc<%>) + (define/public (apply . args) + (cons 'applied-to args)) + (super-new))) + (test '(applied-to 1 2 3) (new c%) 1 2 3)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/mzscheme/prompt.ss b/collects/tests/mzscheme/prompt.ss index fc6e51364c..6ed95f6ca1 100644 --- a/collects/tests/mzscheme/prompt.ss +++ b/collects/tests/mzscheme/prompt.ss @@ -8,6 +8,17 @@ (define (test-breaks-ok) (err/rt-test (break-thread (current-thread)) exn:break?)) + +(test (void) call-with-continuation-prompt void) +(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag)) +(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag) list) +(test '() call-with-continuation-prompt list (default-continuation-prompt-tag) void) +(test '(1) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1) +(test '(1 2) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2) +(test '(1 2 3) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2 3) +(test '(1 2 3 4 5 6 7 8 9 10) call-with-continuation-prompt list (default-continuation-prompt-tag) void + 1 2 3 4 5 6 7 8 9 10) + ;;---------------------------------------- ;; cc variants diff --git a/collects/tests/r6rs/arithmetic/fixnums.sls b/collects/tests/r6rs/arithmetic/fixnums.sls index d00fb333d8..51c38979f8 100644 --- a/collects/tests/r6rs/arithmetic/fixnums.sls +++ b/collects/tests/r6rs/arithmetic/fixnums.sls @@ -227,6 +227,11 @@ (test/exn (fxmod0 1 0) &assertion) (test/exn (fxdiv0-and-mod0 1 0) &assertion) + (test/exn (fxdiv (least-fixnum) -1) &implementation-restriction) + (test/exn (fxdiv-and-mod (least-fixnum) -1) &implementation-restriction) + (test/exn (fxdiv0 (least-fixnum) -1) &implementation-restriction) + (test/exn (fxdiv0-and-mod0 (least-fixnum) -1) &implementation-restriction) + (test (fxnot 0) -1) (test (fxnot -2) 1) (test (fxnot 1) -2) diff --git a/collects/tests/r6rs/io/ports.sls b/collects/tests/r6rs/io/ports.sls index 5a0ea2ce3b..643ea6fd90 100644 --- a/collects/tests/r6rs/io/ports.sls +++ b/collects/tests/r6rs/io/ports.sls @@ -628,7 +628,9 @@ (test (port-has-port-position? p) #t) (test (port-has-set-port-position!? p) #t) (test (port-position p) 0) - (test/unspec (put-string p "abc")) + (test/unspec (put-string p "ab")) + (test (port-position p) 2) + (test/unspec (put-string p "c")) (flush-output-port p) (test accum '(#\c #\b #\a)) (test (port-position p) 3) diff --git a/collects/web-server/scribblings/faq.scrbl b/collects/web-server/scribblings/faq.scrbl index e6a28ff224..5cc10d18da 100644 --- a/collects/web-server/scribblings/faq.scrbl +++ b/collects/web-server/scribblings/faq.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "web-server.ss") -@title{Troubleshooting} +@title{Troubleshooting and Tips} @section{What special considerations are there for security with the Web Server?} @@ -89,3 +89,21 @@ We can now start the server with: The Web Server will start on port 443 (which can be overridden with the @exec{-p} option) using the @filepath{private-key.pem} and @filepath{server-cert.pem} we've created. + +@section{How do I limit the number of requests serviced at once by the Web Server?} + +There is no built-in option for this, but you can easily accomplish it if you assemble your own dispatcher +by wrapping it in @scheme[call-with-semaphore]: +@schemeblock[ +(define (make-limit-dispatcher num inner) + (let ([sem (make-semaphore num)]) + (lambda (conn req) + (call-with-semaphore sem + (lambda () (inner conn req)))))) +] + +Once this function is available, rather than providing @scheme[james-gordon] as your dispatcher, you provide: +@scheme[(make-limit-dispatch 50 james-gordon)] (if you only want 50 concurrent requests.) One interesting +application of this pattern is to have a limit on certain kinds of requests. For example, you could have a +limit of 50 servlet requests, but no limit on filesystem requests. + diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 077cda3c00..62d03ab9fa 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -112,22 +112,47 @@ (define s (load/use-compiled a-path)) (cond [(void? s) - (let* ([module-name `(file ,(path->string a-path))] - [version (dynamic-require module-name 'interface-version)]) + (let* ([path-string (path->string a-path)] + [path-sym (string->symbol path-string)] + [neg-blame 'web-server] + [pos-blame path-sym] + [module-name `(file ,path-string)] + [mk-loc + (lambda (name) + (list (make-srcloc a-path #f #f #f #f) + name))] + [version + (contract (symbols 'v1 'v2 'stateless) + (dynamic-require module-name 'interface-version) + pos-blame neg-blame + (mk-loc "interface-version"))]) (case version [(v1) - (let ([timeout (dynamic-require module-name 'timeout)] - [start (dynamic-require module-name 'start)]) + (let ([timeout (contract number? + (dynamic-require module-name 'timeout) + pos-blame neg-blame + (mk-loc "timeout"))] + [start (contract (request? . -> . response?) + (dynamic-require module-name 'start) + pos-blame neg-blame + (mk-loc "start"))]) (make-v1.servlet (directory-part a-path) timeout start))] [(v2) - (let ([start (dynamic-require module-name 'start)] - [manager (dynamic-require module-name 'manager)]) + (let ([start (contract (request? . -> . response?) + (dynamic-require module-name 'start) + pos-blame neg-blame + (mk-loc "start"))] + [manager (contract manager? + (dynamic-require module-name 'manager) + pos-blame neg-blame + (mk-loc "manager"))]) (make-v2.servlet (directory-part a-path) manager start))] [(stateless) - (let ([start (dynamic-require module-name 'start)]) - (make-stateless.servlet (directory-part a-path) start))] - [else - (error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" version)]))] + (let ([start (contract (request? . -> . response?) + (dynamic-require module-name 'start) + pos-blame neg-blame + (mk-loc "start"))]) + (make-stateless.servlet (directory-part a-path) start))]))] [(response? s) (make-v1.servlet (directory-part a-path) timeouts-default-servlet (v0.response->v1.lambda s a-path))] diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 1d97658d8b..37f8a517db 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.1.3.7 + +image-snip% implements equal<%> + +---------------------------------------------------------------------- + Version 4.1.3, November 2008 Minor bug fixes diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index ea4c3098fd..51cfe16b99 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,12 @@ +Version 4.1.3.8 +Added procedure-rename +Added extra arguments to call-with-continuation-prompt + +Version 4.1.3.7 +Added equal?/recur +Added extra argument to raise-syntax-error +Added equal<%> and interface* to scheme/class + Version 4.1.3.6 Memory accounting changed to bias charges to parent instead of children diff --git a/src/mred/wxs/khead.ss b/src/mred/wxs/khead.ss index 6c0171f61b..6b8747b8e5 100644 --- a/src/mred/wxs/khead.ss +++ b/src/mred/wxs/khead.ss @@ -47,7 +47,7 @@ (let ([defined null]) (lambda (stx) (syntax-case stx () - [(_ name print-name super args id ...) + [(_ name print-name super (intf ...) args id ...) (let ([nm (syntax-e (syntax name))] [sn (syntax-e (syntax super))] [ids (map syntax-e (syntax->list (syntax (id ...))))]) @@ -78,11 +78,11 @@ (syntax (define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) (make-primitive-class - (lambda (class prop:object preparer dispatcher) + (lambda (class prop:object preparer dispatcher more-props) (kernel:primitive-class-prepare-struct-type! - c prop:object class preparer dispatcher)) + c prop:object class preparer dispatcher more-props)) kernel:initialize-primitive-object - 'print-name super 'args + 'print-name super (list intf ...) 'args '(old ...) '(new ...) (list diff --git a/src/mred/wxs/wxs_snip.cxx b/src/mred/wxs/wxs_snip.cxx index 96a7b568fd..e4e21ff7f3 100644 --- a/src/mred/wxs/wxs_snip.cxx +++ b/src/mred/wxs/wxs_snip.cxx @@ -6583,6 +6583,92 @@ static Scheme_Object *bundle_symset_bitmapType(int v) { +extern void wxGetARGBPixels(wxBitmap *bm, double x, double y, int w, int h, char *s, Bool get_alpha); +static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur); + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif +static bool OtherEqualTo(wxImageSnip* snip, wxImageSnip* snip2, void *recur) +{ + int w, h; + char *s1, *s2; + wxBitmap *bm, *bm2, *mask; + + bm = snip->GetSnipBitmap(); + bm2 = snip2->GetSnipBitmap(); + + if (!bm || !bm->Ok()) return FALSE; + if (!bm2 || !bm2->Ok()) return FALSE; + if (bm->GetDepth() != bm2->GetDepth()) return FALSE; + w = bm->GetWidth(); + h = bm->GetHeight(); + if (w != bm2->GetWidth()) return FALSE; + if (h != bm2->GetHeight()) return FALSE; + + s1 = (char *)scheme_malloc_atomic(w * h * 4); + s2 = (char *)scheme_malloc_atomic(w * h * 4); + + memset(s1, 255, w * h * 4); + memset(s2, 255, w * h * 4); + + wxGetARGBPixels(bm, 0, 0, w, h, s1, 0); + wxGetARGBPixels(bm2, 0, 0, w, h, s2, 0); + + mask = snip->GetSnipBitmapMask(); + if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) { + wxGetARGBPixels(mask, 0, 0, w, h, s1, 1); + } + mask = snip2->GetSnipBitmapMask(); + if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) { + wxGetARGBPixels(mask, 0, 0, w, h, s2, 1); + } + + return !memcmp(s1, s2, w * h * 4); +} + +static long HashCodeOf(wxImageSnip *snip, void *recur) +{ + int w, h, i; + long hk = 0; + char *s1; + wxBitmap *bm; + + bm = snip->GetSnipBitmap(); + if (!bm) return 0; + + if (!bm->Ok()) return 0; + w = bm->GetWidth(); + h = bm->GetHeight(); + + s1 = (char *)scheme_malloc_atomic(w * h * 4); + + wxGetARGBPixels(bm, 0, 0, w, h, s1, 0); + + for (i = w * h * 4; i; i -= 4) { + hk += s1[i - 4] + s1[i - 3] + s1[i - 2]; + hk = (hk << 1) + hk; + } + + return hk; +} + +static long SecondaryHashCodeOf(wxImageSnip *snip, void *recur) +{ + wxBitmap *bm; + + bm = snip->GetSnipBitmap(); + if (!bm) return 0; + + return bm->GetWidth() + bm->GetHeight(); +} +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +#define UNKNOWN_OBJ void* + + @@ -6603,6 +6689,7 @@ static Scheme_Object *bundle_symset_bitmapType(int v) { + class os_wxImageSnip : public wxImageSnip { public: @@ -6611,6 +6698,8 @@ class os_wxImageSnip : public wxImageSnip { os_wxImageSnip CONSTRUCTOR_ARGS((class wxBitmap* x0, class wxBitmap* x1 = NULL)); #endif ~os_wxImageSnip(); + Bool OtherEqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1); + Bool EqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1); void SetUnmodified(); nndouble GetScrollStepOffset(nnlong x0); nnlong FindScrollStep(double x0); @@ -6669,6 +6758,92 @@ os_wxImageSnip::~os_wxImageSnip() objscheme_destroy(this, (Scheme_Object *) __gc_external); } +static Scheme_Object *os_wxImageSnipOtherEqualTo(int n, Scheme_Object *p[]); + +Bool os_wxImageSnip::OtherEqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1) +{ + Scheme_Object *p[POFFSET+2] INIT_NULLED_ARRAY({ NULLED_OUT INA_comma NULLED_OUT INA_comma NULLED_OUT }); + Scheme_Object *v; + Scheme_Object *method INIT_NULLED_OUT; +#ifdef MZ_PRECISE_GC + os_wxImageSnip *sElF = this; +#endif + static void *mcache = 0; + + SETUP_VAR_STACK(7); + VAR_STACK_PUSH(0, method); + VAR_STACK_PUSH(1, sElF); + VAR_STACK_PUSH_ARRAY(2, p, POFFSET+2); + VAR_STACK_PUSH(5, x0); + VAR_STACK_PUSH(6, x1); + SET_VAR_STACK(); + + method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxImageSnip_class, "other-equal-to?", &mcache); + if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxImageSnipOtherEqualTo)) { + SET_VAR_STACK(); + READY_TO_RETURN; return OtherEqualTo(SELF__, x0, x1); + } else { + + p[POFFSET+0] = WITH_VAR_STACK(objscheme_bundle_wxImageSnip(x0)); + p[POFFSET+1] = ((Scheme_Object *)x1); + + p[0] = (Scheme_Object *) ASSELF __gc_external; + + v = WITH_VAR_STACK(scheme_apply(method, POFFSET+2, p)); + + + { + Bool resval; + resval = WITH_VAR_STACK(objscheme_unbundle_bool(v, "other-equal-to? in image-snip%"", extracting return value")); + READY_TO_RETURN; + return resval; + } + } +} + +static Scheme_Object *os_wxImageSnipEqualTo(int n, Scheme_Object *p[]); + +Bool os_wxImageSnip::EqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1) +{ + Scheme_Object *p[POFFSET+2] INIT_NULLED_ARRAY({ NULLED_OUT INA_comma NULLED_OUT INA_comma NULLED_OUT }); + Scheme_Object *v; + Scheme_Object *method INIT_NULLED_OUT; +#ifdef MZ_PRECISE_GC + os_wxImageSnip *sElF = this; +#endif + static void *mcache = 0; + + SETUP_VAR_STACK(7); + VAR_STACK_PUSH(0, method); + VAR_STACK_PUSH(1, sElF); + VAR_STACK_PUSH_ARRAY(2, p, POFFSET+2); + VAR_STACK_PUSH(5, x0); + VAR_STACK_PUSH(6, x1); + SET_VAR_STACK(); + + method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxImageSnip_class, "equal-to?", &mcache); + if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxImageSnipEqualTo)) { + SET_VAR_STACK(); + READY_TO_RETURN; return EqualTo(SELF__, x0, x1); + } else { + + p[POFFSET+0] = WITH_VAR_STACK(objscheme_bundle_wxImageSnip(x0)); + p[POFFSET+1] = ((Scheme_Object *)x1); + + p[0] = (Scheme_Object *) ASSELF __gc_external; + + v = WITH_VAR_STACK(scheme_apply(method, POFFSET+2, p)); + + + { + Bool resval; + resval = WITH_VAR_STACK(objscheme_unbundle_bool(v, "equal-to? in image-snip%"", extracting return value")); + READY_TO_RETURN; + return resval; + } + } +} + static Scheme_Object *os_wxImageSnipSetUnmodified(int n, Scheme_Object *p[]); void os_wxImageSnip::SetUnmodified() @@ -7641,6 +7816,108 @@ void os_wxImageSnip::GetExtent(class wxDC* x0, double x1, double x2, nndouble* x } } +static Scheme_Object *os_wxImageSnipSecondaryHashCodeOf(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + long r; + objscheme_check_valid(os_wxImageSnip_class, "equal-secondary-hash-code-of in image-snip%", n, p); + UNKNOWN_OBJ x0 INIT_NULLED_OUT; + + SETUP_VAR_STACK_REMEMBERED(2); + VAR_STACK_PUSH(0, p); + VAR_STACK_PUSH(1, x0); + + + x0 = ((void *)p[POFFSET+0]); + + + r = WITH_VAR_STACK(SecondaryHashCodeOf(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0)); + + + + READY_TO_RETURN; + return scheme_make_integer(r); +} + +static Scheme_Object *os_wxImageSnipHashCodeOf(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + long r; + objscheme_check_valid(os_wxImageSnip_class, "equal-hash-code-of in image-snip%", n, p); + UNKNOWN_OBJ x0 INIT_NULLED_OUT; + + SETUP_VAR_STACK_REMEMBERED(2); + VAR_STACK_PUSH(0, p); + VAR_STACK_PUSH(1, x0); + + + x0 = ((void *)p[POFFSET+0]); + + + r = WITH_VAR_STACK(HashCodeOf(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0)); + + + + READY_TO_RETURN; + return scheme_make_integer(r); +} + +static Scheme_Object *os_wxImageSnipOtherEqualTo(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + Bool r; + objscheme_check_valid(os_wxImageSnip_class, "other-equal-to? in image-snip%", n, p); + class wxImageSnip* x0 INIT_NULLED_OUT; + UNKNOWN_OBJ x1 INIT_NULLED_OUT; + + SETUP_VAR_STACK_REMEMBERED(3); + VAR_STACK_PUSH(0, p); + VAR_STACK_PUSH(1, x0); + VAR_STACK_PUSH(2, x1); + + + x0 = WITH_VAR_STACK(objscheme_unbundle_wxImageSnip(p[POFFSET+0], "other-equal-to? in image-snip%", 1)); + x1 = ((void *)p[POFFSET+1]); + + + r = WITH_VAR_STACK(OtherEqualTo(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0, x1)); + + + + READY_TO_RETURN; + return (r ? scheme_true : scheme_false); +} + +static Scheme_Object *os_wxImageSnipEqualTo(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + Bool r; + objscheme_check_valid(os_wxImageSnip_class, "equal-to? in image-snip%", n, p); + class wxImageSnip* x0 INIT_NULLED_OUT; + UNKNOWN_OBJ x1 INIT_NULLED_OUT; + + SETUP_VAR_STACK_REMEMBERED(3); + VAR_STACK_PUSH(0, p); + VAR_STACK_PUSH(1, x0); + VAR_STACK_PUSH(2, x1); + + + x0 = WITH_VAR_STACK(objscheme_unbundle_wxImageSnip(p[POFFSET+0], "equal-to? in image-snip%", 1)); + x1 = ((void *)p[POFFSET+1]); + + + r = WITH_VAR_STACK(EqualTo(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0, x1)); + + + + READY_TO_RETURN; + return (r ? scheme_true : scheme_false); +} + static Scheme_Object *os_wxImageSnipSetOffset(int n, Scheme_Object *p[]) { WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) @@ -8707,8 +8984,12 @@ void objscheme_setup_wxImageSnip(Scheme_Env *env) wxREGGLOB(os_wxImageSnip_class); - os_wxImageSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "image-snip%", "snip%", (Scheme_Method_Prim *)os_wxImageSnip_ConstructScheme, 31)); + os_wxImageSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "image-snip%", "snip%", (Scheme_Method_Prim *)os_wxImageSnip_ConstructScheme, 35)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-secondary-hash-code-of" " method", (Scheme_Method_Prim *)os_wxImageSnipSecondaryHashCodeOf, 1, 1)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-hash-code-of" " method", (Scheme_Method_Prim *)os_wxImageSnipHashCodeOf, 1, 1)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "other-equal-to?" " method", (Scheme_Method_Prim *)os_wxImageSnipOtherEqualTo, 2, 2)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-to?" " method", (Scheme_Method_Prim *)os_wxImageSnipEqualTo, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "set-offset" " method", (Scheme_Method_Prim *)os_wxImageSnipSetOffset, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "get-bitmap-mask" " method", (Scheme_Method_Prim *)os_wxImageSnipGetSnipBitmapMask, 0, 0)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "get-bitmap" " method", (Scheme_Method_Prim *)os_wxImageSnipGetSnipBitmap, 0, 0)); @@ -8805,6 +9086,15 @@ class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *obj, const char } +static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur) +{ + /* Might redirect to Scheme. + We're relying on the cast succeeding because the method is + not virtual, but I doubt that this is guaranteed to work by the C++ + spec if wxImageSnip is instantiated instead of os_wxImageSnip */ + return ((os_wxImageSnip *)bm2)->OtherEqualTo_method(bm, recur); +} + diff --git a/src/mred/wxs/wxs_snip.h b/src/mred/wxs/wxs_snip.h index 8bd80e0f24..ae9b8f8391 100644 --- a/src/mred/wxs/wxs_snip.h +++ b/src/mred/wxs/wxs_snip.h @@ -151,6 +151,8 @@ void objscheme_setup_wxTabSnip(Scheme_Env *env); int objscheme_istype_wxTabSnip(Scheme_Object *obj, const char *stop, int nullOK); Scheme_Object *objscheme_bundle_wxTabSnip(class wxTabSnip *realobj); class wxTabSnip *objscheme_unbundle_wxTabSnip(Scheme_Object *obj, const char *where, int nullOK); +extern Scheme_Object *objscheme_bundle_wxImageSnip(class wxImageSnip *); +extern Scheme_Object *objscheme_bundle_wxImageSnip(class wxImageSnip *); extern Scheme_Object *objscheme_bundle_wxSnipAdmin(class wxSnipAdmin *); extern Scheme_Object *objscheme_bundle_wxMediaStreamOut(class wxMediaStreamOut *); extern Scheme_Object *objscheme_bundle_wxSnip(class wxSnip *); @@ -172,6 +174,8 @@ extern class wxSnip *objscheme_unbundle_wxSnip(Scheme_Object *, const char *, in extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *); extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *); extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *); +extern class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *, const char *, int); +extern class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *, const char *, int); extern Scheme_Object *objscheme_bundle_wxBitmap(class wxBitmap *); extern Scheme_Object *objscheme_bundle_wxBitmap(class wxBitmap *); extern class wxBitmap *objscheme_unbundle_wxBitmap(Scheme_Object *, const char *, int); diff --git a/src/mred/wxs/wxs_snip.xc b/src/mred/wxs/wxs_snip.xc index bdc4a5ce8b..b186aa3560 100644 --- a/src/mred/wxs/wxs_snip.xc +++ b/src/mred/wxs/wxs_snip.xc @@ -88,8 +88,97 @@ @INCLUDE wxs_bmt.xci +extern void wxGetARGBPixels(wxBitmap *bm, double x, double y, int w, int h, char *s, Bool get_alpha); +static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur); + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif +static bool OtherEqualTo(wxImageSnip* snip, wxImageSnip* snip2, void *recur) +{ + int w, h; + char *s1, *s2; + wxBitmap *bm, *bm2, *mask; + + bm = snip->GetSnipBitmap(); + bm2 = snip2->GetSnipBitmap(); + + if (!bm || !bm->Ok()) return FALSE; + if (!bm2 || !bm2->Ok()) return FALSE; + if (bm->GetDepth() != bm2->GetDepth()) return FALSE; + w = bm->GetWidth(); + h = bm->GetHeight(); + if (w != bm2->GetWidth()) return FALSE; + if (h != bm2->GetHeight()) return FALSE; + + s1 = (char *)scheme_malloc_atomic(w * h * 4); + s2 = (char *)scheme_malloc_atomic(w * h * 4); + + memset(s1, 255, w * h * 4); + memset(s2, 255, w * h * 4); + + wxGetARGBPixels(bm, 0, 0, w, h, s1, 0); + wxGetARGBPixels(bm2, 0, 0, w, h, s2, 0); + + mask = snip->GetSnipBitmapMask(); + if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) { + wxGetARGBPixels(mask, 0, 0, w, h, s1, 1); + } + mask = snip2->GetSnipBitmapMask(); + if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) { + wxGetARGBPixels(mask, 0, 0, w, h, s2, 1); + } + + return !memcmp(s1, s2, w * h * 4); +} + +static long HashCodeOf(wxImageSnip *snip, void *recur) +{ + int w, h, i; + long hk = 0; + char *s1; + wxBitmap *bm; + + bm = snip->GetSnipBitmap(); + if (!bm) return 0; + + if (!bm->Ok()) return 0; + w = bm->GetWidth(); + h = bm->GetHeight(); + + s1 = (char *)scheme_malloc_atomic(w * h * 4); + + wxGetARGBPixels(bm, 0, 0, w, h, s1, 0); + + for (i = w * h * 4; i; i -= 4) { + hk += s1[i - 4] + s1[i - 3] + s1[i - 2]; + hk = (hk << 1) + hk; + } + + return hk; +} + +static long SecondaryHashCodeOf(wxImageSnip *snip, void *recur) +{ + wxBitmap *bm; + + bm = snip->GetSnipBitmap(); + if (!bm) return 0; + + return bm->GetWidth() + bm->GetHeight(); +} +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +#define UNKNOWN_OBJ void* +@MACRO bundleAny = ((Scheme_Object *){x}) +@MACRO unbundleAny = ((void *){x}) + @CLASSBASE wxImageSnip "image-snip":"snip" / nofnl +@IMPLEMENTS equal<%> + @CREATOR (nxpathname=NULL,SYM[bitmapType]=0,bool=FALSE,bool=TRUE); : : //USEALLFUEL[x0] <> filename @CREATOR (wxBitmap!,wxBitmap^=NULL) : : /CheckBW[1.METHODNAME("image-snip%","initialization")]|CHECKOK[0.METHODNAME("image-snip%","initialization")]|CHECKOK[1.METHODNAME("image-snip%","initialization")]|CheckSizes[0.1.METHODNAME("image-snip%","initialization")] <> bitmap @@ -111,8 +200,22 @@ @ "set-offset" : void SetOffset(double, double); +@ M "equal-to?" : bool EqualTo(wxImageSnip^,UNKNOWN_OBJ/bundleAny/unbundleAny////push); +@ M "other-equal-to?" : bool OtherEqualTo(wxImageSnip^,UNKNOWN_OBJ/bundleAny/unbundleAny////push); +@ m "equal-hash-code-of" : long HashCodeOf(UNKNOWN_OBJ/bundleAny/unbundleAny////push); +@ m "equal-secondary-hash-code-of" : long SecondaryHashCodeOf(UNKNOWN_OBJ/bundleAny/unbundleAny////push); + @END +static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur) +{ + /* Might redirect to Scheme. + We're relying on the cast succeeding because the method is + not virtual, but I doubt that this is guaranteed to work by the C++ + spec if wxImageSnip is instantiated instead of os_wxImageSnip */ + return ((os_wxImageSnip *)bm2)->OtherEqualTo_method(bm, recur); +} + @CLASSBASE wxMediaSnip "editor-snip" : "snip" / nofnl @CREATOR (wxMediaBuffer^=NULL,bool=TRUE,nnint=wxMSNIPBOX_XMARGIN,nnint=wxMSNIPBOX_YMARGIN,nnint=wxMSNIPBOX_XMARGIN,nnint=wxMSNIPBOX_YMARGIN,nnint=wxMSNIPBOX_XINSET,nnint=wxMSNIPBOX_YINSET,nnint=wxMSNIPBOX_XINSET,nnint=wxMSNIPBOX_YINSET,nnfs[none]=-1,nnfs[none]=-1,nnfs[none]=-1,nnfs[none]=-1); diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index 714836f502..9598f26687 100644 --- a/src/mzscheme/src/bool.c +++ b/src/mzscheme/src/bool.c @@ -48,12 +48,14 @@ static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]); +static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]); typedef struct Equal_Info { - long depth; /* always odd */ - long car_depth; /* always odd */ + long depth; /* always odd, so it looks like a fixnum */ + long car_depth; /* always odd => fixnum */ Scheme_Hash_Table *ht; Scheme_Object *recur; + Scheme_Object *next, *next_next; } Equal_Info; static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); @@ -95,6 +97,10 @@ void scheme_init_bool (Scheme_Env *env) scheme_equal_prim = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2); scheme_add_global_constant("equal?", scheme_equal_prim, env); + + scheme_add_global_constant("equal?/recur", + scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3), + env); } static Scheme_Object * @@ -130,6 +136,25 @@ equal_prim (int argc, Scheme_Object *argv[]) eql.car_depth = 1; eql.ht = NULL; eql.recur = NULL; + eql.next = NULL; + eql.next_next = NULL; + + return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false); +} + +static Scheme_Object * +equalish_prim (int argc, Scheme_Object *argv[]) +{ + Equal_Info eql; + + scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv); + + eql.depth = 1; + eql.car_depth = 1; + eql.ht = NULL; + eql.recur = NULL; + eql.next = NULL; + eql.next_next = argv[2]; return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false); } @@ -222,6 +247,8 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) eql.car_depth = 1; eql.ht = NULL; eql.recur = NULL; + eql.next_next = NULL; + eql.next = NULL; return is_equal(obj1, obj2, &eql); } @@ -252,7 +279,8 @@ static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht) static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) { if (eql->depth < 50) { - eql->depth += 2; + if (!eql->next_next) + eql->depth += 2; return 0; } else { Scheme_Hash_Table *ht = eql->ht; @@ -324,6 +352,17 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) static int equal_counter = EQUAL_COUNT_START; top: + if (eql->next_next) { + if (eql->next) { + Scheme_Object *a[2]; + a[0] = obj1; + a[1] = obj2; + obj1 = _scheme_apply(eql->next, 2, a); + return SCHEME_TRUEP(obj1); + } + eql->next = eql->next_next; + } + if (scheme_eqv(obj1, obj2)) return 1; else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) { diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 85845e9172..77b7599b9e 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,13 +1,13 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,50,0,0,0,1,0,0,3,0,12,0, -16,0,23,0,26,0,31,0,38,0,43,0,48,0,55,0,68,0,72,0,78, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,50,0,0,0,1,0,0,3,0,12,0, +17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, 1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3, 132,4,34,5,84,5,107,5,186,5,0,0,132,7,0,0,29,11,11,68,104, -101,114,101,45,115,116,120,63,108,101,116,66,100,101,102,105,110,101,62,111,114, -64,108,101,116,42,66,117,110,108,101,115,115,64,99,111,110,100,64,119,104,101, -110,66,108,101,116,114,101,99,72,112,97,114,97,109,101,116,101,114,105,122,101, +101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101, +99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115, +63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42, 63,97,110,100,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110, 101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65, 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101, @@ -15,66 +15,66 @@ 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, 10,35,11,8,180,243,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, -2,1,2,4,2,1,2,10,2,1,2,5,2,1,2,6,2,1,2,7,2, -1,2,8,2,1,2,9,2,1,2,11,2,1,2,12,2,1,97,36,11,8, +2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2,1,2,9,2, +1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1,97,36,11,8, 180,243,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2, 2,97,10,11,11,8,180,243,16,0,97,10,37,11,8,180,243,16,0,13,16, 4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,8,30, 8,29,8,28,8,27,93,8,224,251,60,0,0,95,9,8,224,251,60,0,0, -2,1,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74, -2,16,248,22,89,23,200,2,12,249,22,64,2,17,248,22,91,23,202,1,27, -248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,16,248, -22,89,23,200,2,249,22,64,2,17,248,22,91,23,202,1,12,27,248,22,66, -248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,28, -248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35, -251,22,74,2,16,248,22,65,23,200,2,249,22,64,2,12,248,22,66,23,202, +2,1,27,248,22,134,4,23,196,1,249,22,191,3,80,158,38,35,251,22,75, +2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202,1,27, +248,22,134,4,23,196,1,249,22,191,3,80,158,38,35,251,22,75,2,16,248, +22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248,22,67, +248,22,134,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,28, +248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,191,3,80,158,38,35, +251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67,23,202, 1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, 2,18,3,1,7,101,110,118,57,55,57,51,16,4,11,11,2,19,3,1,7, 101,110,118,57,55,57,52,93,8,224,252,60,0,0,95,9,8,224,252,60,0, -0,2,1,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2, -20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249, -22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74, -2,21,248,22,65,23,202,2,251,22,74,2,16,2,21,2,21,249,22,64,2, -5,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, +0,2,1,27,248,22,67,248,22,134,4,23,197,1,28,248,22,73,23,194,2, +20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249, +22,191,3,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248,22,75, +2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22,65,2, +4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, 27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,54,16,4,11,11, 2,19,3,1,7,101,110,118,57,55,57,55,93,8,224,253,60,0,0,95,9, -8,224,253,60,0,0,2,1,248,22,133,4,193,27,248,22,133,4,194,249,22, -64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23, -197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65, +8,224,253,60,0,0,2,1,248,22,134,4,193,27,248,22,134,4,194,249,22, +65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,134,4,23, +197,1,249,22,191,3,80,158,38,35,28,248,22,53,248,22,128,4,248,22,66, 23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22, -133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,249,22,74,248,22, -74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,65,23,204,2,248, -22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,2,22,89,23,200, -1,250,22,75,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40, -248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,194,249,22,64, -248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,197, -1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,32,0,89,162, -8,44,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,66,198,27, -248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,22,190,3, -80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,199,250,22, -74,2,3,248,22,74,248,22,65,199,250,22,75,2,6,248,22,66,201,248,22, -66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,78,249,22, -2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,39,35,251, -22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110, -45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,45,112,97, +134,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75,248,22, +75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204,2,248, +22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90,23,200, +1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40, +248,22,134,4,248,22,66,201,248,22,67,198,27,248,22,134,4,194,249,22,65, +248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,134,4,23,197, +1,249,22,191,3,80,158,38,35,250,22,76,2,22,249,22,2,32,0,89,162, +8,44,36,46,9,222,33,42,248,22,134,4,248,22,66,201,248,22,67,198,27, +248,22,67,248,22,134,4,196,27,248,22,134,4,248,22,66,195,249,22,191,3, +80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199,250,22, +75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201,248,22, +67,202,27,248,22,67,248,22,134,4,23,197,1,27,249,22,1,22,79,249,22, +2,22,134,4,248,22,134,4,248,22,66,199,249,22,191,3,80,158,39,35,251, +22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110, +45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45,112,97, 114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110, 116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105, -114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,248,22,66, -248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,249, -22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,28,249,22, -162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,2,20,248, -22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,8,249,22,74, -2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,2,16,28, -249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248, -22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2, -8,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, +114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248,22,67, +248,22,134,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,249, +22,191,3,80,158,38,35,27,248,22,134,4,248,22,66,23,198,2,28,249,22, +163,8,62,61,62,248,22,128,4,248,22,90,23,197,2,250,22,75,2,20,248, +22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249,22,75, +2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2,16,28, +249,22,163,8,248,22,128,4,248,22,66,23,201,2,64,101,108,115,101,10,248, +22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22,65,2, +3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, 11,2,18,3,1,7,101,110,118,57,56,49,57,16,4,11,11,2,19,3,1, 7,101,110,118,57,56,50,48,93,8,224,254,60,0,0,18,16,2,158,94,10, -64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,1,27,248,22,66, -248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3, -248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27, -248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250, -22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,11, +64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,1,27,248,22,67, +248,22,134,4,196,249,22,191,3,80,158,38,35,28,248,22,53,248,22,128,4, +248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90,198,27, +248,22,128,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,197,250, +22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16,1,11, 16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,1,11, 10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,2, 2,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,3,2,4,2, @@ -84,29 +84,29 @@ 11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15,159,35,35, 35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89,162,8,44, 36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,11,16,5, -2,9,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2, +2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2, 2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,35,35,20, -103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,5,89,162,8,44,36, +103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162,8,44,36, 55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,38,11,16, -5,2,3,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1, -2,2,16,0,11,16,5,2,10,89,162,8,44,36,52,9,223,0,33,43,35, -20,103,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,44,36,53, -9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,11, +5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1, +2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33,43,35, +20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8,44,36,53, +9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6, 89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,2,2,16, -0,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159, -35,16,1,2,2,16,1,33,48,11,16,5,2,4,89,162,8,44,36,53,9, +0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159, +35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44,36,53,9, 223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,94,2,14, 2,15,93,2,14,9,9,35,0}; EVAL_ONE_SIZED_STR((char *)expr, 2045); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, -199,1,223,1,6,2,8,2,65,2,155,3,196,3,30,5,134,5,238,5,99, -6,113,6,147,6,163,6,13,8,27,8,190,8,191,9,191,10,198,10,205,10, -212,10,87,11,100,11,55,12,157,12,170,12,192,12,144,13,48,14,119,15,127, -15,135,15,161,15,15,16,0,0,3,19,0,0,72,112,97,116,104,45,115,116, +199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, +6,114,6,148,6,164,6,14,8,28,8,191,8,192,9,192,10,199,10,206,10, +213,10,88,11,101,11,56,12,158,12,171,12,193,12,145,13,49,14,121,15,129, +15,137,15,163,15,18,16,0,0,6,19,0,0,72,112,97,116,104,45,115,116, 114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115, 101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,108,112,97,116,104, 77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,75,99,111, @@ -132,217 +132,217 @@ 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100, 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32, 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51, -249,22,27,11,80,158,41,50,22,179,12,10,248,22,155,5,23,196,2,28,248, -22,152,6,23,194,2,12,87,94,248,22,165,8,23,194,1,248,80,159,37,53, -36,195,28,248,22,72,23,195,2,9,27,248,22,65,23,196,2,27,28,248,22, -160,13,23,195,2,23,194,1,28,248,22,159,13,23,195,2,249,22,161,13,23, -196,1,250,80,158,42,48,248,22,175,13,2,19,11,10,250,80,158,40,48,248, -22,175,13,2,19,23,197,1,10,28,23,193,2,249,22,64,248,22,163,13,249, -22,161,13,23,198,1,247,22,176,13,27,248,22,66,23,200,1,28,248,22,72, -23,194,2,9,27,248,22,65,23,195,2,27,28,248,22,160,13,23,195,2,23, -194,1,28,248,22,159,13,23,195,2,249,22,161,13,23,196,1,250,80,158,47, -48,248,22,175,13,2,19,11,10,250,80,158,45,48,248,22,175,13,2,19,23, -197,1,10,28,23,193,2,249,22,64,248,22,163,13,249,22,161,13,23,198,1, -247,22,176,13,248,80,159,45,52,36,248,22,66,23,199,1,87,94,23,193,1, -248,80,159,43,52,36,248,22,66,23,197,1,87,94,23,193,1,27,248,22,66, -23,198,1,28,248,22,72,23,194,2,9,27,248,22,65,23,195,2,27,28,248, -22,160,13,23,195,2,23,194,1,28,248,22,159,13,23,195,2,249,22,161,13, -23,196,1,250,80,158,45,48,248,22,175,13,2,19,11,10,250,80,158,43,48, -248,22,175,13,2,19,23,197,1,10,28,23,193,2,249,22,64,248,22,163,13, -249,22,161,13,23,198,1,247,22,176,13,248,80,159,43,52,36,248,22,66,23, -199,1,248,80,159,41,52,36,248,22,66,196,27,248,22,136,13,23,195,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,157,6,23,195,2,27,248,22,158, -13,195,28,192,192,248,22,159,13,195,11,87,94,28,28,248,22,137,13,23,195, -2,10,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,76,110,111,114, +249,22,27,11,80,158,41,50,22,181,12,10,248,22,156,5,23,196,2,28,248, +22,153,6,23,194,2,12,87,94,248,22,167,8,23,194,1,248,80,159,37,53, +36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22, +162,13,23,195,2,23,194,1,28,248,22,161,13,23,195,2,249,22,163,13,23, +196,1,250,80,158,42,48,248,22,177,13,2,19,11,10,250,80,158,40,48,248, +22,177,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,165,13,249, +22,163,13,23,198,1,247,22,178,13,27,248,22,67,23,200,1,28,248,22,73, +23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,162,13,23,195,2,23, +194,1,28,248,22,161,13,23,195,2,249,22,163,13,23,196,1,250,80,158,47, +48,248,22,177,13,2,19,11,10,250,80,158,45,48,248,22,177,13,2,19,23, +197,1,10,28,23,193,2,249,22,65,248,22,165,13,249,22,163,13,23,198,1, +247,22,178,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, +248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67, +23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248, +22,162,13,23,195,2,23,194,1,28,248,22,161,13,23,195,2,249,22,163,13, +23,196,1,250,80,158,45,48,248,22,177,13,2,19,11,10,250,80,158,43,48, +248,22,177,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,165,13, +249,22,163,13,23,198,1,247,22,178,13,248,80,159,43,52,36,248,22,67,23, +199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,138,13,23,195,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,158,6,23,195,2,27,248,22,160, +13,195,28,192,192,248,22,161,13,195,11,87,94,28,28,248,22,139,13,23,195, +2,10,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, +248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,76,110,111,114, 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32, 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118, 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28, -248,22,137,13,23,195,2,249,22,162,8,248,22,138,13,23,197,2,2,20,249, -22,162,8,247,22,176,7,2,20,27,28,248,22,157,6,23,196,2,23,195,2, -248,22,166,7,248,22,141,13,23,197,2,28,249,22,188,13,0,21,35,114,120, +248,22,139,13,23,195,2,249,22,163,8,248,22,140,13,23,197,2,2,20,249, +22,163,8,247,22,177,7,2,20,27,28,248,22,158,6,23,196,2,23,195,2, +248,22,167,7,248,22,143,13,23,197,2,28,249,22,190,13,0,21,35,114,120, 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2, -28,248,22,157,6,195,248,22,144,13,195,194,27,248,22,132,7,23,195,1,249, -22,145,13,248,22,169,7,250,22,130,14,0,6,35,114,120,34,47,34,28,249, -22,188,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, -92,92,93,42,36,34,23,201,2,23,199,1,250,22,130,14,0,19,35,114,120, +28,248,22,158,6,195,248,22,146,13,195,194,27,248,22,133,7,23,195,1,249, +22,147,13,248,22,170,7,250,22,132,14,0,6,35,114,120,34,47,34,28,249, +22,190,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, +92,92,93,42,36,34,23,201,2,23,199,1,250,22,132,14,0,19,35,114,120, 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2, -2,92,49,80,158,43,36,2,20,28,248,22,157,6,194,248,22,144,13,194,193, -87,94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,23,196,2, -2,21,23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164, -10,248,22,186,6,250,22,141,7,2,22,23,200,1,23,201,1,247,22,23,87, -94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,23,196,2,2, -21,23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164,10, -248,22,186,6,250,22,141,7,2,22,23,200,1,23,201,1,247,22,23,87,94, -87,94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,195,2,21, -23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164,10,248, -22,186,6,250,22,141,7,2,22,199,23,201,1,247,22,23,249,22,3,89,162, -8,44,36,49,9,223,2,33,33,196,248,22,155,11,249,22,130,11,23,196,1, -247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41,36, -2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162,43, -41,58,65,99,108,111,111,112,222,33,38,28,248,22,72,23,199,2,87,94,23, -198,1,248,23,196,1,251,22,141,7,2,23,23,199,1,28,248,22,72,23,203, -2,87,94,23,202,1,23,201,1,250,22,1,22,154,13,23,204,1,23,205,1, -23,198,1,27,249,22,154,13,248,22,65,23,202,2,23,199,2,28,248,22,149, -13,23,194,2,27,250,22,1,22,154,13,23,197,1,23,202,2,28,248,22,149, -13,23,194,2,192,87,94,23,193,1,27,248,22,66,23,202,1,28,248,22,72, -23,194,2,87,94,23,193,1,248,23,199,1,251,22,141,7,2,23,23,202,1, -28,248,22,72,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,154,13, -23,207,1,23,208,1,23,201,1,27,249,22,154,13,248,22,65,23,197,2,23, -202,2,28,248,22,149,13,23,194,2,27,250,22,1,22,154,13,23,197,1,204, -28,248,22,149,13,193,192,253,2,37,203,204,205,206,23,15,248,22,66,201,253, -2,37,202,203,204,205,206,248,22,66,200,87,94,23,193,1,27,248,22,66,23, -201,1,28,248,22,72,23,194,2,87,94,23,193,1,248,23,198,1,251,22,141, -7,2,23,23,201,1,28,248,22,72,23,205,2,87,94,23,204,1,23,203,1, -250,22,1,22,154,13,23,206,1,23,207,1,23,200,1,27,249,22,154,13,248, -22,65,23,197,2,23,201,2,28,248,22,149,13,23,194,2,27,250,22,1,22, -154,13,23,197,1,203,28,248,22,149,13,193,192,253,2,37,202,203,204,205,206, -248,22,66,201,253,2,37,201,202,203,204,205,248,22,66,200,27,247,22,177,13, -253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,137,13,23,194,2,10, -27,248,22,136,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,22, -157,6,23,195,2,27,248,22,158,13,23,196,2,28,23,193,2,192,87,94,23, -193,1,248,22,159,13,23,196,2,11,12,252,22,129,9,23,200,2,2,24,35, -23,198,2,23,199,2,28,28,248,22,157,6,23,195,2,10,248,22,145,7,23, -195,2,87,94,23,194,1,12,252,22,129,9,23,200,2,2,25,36,23,198,2, -23,199,1,91,159,38,11,90,161,38,35,11,248,22,157,13,23,197,2,87,94, -23,195,1,87,94,28,192,12,250,22,130,9,23,201,1,2,26,23,199,1,249, -22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,137,13, -23,196,2,10,27,248,22,136,13,23,197,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198,2,28,23,193,2, -192,87,94,23,193,1,248,22,159,13,23,198,2,11,12,252,22,129,9,2,9, -2,24,35,23,200,2,23,201,2,28,28,248,22,157,6,23,197,2,10,248,22, -145,7,23,197,2,12,252,22,129,9,2,9,2,25,36,23,200,2,23,201,2, -91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2,87,94,23,195,1, -87,94,28,192,12,250,22,130,9,2,9,2,26,23,201,2,249,22,7,194,195, -27,249,22,146,13,250,22,129,14,0,18,35,114,120,35,34,40,91,46,93,91, -94,46,93,42,124,41,36,34,248,22,142,13,23,201,1,28,248,22,157,6,23, -203,2,249,22,169,7,23,204,1,8,63,23,202,1,28,248,22,137,13,23,199, -2,248,22,138,13,23,199,1,87,94,23,198,1,247,22,139,13,28,248,22,136, -13,194,249,22,154,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95,28, -28,248,22,137,13,23,196,2,10,27,248,22,136,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198, -2,28,23,193,2,192,87,94,23,193,1,248,22,159,13,23,198,2,11,12,252, -22,129,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,157,6,23, -197,2,10,248,22,145,7,23,197,2,12,252,22,129,9,2,10,2,25,36,23, -200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2, -87,94,23,195,1,87,94,28,192,12,250,22,130,9,2,10,2,26,23,201,2, -249,22,7,194,195,27,249,22,146,13,249,22,155,7,250,22,130,14,0,9,35, -114,120,35,34,91,46,93,34,248,22,142,13,23,203,1,6,1,1,95,28,248, -22,157,6,23,202,2,249,22,169,7,23,203,1,8,63,23,201,1,28,248,22, -137,13,23,199,2,248,22,138,13,23,199,1,87,94,23,198,1,247,22,139,13, -28,248,22,136,13,194,249,22,154,13,195,194,192,249,247,22,188,4,194,11,249, -80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,179,13,249,80,158, -38,47,28,23,195,2,27,248,22,174,7,6,11,11,80,76,84,67,79,76,76, -69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22,154, -13,248,22,175,13,69,97,100,100,111,110,45,100,105,114,247,22,172,7,6,8, -8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,78,23, -203,1,248,22,74,248,22,175,13,72,99,111,108,108,101,99,116,115,45,100,105, -114,23,204,1,28,23,194,2,249,22,64,23,196,1,23,195,1,192,32,47,89, -162,8,44,38,54,2,18,222,33,48,27,249,22,186,13,23,197,2,23,198,2, -28,23,193,2,87,94,23,196,1,27,248,22,89,23,195,2,27,27,248,22,98, -23,197,1,27,249,22,186,13,23,201,2,23,196,2,28,23,193,2,87,94,23, -194,1,27,248,22,89,23,195,2,27,250,2,47,23,203,2,23,204,1,248,22, -98,23,199,1,28,249,22,151,7,23,196,2,2,27,249,22,78,23,202,2,194, -249,22,64,248,22,145,13,23,197,1,23,195,1,87,95,23,199,1,23,193,1, -28,249,22,151,7,23,196,2,2,27,249,22,78,23,200,2,9,249,22,64,248, -22,145,13,23,197,1,9,28,249,22,151,7,23,196,2,2,27,249,22,78,197, -194,87,94,23,196,1,249,22,64,248,22,145,13,23,197,1,194,87,94,23,193, -1,28,249,22,151,7,23,198,2,2,27,249,22,78,195,9,87,94,23,194,1, -249,22,64,248,22,145,13,23,199,1,9,87,95,28,28,248,22,145,7,194,10, -248,22,157,6,194,12,250,22,129,9,2,13,6,21,21,98,121,116,101,32,115, -116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,73, -195,249,22,4,22,136,13,196,11,12,250,22,129,9,2,13,6,13,13,108,105, -115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,157, -6,197,248,22,168,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53, -32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,33, -52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2, -87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,162,13,23,201,2, -28,249,22,164,8,23,195,2,23,202,2,11,28,248,22,158,13,23,194,2,250, -2,51,23,201,2,23,202,2,249,22,154,13,23,200,2,23,198,1,250,2,51, -23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,27, -28,248,22,136,13,23,196,2,27,249,22,154,13,23,198,2,23,201,2,28,28, -248,22,149,13,193,10,248,22,148,13,193,192,11,11,28,23,193,2,192,87,94, -23,193,1,28,23,199,2,11,27,248,22,162,13,23,202,2,28,249,22,164,8, -23,195,2,23,203,1,11,28,248,22,158,13,23,194,2,250,2,51,23,202,1, -23,203,1,249,22,154,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28, -248,22,72,23,197,2,11,27,248,22,161,13,248,22,65,23,199,2,27,249,22, -154,13,23,196,1,23,197,2,28,248,22,148,13,23,194,2,250,2,51,198,199, -195,87,94,23,193,1,27,248,22,66,23,200,1,28,248,22,72,23,194,2,11, -27,248,22,161,13,248,22,65,23,196,2,27,249,22,154,13,23,196,1,23,200, -2,28,248,22,148,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27, -248,22,66,23,197,1,28,248,22,72,23,194,2,11,27,248,22,161,13,248,22, -65,195,27,249,22,154,13,23,196,1,202,28,248,22,148,13,193,250,2,51,204, -205,195,251,2,50,204,205,206,248,22,66,199,87,95,28,27,248,22,136,13,23, -196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,157,6,23,196,2,27, -248,22,158,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,159,13, -23,197,2,11,12,250,22,129,9,2,14,6,25,25,112,97,116,104,32,111,114, -32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,2, -28,28,23,195,2,28,27,248,22,136,13,23,197,2,28,23,193,2,192,87,94, -23,193,1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198,2,28,23, -193,2,192,87,94,23,193,1,248,22,159,13,23,198,2,11,248,22,158,13,23, -196,2,11,10,12,250,22,129,9,2,14,6,29,29,35,102,32,111,114,32,114, -101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,110, -103,23,198,2,28,28,248,22,158,13,23,195,2,91,159,38,11,90,161,38,35, -11,248,22,157,13,23,198,2,249,22,162,8,194,68,114,101,108,97,116,105,118, -101,11,27,248,22,174,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23, -200,1,23,201,1,28,23,197,2,27,249,80,158,43,47,23,200,1,9,28,249, -22,162,8,247,22,176,7,2,20,249,22,64,248,22,145,13,5,1,46,23,195, -1,192,9,27,248,22,161,13,23,196,1,28,248,22,148,13,193,250,2,51,198, -199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11,87,94, -249,22,148,6,247,22,184,4,195,248,22,174,5,249,22,170,3,35,249,22,154, -3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,87,94, -23,197,1,27,248,22,175,13,2,19,27,249,80,158,40,48,23,196,1,11,27, -27,248,22,173,3,23,200,1,28,192,192,35,27,27,248,22,173,3,23,202,1, -28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,95,89,162,8,44, -35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,136,5,23,195, -1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,11,16,0,83,158, -41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11,11,10,10,42,80, -158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2,4,2,5,2,6, -2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,30,2,17, -1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101, -121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116, -101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0,35,16,0,35,16, -4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,16,11,2,7,2, -6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,16,11, -11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6,2,15,2,14, -2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36,11,11,16,0, -16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,17, -83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159,35,53,36, -83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80,159,35,52, -36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30,80,159,35, -35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,36,36,83, -158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35,37,36,83, -158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80,159,35,38, -36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33,34,80,159, -35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6,223,0,33,36,80, -159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,7,222,33,39, -80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,8,222,33, -40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,2,9,222, -33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,53,2,10, -222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,36,43,2, -11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2, -12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,0,33,45, -89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,16,2,27, -248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,2,20,6, -1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,97,93,42, -41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,13, -223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2, -14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9,223,0,33, -55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36,83,158,35,16,2, -89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36,94,29,94,2,16, -68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35,37,109,105,110,45, -115,116,120,11,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 5006); +2,92,49,80,159,43,36,37,2,20,28,248,22,158,6,194,248,22,146,13,194, +193,87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,23,196, +2,2,21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22, +166,10,248,22,187,6,250,22,142,7,2,22,23,200,1,23,201,1,247,22,23, +87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,192, +87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,23,196,2, +2,21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22,166, +10,248,22,187,6,250,22,142,7,2,22,23,200,1,23,201,1,247,22,23,87, +94,87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,195,2, +21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22,166,10, +248,22,187,6,250,22,142,7,2,22,199,23,201,1,247,22,23,249,22,3,89, +162,8,44,36,49,9,223,2,33,33,196,248,22,157,11,249,22,132,11,23,196, +1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41, +36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162, +43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94, +23,198,1,248,23,196,1,251,22,142,7,2,23,23,199,1,28,248,22,73,23, +203,2,87,94,23,202,1,23,201,1,250,22,1,22,156,13,23,204,1,23,205, +1,23,198,1,27,249,22,156,13,248,22,66,23,202,2,23,199,2,28,248,22, +151,13,23,194,2,27,250,22,1,22,156,13,23,197,1,23,202,2,28,248,22, +151,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, +73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,142,7,2,23,23,202, +1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,156, +13,23,207,1,23,208,1,23,201,1,27,249,22,156,13,248,22,66,23,197,2, +23,202,2,28,248,22,151,13,23,194,2,27,250,22,1,22,156,13,23,197,1, +204,28,248,22,151,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, +253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67, +23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22, +142,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203, +1,250,22,1,22,156,13,23,206,1,23,207,1,23,200,1,27,249,22,156,13, +248,22,66,23,197,2,23,201,2,28,248,22,151,13,23,194,2,27,250,22,1, +22,156,13,23,197,1,203,28,248,22,151,13,193,192,253,2,37,202,203,204,205, +206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,179, +13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,139,13,23,194,2, +10,27,248,22,138,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, +22,158,6,23,195,2,27,248,22,160,13,23,196,2,28,23,193,2,192,87,94, +23,193,1,248,22,161,13,23,196,2,11,12,252,22,131,9,23,200,2,2,24, +35,23,198,2,23,199,2,28,28,248,22,158,6,23,195,2,10,248,22,146,7, +23,195,2,87,94,23,194,1,12,252,22,131,9,23,200,2,2,25,36,23,198, +2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,159,13,23,197,2,87, +94,23,195,1,87,94,28,192,12,250,22,132,9,23,201,1,2,26,23,199,1, +249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,139, +13,23,196,2,10,27,248,22,138,13,23,197,2,28,23,193,2,192,87,94,23, +193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23,198,2,28,23,193, +2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,12,252,22,131,9,2, +9,2,24,35,23,200,2,23,201,2,28,28,248,22,158,6,23,197,2,10,248, +22,146,7,23,197,2,12,252,22,131,9,2,9,2,25,36,23,200,2,23,201, +2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199,2,87,94,23,195, +1,87,94,28,192,12,250,22,132,9,2,9,2,26,23,201,2,249,22,7,194, +195,27,249,22,148,13,250,22,131,14,0,18,35,114,120,35,34,40,91,46,93, +91,94,46,93,42,124,41,36,34,248,22,144,13,23,201,1,28,248,22,158,6, +23,203,2,249,22,170,7,23,204,1,8,63,23,202,1,28,248,22,139,13,23, +199,2,248,22,140,13,23,199,1,87,94,23,198,1,247,22,141,13,28,248,22, +138,13,194,249,22,156,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95, +28,28,248,22,139,13,23,196,2,10,27,248,22,138,13,23,197,2,28,23,193, +2,192,87,94,23,193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23, +198,2,28,23,193,2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,12, +252,22,131,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,158,6, +23,197,2,10,248,22,146,7,23,197,2,12,252,22,131,9,2,10,2,25,36, +23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199, +2,87,94,23,195,1,87,94,28,192,12,250,22,132,9,2,10,2,26,23,201, +2,249,22,7,194,195,27,249,22,148,13,249,22,156,7,250,22,132,14,0,9, +35,114,120,35,34,91,46,93,34,248,22,144,13,23,203,1,6,1,1,95,28, +248,22,158,6,23,202,2,249,22,170,7,23,203,1,8,63,23,201,1,28,248, +22,139,13,23,199,2,248,22,140,13,23,199,1,87,94,23,198,1,247,22,141, +13,28,248,22,138,13,194,249,22,156,13,195,194,192,249,247,22,189,4,194,11, +249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,181,13,249,80, +158,38,47,28,23,195,2,27,248,22,175,7,6,11,11,80,76,84,67,79,76, +76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22, +156,13,248,22,177,13,69,97,100,100,111,110,45,100,105,114,247,22,173,7,6, +8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,79, +23,203,1,248,22,75,248,22,177,13,72,99,111,108,108,101,99,116,115,45,100, +105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192,32,47, +89,162,8,44,38,54,2,18,222,33,48,27,249,22,188,13,23,197,2,23,198, +2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27,248,22, +99,23,197,1,27,249,22,188,13,23,201,2,23,196,2,28,23,193,2,87,94, +23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204,1,248, +22,99,23,199,1,28,249,22,152,7,23,196,2,2,27,249,22,79,23,202,2, +194,249,22,65,248,22,147,13,23,197,1,23,195,1,87,95,23,199,1,23,193, +1,28,249,22,152,7,23,196,2,2,27,249,22,79,23,200,2,9,249,22,65, +248,22,147,13,23,197,1,9,28,249,22,152,7,23,196,2,2,27,249,22,79, +197,194,87,94,23,196,1,249,22,65,248,22,147,13,23,197,1,194,87,94,23, +193,1,28,249,22,152,7,23,198,2,2,27,249,22,79,195,9,87,94,23,194, +1,249,22,65,248,22,147,13,23,199,1,9,87,95,28,28,248,22,146,7,194, +10,248,22,158,6,194,12,250,22,131,9,2,13,6,21,21,98,121,116,101,32, +115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22, +74,195,249,22,4,22,138,13,196,11,12,250,22,131,9,2,13,6,13,13,108, +105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22, +158,6,197,248,22,169,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33, +53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222, +33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199, +2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,164,13,23,201, +2,28,249,22,165,8,23,195,2,23,202,2,11,28,248,22,160,13,23,194,2, +250,2,51,23,201,2,23,202,2,249,22,156,13,23,200,2,23,198,1,250,2, +51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1, +27,28,248,22,138,13,23,196,2,27,249,22,156,13,23,198,2,23,201,2,28, +28,248,22,151,13,193,10,248,22,150,13,193,192,11,11,28,23,193,2,192,87, +94,23,193,1,28,23,199,2,11,27,248,22,164,13,23,202,2,28,249,22,165, +8,23,195,2,23,203,1,11,28,248,22,160,13,23,194,2,250,2,51,23,202, +1,23,203,1,249,22,156,13,23,201,1,23,198,1,250,2,51,201,202,195,194, +28,248,22,73,23,197,2,11,27,248,22,163,13,248,22,66,23,199,2,27,249, +22,156,13,23,196,1,23,197,2,28,248,22,150,13,23,194,2,250,2,51,198, +199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23,194,2, +11,27,248,22,163,13,248,22,66,23,196,2,27,249,22,156,13,23,196,1,23, +200,2,28,248,22,150,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1, +27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,163,13,248, +22,66,195,27,249,22,156,13,23,196,1,202,28,248,22,150,13,193,250,2,51, +204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,138,13, +23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,158,6,23,196,2, +27,248,22,160,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,161, +13,23,197,2,11,12,250,22,131,9,2,14,6,25,25,112,97,116,104,32,111, +114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197, +2,28,28,23,195,2,28,27,248,22,138,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23,198,2,28, +23,193,2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,248,22,160,13, +23,196,2,11,10,12,250,22,131,9,2,14,6,29,29,35,102,32,111,114,32, +114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105, +110,103,23,198,2,28,28,248,22,160,13,23,195,2,91,159,38,11,90,161,38, +35,11,248,22,159,13,23,198,2,249,22,163,8,194,68,114,101,108,97,116,105, +118,101,11,27,248,22,175,7,6,4,4,80,65,84,72,251,2,50,23,199,1, +23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9, +28,249,22,163,8,247,22,177,7,2,20,249,22,65,248,22,147,13,5,1,46, +23,195,1,192,9,27,248,22,163,13,23,196,1,28,248,22,150,13,193,250,2, +51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11, +87,94,249,22,149,6,247,22,185,4,195,248,22,175,5,249,22,171,3,35,249, +22,155,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1, +87,94,23,197,1,27,248,22,177,13,2,19,27,249,80,159,40,48,37,23,196, +1,11,27,27,248,22,174,3,23,200,1,28,192,192,35,27,27,248,22,174,3, +23,202,1,28,192,192,35,249,22,152,5,23,197,1,83,158,39,20,97,95,89, +162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,137, +5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,11,16, +0,83,158,41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11,11,10, +10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2,4,2, +5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15, +30,2,17,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, +45,107,101,121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97,114,97, +109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0,35,16, +0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,16,11, +2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2, +1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6,2, +15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36,11, +11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16, +0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159, +35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80, +159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30, +80,159,35,35,36,83,158,35,16,2,249,22,160,6,7,92,7,92,80,159,35, +36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35, +37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80, +159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33, +34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6,223,0, +33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,7, +222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2, +8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52, +2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37, +53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43, +36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20, +96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223, +0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35, +16,2,27,248,22,184,13,248,22,169,7,27,28,249,22,163,8,247,22,177,7, +2,20,6,1,1,59,6,1,1,58,250,22,142,7,6,14,14,40,91,94,126, +97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37, +47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20, +96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9, +223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36,83,158, +35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36,94,29, +94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35,37,109, +105,110,45,115,116,120,11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 5009); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, @@ -360,12 +360,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 294); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, -0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,80,1, -88,1,191,1,236,1,0,2,28,2,59,2,114,2,124,2,171,2,181,2,188, -2,75,4,88,4,107,4,226,4,238,4,134,5,148,5,12,6,18,6,32,6, -59,6,144,6,146,6,211,6,146,12,205,12,237,12,0,0,116,15,0,0,70, +0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, +89,1,196,1,241,1,5,2,34,2,65,2,121,2,131,2,178,2,188,2,195, +2,82,4,95,4,114,4,233,4,245,4,141,5,155,5,21,6,27,6,41,6, +68,6,153,6,155,6,221,6,166,12,225,12,3,13,0,0,138,15,0,0,70, 100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108, 111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116, 101,29,94,2,3,67,35,37,117,116,105,108,115,11,29,94,2,3,68,35,37, @@ -381,179 +381,180 @@ 118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46,122,111,6,6,6, 110,97,116,105,118,101,64,108,111,111,112,1,29,115,116,97,110,100,97,114,100, 45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114, -63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,158,37,45,249, -80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,162,8,23,197,2,80, -158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,171,4,23,197,2,28, -248,22,136,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23, -197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40,47, -192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,189,4,28,192, -192,247,22,176,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11, -80,158,40,39,22,189,4,28,248,22,136,13,23,198,2,23,197,1,87,94,23, -197,1,247,22,176,13,247,194,250,22,154,13,23,197,1,23,199,1,249,80,158, -42,38,23,198,1,2,17,252,22,154,13,23,199,1,23,201,1,2,18,247,22, -177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94,23,194,1,27,250, -22,171,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,64, -195,194,11,27,252,22,154,13,23,200,1,23,202,1,2,18,247,22,177,7,249, -80,158,45,38,23,201,1,80,158,45,35,27,250,22,171,13,196,11,32,0,89, -162,8,44,35,40,9,222,11,28,192,249,22,64,195,194,11,249,247,22,181,13, -248,22,65,195,195,27,250,22,154,13,23,198,1,23,200,1,249,80,158,43,38, -23,199,1,2,17,27,250,22,171,13,196,11,32,0,89,162,8,44,35,40,9, -222,11,28,192,249,22,64,195,194,11,249,247,22,187,4,248,22,65,195,195,249, -247,22,187,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250,22,129, -9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,6,25, -25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116,104,32,115, -116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28,248,22,160, -13,23,201,2,23,200,1,27,247,22,189,4,28,23,193,2,249,22,161,13,23, -203,1,23,195,1,200,90,161,38,36,11,248,22,157,13,23,194,2,87,94,23, -196,1,90,161,36,39,11,28,249,22,162,8,23,196,2,68,114,101,108,97,116, -105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11,247,22,178, -13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89,162,43,36, -51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46,9,223,5, -33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44,36,52,9, -225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192,192,28,193, -28,23,196,2,28,249,22,166,3,248,22,66,196,248,22,66,23,199,2,193,11, -11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162,43,35,45,9,224, -14,2,33,31,87,94,23,193,1,27,28,23,197,1,27,249,22,5,83,158,39, -20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,32,23,203,1,23,206, -1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,166,3,248,22,66, -196,248,22,66,199,193,11,11,11,11,28,192,249,80,159,48,54,36,203,89,162, -43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162,43,35,44, -9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33,38,0,17, -35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27,249,22,186, -13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89, -23,196,2,27,248,22,98,23,197,1,27,249,22,186,13,2,37,23,196,2,28, -23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,27,248,22,98, -23,197,1,27,249,22,186,13,2,37,23,196,2,28,23,193,2,87,94,23,194, -1,249,22,64,248,22,89,23,196,2,248,2,36,248,22,98,23,197,1,248,22, -74,194,248,22,74,194,248,22,74,194,32,39,89,162,43,36,54,2,19,222,33, -40,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159, -37,11,90,161,37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66, -23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,27, -248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248, -22,65,195,91,159,37,11,90,161,37,35,11,248,2,39,248,22,66,23,197,2, -249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22, -64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65,23, -200,1,23,197,1,195,27,248,2,36,23,195,1,28,194,192,248,2,39,193,87, -95,28,248,22,169,4,195,12,250,22,129,9,2,20,6,20,20,114,101,115,111, -108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28,24,193,2, -248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,138,2,80,158,41,42, -248,22,142,14,247,22,183,11,11,28,23,193,2,192,87,94,23,193,1,27,247, -22,122,87,94,250,22,136,2,80,158,42,42,248,22,142,14,247,22,183,11,195, -192,250,22,136,2,195,198,66,97,116,116,97,99,104,251,211,197,198,199,10,28, -192,250,22,128,9,11,196,195,248,22,190,8,194,28,249,22,163,6,194,6,1, -1,46,2,16,28,249,22,163,6,194,6,2,2,46,46,62,117,112,192,28,249, -22,164,8,248,22,66,23,200,2,23,197,1,28,249,22,162,8,248,22,65,23, -200,2,23,196,1,251,22,190,8,2,20,6,26,26,99,121,99,108,101,32,105, -110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58,32,126,101,23,200, -1,249,22,2,22,66,248,22,79,249,22,64,23,206,1,23,202,1,12,12,247, -192,20,14,159,80,158,39,44,249,22,64,248,22,142,14,247,22,183,11,23,197, -1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,27,11,80,158,44,39, -22,151,4,23,196,1,249,247,22,188,4,23,198,1,248,22,53,248,22,140,13, -23,198,1,87,94,28,28,248,22,136,13,23,197,2,10,248,22,175,4,23,197, -2,12,28,23,198,2,250,22,128,9,11,6,15,15,98,97,100,32,109,111,100, -117,108,101,32,112,97,116,104,23,201,2,250,22,129,9,2,20,6,19,19,109, -111,100,117,108,101,45,112,97,116,104,32,111,114,32,112,97,116,104,23,199,2, -28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23,199,2,2,3,11, -248,22,170,4,248,22,89,197,28,28,248,22,62,23,197,2,249,22,162,8,248, -22,65,23,199,2,66,112,108,97,110,101,116,11,87,94,28,207,12,20,14,159, -80,158,37,39,250,80,158,40,40,249,22,27,11,80,158,42,39,22,183,11,23, -197,1,90,161,36,35,10,249,22,152,4,21,94,2,21,6,18,18,112,108,97, -110,101,116,47,114,101,115,111,108,118,101,114,46,115,115,1,27,112,108,97,110, -101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118, -101,114,12,251,211,199,200,201,202,87,94,23,193,1,27,89,162,8,44,36,45, -79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223, -6,33,44,27,28,248,22,52,23,199,2,27,250,22,138,2,80,158,43,43,249, -22,64,23,204,2,247,22,177,13,11,28,23,193,2,192,87,94,23,193,1,91, -159,37,11,90,161,37,35,11,249,80,159,44,48,36,248,22,55,23,204,2,11, -27,251,80,158,47,50,2,20,23,202,1,28,248,22,72,23,199,2,23,199,2, -248,22,65,23,199,2,28,248,22,72,23,199,2,9,248,22,66,23,199,2,249, -22,154,13,23,195,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7, -109,97,105,110,46,115,115,249,22,180,6,23,199,1,6,3,3,46,115,115,28, -248,22,157,6,23,199,2,87,94,23,194,1,27,248,80,159,41,55,36,23,201, -2,27,250,22,138,2,80,158,44,43,249,22,64,23,205,2,23,199,2,11,28, -23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159, -45,48,36,23,204,2,11,250,22,1,22,154,13,23,199,1,249,22,78,249,22, -2,32,0,89,162,8,44,36,43,9,222,33,45,23,200,1,248,22,74,23,200, -1,28,248,22,136,13,23,199,2,87,94,23,194,1,28,248,22,159,13,23,199, -2,23,198,2,248,22,74,6,26,26,32,40,97,32,112,97,116,104,32,109,117, -115,116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,162,8,248, -22,65,23,201,2,2,21,27,250,22,138,2,80,158,43,43,249,22,64,23,204, -2,247,22,177,13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90, -161,37,35,11,249,80,159,45,48,36,248,22,89,23,205,2,11,90,161,36,37, -11,28,248,22,72,248,22,91,23,204,2,28,248,22,72,23,194,2,249,22,188, -13,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197, -2,249,22,78,28,248,22,72,248,22,91,23,208,2,21,93,6,5,5,109,122, -108,105,98,249,22,1,22,78,249,22,2,80,159,51,56,36,248,22,91,23,211, -2,23,197,2,28,248,22,72,23,196,2,248,22,74,23,197,2,23,195,2,251, -80,158,49,50,2,20,23,204,1,248,22,65,23,198,2,248,22,66,23,198,1, -249,22,154,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,248, -22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,28, -249,22,188,13,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,249, -22,180,6,23,199,1,6,3,3,46,115,115,28,249,22,162,8,248,22,65,23, -201,2,64,102,105,108,101,249,22,161,13,248,22,165,13,248,22,89,23,202,2, -248,80,159,42,55,36,23,202,2,12,87,94,28,28,248,22,136,13,23,194,2, -10,248,22,179,7,23,194,2,87,94,23,200,1,12,28,23,200,2,250,22,128, -9,67,114,101,113,117,105,114,101,249,22,141,7,6,17,17,98,97,100,32,109, -111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23,199, -2,6,0,0,23,203,1,87,94,23,200,1,250,22,129,9,2,20,249,22,141, -7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2, -248,22,65,23,199,2,6,0,0,23,201,2,27,28,248,22,179,7,23,195,2, -249,22,184,7,23,196,2,35,249,22,163,13,248,22,164,13,23,197,2,11,27, -28,248,22,179,7,23,196,2,249,22,184,7,23,197,2,36,248,80,158,42,51, -23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,179,7,23,199,2,250, -22,7,2,22,249,22,184,7,23,203,2,37,2,22,248,22,157,13,23,198,2, -87,95,23,195,1,23,193,1,27,28,248,22,179,7,23,200,2,249,22,184,7, -23,201,2,38,249,80,158,47,52,23,197,2,5,0,27,28,248,22,179,7,23, -201,2,249,22,184,7,23,202,2,39,248,22,170,4,23,200,2,27,27,250,22, -138,2,80,158,51,42,248,22,142,14,247,22,183,11,11,28,23,193,2,192,87, -94,23,193,1,27,247,22,122,87,94,250,22,136,2,80,158,52,42,248,22,142, -14,247,22,183,11,195,192,87,95,28,23,209,1,27,250,22,138,2,23,197,2, -197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80,158,51,45,80,158, -50,45,247,22,19,250,22,25,248,22,23,23,197,2,80,158,53,44,23,196,1, -27,248,22,142,14,247,22,183,11,249,22,3,83,158,39,20,97,94,89,162,8, -44,36,54,9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22, -17,80,158,50,45,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36, -89,162,43,35,50,9,227,14,9,8,4,3,33,48,250,22,136,2,23,197,1, -197,10,12,28,28,248,22,179,7,23,202,1,11,27,248,22,157,6,23,208,2, -28,192,192,28,248,22,62,23,208,2,249,22,162,8,248,22,65,23,210,2,2, -21,11,250,22,136,2,80,158,50,43,28,248,22,157,6,23,210,2,249,22,64, -23,211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,64,23, -211,1,247,22,177,13,252,22,181,7,23,208,1,23,207,1,23,205,1,23,203, -1,201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158, -38,20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43, -38,48,9,223,1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208, -87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,22,188,4,80,158, -36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16, -0,83,158,41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,10, -36,80,158,35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,97, -116,104,45,115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,97, -100,100,45,115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109,101, -116,101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23,101, -120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111, -110,3,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,30, -2,4,69,45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114,109, -97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116,104, -45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0,11, -11,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2,12, -2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2,15, -16,1,11,16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35,11, -11,11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,162, -43,36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,43, -36,44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,36, -48,67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,35, -16,2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,80, -159,35,54,36,83,158,35,16,2,248,22,176,7,69,115,111,45,115,117,102,102, -105,120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,0, -33,35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2, -6,222,192,80,159,35,41,36,83,158,35,16,2,247,22,125,80,159,35,42,36, -83,158,35,16,2,247,22,124,80,159,35,43,36,83,158,35,16,2,247,22,60, -80,159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,45, -108,111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,35, -46,83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,43, -37,44,2,13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,44, -36,44,2,14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,43, -35,43,2,15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35,37, -107,101,114,110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116,120, -11,2,4,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4081); +63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37, +249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,163,8,23,197,2, +80,159,38,46,37,87,94,23,195,1,80,159,36,47,37,27,248,22,172,4,23, +197,2,28,248,22,138,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22, +159,13,23,197,1,87,95,83,160,37,11,80,159,40,46,37,198,83,160,37,11, +80,159,40,47,37,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247, +22,190,4,28,192,192,247,22,178,13,20,14,159,80,158,35,39,250,80,158,38, +40,249,22,27,11,80,158,40,39,22,190,4,28,248,22,138,13,23,198,2,23, +197,1,87,94,23,197,1,247,22,178,13,247,194,250,22,156,13,23,197,1,23, +199,1,249,80,158,42,38,23,198,1,2,17,252,22,156,13,23,199,1,23,201, +1,2,18,247,22,178,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87, +94,23,194,1,27,250,22,173,13,196,11,32,0,89,162,8,44,35,40,9,222, +11,28,192,249,22,65,195,194,11,27,252,22,156,13,23,200,1,23,202,1,2, +18,247,22,178,7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22, +173,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195, +194,11,249,247,22,183,13,248,22,66,195,195,27,250,22,156,13,23,198,1,23, +200,1,249,80,158,43,38,23,199,1,2,17,27,250,22,173,13,196,11,32,0, +89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,188, +4,248,22,66,195,195,249,247,22,188,4,194,195,87,94,28,248,80,158,36,37, +23,195,2,12,250,22,131,9,77,108,111,97,100,47,117,115,101,45,99,111,109, +112,105,108,101,100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100, +45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161, +36,35,11,28,248,22,162,13,23,201,2,23,200,1,27,247,22,190,4,28,23, +193,2,249,22,163,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,159, +13,23,194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,163,8,23,196, +2,68,114,101,108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90, +161,36,40,11,247,22,180,13,27,89,162,43,36,49,62,122,111,225,7,5,3, +33,27,27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162, +8,44,36,46,9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5, +89,162,8,44,36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2, +11,193,28,192,192,28,193,28,23,196,2,28,249,22,167,3,248,22,67,196,248, +22,67,23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202, +89,162,43,35,45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1, +27,249,22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10, +33,32,23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28, +249,22,167,3,248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80, +159,48,54,36,203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54, +36,203,89,162,43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54, +2,19,222,33,38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42, +41,36,34,27,249,22,188,13,2,37,23,196,2,28,23,193,2,87,94,23,194, +1,249,22,65,248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,188, +13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90, +23,196,2,27,248,22,99,23,197,1,27,249,22,188,13,2,37,23,196,2,28, +23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248, +22,99,23,197,1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162, +43,36,54,2,19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7, +9,248,22,66,195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2, +28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37, +11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23, +195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2, +39,248,22,67,23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197, +1,195,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7, +249,22,65,248,22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28, +194,192,248,2,39,193,87,95,28,248,22,170,4,195,12,250,22,131,9,2,20, +6,20,20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, +116,104,197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250, +22,139,2,80,159,41,42,37,248,22,144,14,247,22,185,11,11,28,23,193,2, +192,87,94,23,193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37, +248,22,144,14,247,22,185,11,195,192,250,22,137,2,195,198,66,97,116,116,97, +99,104,251,211,197,198,199,10,28,192,250,22,130,9,11,196,195,248,22,128,9, +194,28,249,22,164,6,194,6,1,1,46,2,16,28,249,22,164,6,194,6,2, +2,46,46,62,117,112,192,28,249,22,165,8,248,22,67,23,200,2,23,197,1, +28,249,22,163,8,248,22,66,23,200,2,23,196,1,251,22,128,9,2,20,6, +26,26,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116, +32,126,101,58,32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65, +23,206,1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65, +248,22,144,14,247,22,185,11,23,197,1,20,14,159,80,158,39,39,250,80,158, +42,40,249,22,27,11,80,158,44,39,22,152,4,23,196,1,249,247,22,189,4, +23,198,1,248,22,54,248,22,142,13,23,198,1,87,94,28,28,248,22,138,13, +23,197,2,10,248,22,176,4,23,197,2,12,28,23,198,2,250,22,130,9,11, +6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2, +250,22,131,9,2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32, +111,114,32,112,97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,163, +8,248,22,66,23,199,2,2,3,11,248,22,171,4,248,22,90,197,28,28,248, +22,63,23,197,2,249,22,163,8,248,22,66,23,199,2,66,112,108,97,110,101, +116,11,87,94,28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22, +27,11,80,158,42,39,22,185,11,23,197,1,90,161,36,35,10,249,22,153,4, +21,94,2,21,6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101, +114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110, +97,109,101,45,114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94, +23,193,1,27,89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101, +99,116,105,111,110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2, +27,250,22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,179,13,11, +28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80, +159,44,48,36,248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202, +1,28,248,22,73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73, +23,199,2,9,248,22,67,23,199,2,249,22,156,13,23,195,1,28,248,22,73, +23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,181, +6,23,199,1,6,3,3,46,115,115,28,248,22,158,6,23,199,2,87,94,23, +194,1,27,248,80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43, +37,249,22,65,23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1, +91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22, +1,22,156,13,23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43, +9,222,33,45,23,200,1,248,22,75,23,200,1,28,248,22,138,13,23,199,2, +87,94,23,194,1,28,248,22,161,13,23,199,2,23,198,2,248,22,75,6,26, +26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115, +111,108,117,116,101,41,28,249,22,163,8,248,22,66,23,201,2,2,21,27,250, +22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,179,13,11,28,23, +193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45, +48,36,248,22,90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92, +23,204,2,28,248,22,73,23,194,2,249,22,190,13,0,8,35,114,120,34,91, +46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73, +248,22,92,23,208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79, +249,22,2,80,159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73, +23,196,2,248,22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204, +1,248,22,66,23,198,2,248,22,67,23,198,1,249,22,156,13,23,195,1,28, +23,198,1,87,94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23, +197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,190,13,0,8,35,114, +120,34,91,46,93,34,23,199,2,23,197,1,249,22,181,6,23,199,1,6,3, +3,46,115,115,28,249,22,163,8,248,22,66,23,201,2,64,102,105,108,101,249, +22,163,13,248,22,167,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202, +2,12,87,94,28,28,248,22,138,13,23,194,2,10,248,22,180,7,23,194,2, +87,94,23,200,1,12,28,23,200,2,250,22,130,9,67,114,101,113,117,105,114, +101,249,22,142,7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97, +116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87, +94,23,200,1,250,22,131,9,2,20,249,22,142,7,6,13,13,109,111,100,117, +108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0, +0,23,201,2,27,28,248,22,180,7,23,195,2,249,22,185,7,23,196,2,35, +249,22,165,13,248,22,166,13,23,197,2,11,27,28,248,22,180,7,23,196,2, +249,22,185,7,23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90, +161,38,35,11,28,248,22,180,7,23,199,2,250,22,7,2,22,249,22,185,7, +23,203,2,37,2,22,248,22,159,13,23,198,2,87,95,23,195,1,23,193,1, +27,28,248,22,180,7,23,200,2,249,22,185,7,23,201,2,38,249,80,158,47, +52,23,197,2,5,0,27,28,248,22,180,7,23,201,2,249,22,185,7,23,202, +2,39,248,22,171,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248, +22,144,14,247,22,185,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22, +123,87,94,250,22,137,2,80,159,52,42,37,248,22,144,14,247,22,185,11,195, +192,87,95,28,23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1, +12,87,95,27,27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22, +19,250,22,25,248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22, +144,14,247,22,185,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54, +9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159, +50,45,37,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162, +43,35,50,9,227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10, +12,28,28,248,22,180,7,23,202,1,11,27,248,22,158,6,23,208,2,28,192, +192,28,248,22,63,23,208,2,249,22,163,8,248,22,66,23,210,2,2,21,11, +250,22,137,2,80,159,50,43,37,28,248,22,158,6,23,210,2,249,22,65,23, +211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211, +1,247,22,179,13,252,22,182,7,23,208,1,23,207,1,23,205,1,23,203,1, +201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38, +20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38, +48,9,223,1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87, +95,248,22,151,4,248,80,159,37,49,37,247,22,185,11,248,22,189,4,80,159, +36,36,37,248,22,176,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11, +16,0,83,158,41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10, +10,36,80,158,35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112, +97,116,104,45,115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45, +97,100,100,45,115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109, +101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23, +101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105, +111,110,3,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14, +30,2,4,69,45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114, +109,97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116, +104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0, +11,11,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2, +12,2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2, +15,16,1,11,16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35, +11,11,11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89, +162,43,36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162, +43,36,44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43, +36,48,67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158, +35,16,2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26, +80,159,35,54,36,83,158,35,16,2,248,22,177,7,69,115,111,45,115,117,102, +102,105,120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223, +0,33,35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41, +2,6,222,192,80,159,35,41,36,83,158,35,16,2,247,22,126,80,159,35,42, +36,83,158,35,16,2,247,22,125,80,159,35,43,36,83,158,35,16,2,247,22, +61,80,159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101, +45,108,111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158, +35,46,83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162, +43,37,44,2,13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8, +44,36,44,2,14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162, +43,35,43,2,15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35, +37,107,101,114,110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116, +120,11,2,4,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4103); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index d39eaef82c..43affd3fea 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -4731,6 +4731,7 @@ local_lift_expr(int argc, Scheme_Object *argv[]) Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym; Scheme_Lift_Capture_Proc cp; Scheme_Object *orig_expr; + char buf[24]; expr = argv[0]; if (!SCHEME_STXP(expr)) @@ -4753,7 +4754,13 @@ local_lift_expr(int argc, Scheme_Object *argv[]) expr = scheme_add_remove_mark(expr, local_mark); - id_sym = scheme_intern_exact_parallel_symbol("lifted", 6); + /* We don't really need a new symbol each time, since the mark + will generate new bindings. But lots of things work better or faster + when different bindings have different symbols. Use env->genv->id_counter + to help keep name generation deterministic within a module. */ + sprintf(buf, "lifted.%d", env->genv->id_counter++); + id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); id = scheme_add_remove_mark(id, scheme_new_mark()); diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index bb4b052258..86f70f09f2 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -544,7 +544,7 @@ void scheme_init_error(Scheme_Env *env) /* errors */ GLOBAL_NONCM_PRIM("error", error, 1, -1, env); GLOBAL_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env); - GLOBAL_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 4, env); + GLOBAL_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 5, env); GLOBAL_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env); GLOBAL_NONCM_PRIM("raise-mismatch-error", raise_mismatch_error, 3, 3, env); @@ -2007,7 +2007,7 @@ static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]) static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) { const char *who; - Scheme_Object *str; + Scheme_Object *str, *extra_sources = scheme_null; if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0])) scheme_wrong_type("raise-syntax-error", "symbol or #f", 0, argc, argv); @@ -2026,10 +2026,24 @@ static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) 1); } - scheme_wrong_syntax(who, - (argc > 3) ? argv[3] : NULL, - (argc > 2) ? argv[2] : NULL, - "%T", str); + if (argc > 4) { + extra_sources = argv[4]; + while (SCHEME_PAIRP(extra_sources)) { + if (!SCHEME_STXP(SCHEME_CAR(extra_sources))) + break; + } + if (!SCHEME_NULLP(extra_sources)) { + scheme_wrong_type("raise-syntax-error", "list of syntax", 4, argc, argv); + return NULL; + } + extra_sources = argv[4]; + } + + scheme_wrong_syntax_with_more_sources(who, + (argc > 3) ? argv[3] : NULL, + (argc > 2) ? argv[2] : NULL, + extra_sources, + "%T", str); return NULL; } diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index c4354e75f5..de0bf2d706 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -137,6 +137,7 @@ static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]); +static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]); @@ -317,7 +318,7 @@ scheme_init_fun (Scheme_Env *env) REGISTER_SO(call_with_prompt_proc); call_with_prompt_proc = scheme_make_prim_w_arity2(call_with_prompt, "call-with-continuation-prompt", - 1, 3, + 1, -1, 0, -1); scheme_add_global_constant("call-with-continuation-prompt", call_with_prompt_proc, @@ -497,6 +498,11 @@ scheme_init_fun (Scheme_Env *env) "procedure-reduce-arity", 2, 2), env); + scheme_add_global_constant("procedure-rename", + scheme_make_prim_w_arity(procedure_rename, + "procedure-rename", + 2, 2), + env); scheme_add_global_constant("procedure-closure-contents-eq?", scheme_make_folding_prim(procedure_equal_closure_p, "procedure-closure-contents-eq?", @@ -3133,15 +3139,21 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a) Scheme_Object *b; while (SCHEME_PROC_STRUCTP(a)) { - /* Either use struct name, or extract proc, depending - whether it's method-style */ - int is_method; - b = scheme_extract_struct_procedure(a, -1, NULL, &is_method); - if (!is_method && SCHEME_PROCP(b)) { - a = b; - SCHEME_USE_FUEL(1); - } else - break; + if (scheme_reduced_procedure_struct + && scheme_is_struct_instance(scheme_reduced_procedure_struct, a) + && SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) { + return a; + } else { + /* Either use struct name, or extract proc, depending + whether it's method-style */ + int is_method; + b = scheme_extract_struct_procedure(a, -1, NULL, &is_method); + if (!is_method && SCHEME_PROCP(b)) { + a = b; + SCHEME_USE_FUEL(1); + } else + break; + } } return a; @@ -3200,15 +3212,28 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error) Scheme_Object *other; other = scheme_proc_struct_name_source(p); if (SAME_OBJ(other, p)) { - Scheme_Object *sym; - sym = SCHEME_STRUCT_NAME_SYM(p); - *len = SCHEME_SYM_LEN(sym); - s = (char *)scheme_malloc_atomic((*len) + 8); - memcpy(s, "struct ", 7); - memcpy(s + 7, scheme_symbol_val(sym), *len); - (*len) += 7; - s[*len] = 0; - return s; + if (scheme_reduced_procedure_struct + && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) { + /* It must have a name: */ + Scheme_Object *sym = ((Scheme_Structure *)p)->slots[2]; + if (for_error < 0) { + s = (char *)sym; + *len = -1; + } else { + *len = SCHEME_SYM_LEN(sym); + s = scheme_symbol_val(sym); + } + } else { + Scheme_Object *sym; + sym = SCHEME_STRUCT_NAME_SYM(p); + *len = SCHEME_SYM_LEN(sym); + s = (char *)scheme_malloc_atomic((*len) + 8); + memcpy(s, "struct ", 7); + memcpy(s + 7, scheme_symbol_val(sym), *len); + (*len) += 7; + s[*len] = 0; + return s; + } } else { p = other; goto top; @@ -3288,8 +3313,16 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv) { Scheme_Object *a = argv[0]; - if (SCHEME_PROC_STRUCTP(a)) + if (SCHEME_PROC_STRUCTP(a)) { a = scheme_proc_struct_name_source(a); + + if (SCHEME_STRUCTP(a) + && scheme_reduced_procedure_struct + && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)) { + /* It must have a name: */ + return ((Scheme_Structure *)a)->slots[2]; + } + } if (SCHEME_STRUCTP(a)) { return SCHEME_STRUCT_NAME_SYM(a); @@ -3417,18 +3450,11 @@ static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok) return 0; } -static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) +static void init_reduced_proc_struct() { - Scheme_Object *orig, *req, *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp, *a[3]; - - if (!SCHEME_PROCP(argv[0])) - scheme_wrong_type("procedure-reduce-arity", "procedure", 0, argc, argv); - - if (!is_arity(argv[1], 1, 1)) { - scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv); - } - if (!scheme_reduced_procedure_struct) { + Scheme_Object *pr, *orig; + REGISTER_SO(scheme_reduced_procedure_struct); pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); while (((Scheme_Inspector *)pr)->superior->superior) { @@ -3438,18 +3464,52 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL, NULL, pr, - 2, 0, + 3, 0, scheme_false, scheme_make_integer(0), NULL); } +} + +static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name) +{ + Scheme_Object *a[3]; + + if (SCHEME_STRUCTP(proc) + && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) { + /* Don't need the intermediate layer */ + if (!name) + name = ((Scheme_Structure *)proc)->slots[2]; + proc = ((Scheme_Structure *)proc)->slots[0]; + } + + a[0] = proc; + a[1] = aty; + a[2] = (name ? name : scheme_false); + + return scheme_make_struct_instance(scheme_reduced_procedure_struct, 3, a); +} + +static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *orig, *req, *aty, *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp; + + if (!SCHEME_PROCP(argv[0])) + scheme_wrong_type("procedure-reduce-arity", "procedure", 0, argc, argv); + + if (!is_arity(argv[1], 1, 1)) { + scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv); + } + + init_reduced_proc_struct(); /* Check whether current arity covers the requested arity. This is a bit complicated, because both the source and target can be lists that include arity-at-least records. */ orig = get_or_check_arity(argv[0], -1, NULL); - req = argv[1]; + aty = clone_arity(argv[1]); + req = aty; if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig)) orig = scheme_make_pair(orig, scheme_null); @@ -3574,12 +3634,23 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) } /* Construct a procedure that has the given arity. */ + return make_reduced_proc(argv[0], aty, NULL); +} - a[0] = argv[0]; - pr = clone_arity(argv[1]); - a[1] = pr; +static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *aty; - return scheme_make_struct_instance(scheme_reduced_procedure_struct, 2, a); + if (!SCHEME_PROCP(argv[0])) + scheme_wrong_type("procedure-rename", "procedure", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_type("procedure-rename", "symbol", 1, argc, argv); + + init_reduced_proc_struct(); + + aty = get_or_check_arity(argv[0], -1, NULL); + + return make_reduced_proc(argv[0], aty, argv[1]); } static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]) @@ -6053,12 +6124,28 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) Scheme_Object *proc = in_argv[0], *prompt_tag; Scheme_Prompt *prompt; int argc, handler_argument_error = 0; - Scheme_Object **argv, *a[1], *handler; +# define QUICK_PROMPT_ARGS 3 + Scheme_Object **argv, *a[QUICK_PROMPT_ARGS], *handler; Scheme_Cont_Frame_Data cframe; Scheme_Dynamic_Wind *prompt_dw; int cc_count = scheme_cont_capture_count; - scheme_check_proc_arity("call-with-continuation-prompt", 0, 0, in_argc, in_argv); + argc = in_argc - 3; + if (argc <= 0) { + argc = 0; + argv = NULL; + } else { + int i; + if (argc <= QUICK_PROMPT_ARGS) + argv = a; + else + argv = MALLOC_N(Scheme_Object *, argc); + for (i = 0; i < argc; i++) { + argv[i] = in_argv[i+3]; + } + } + + scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv); if (in_argc > 1) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) { scheme_wrong_type("call-with-continuation-prompt", "continuation-prompt-tag", @@ -6075,9 +6162,6 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) } else handler = scheme_false; - argv = NULL; - argc = 0; - do { /* loop implements the default prompt handler */ diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index e40a8a8080..9ae24f51ca 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2451,6 +2451,37 @@ static int generate_nontail_self_setup(mz_jit_state *jitter) return 0; } +static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case) +{ + if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) { + if (((Scheme_Native_Closure *)p)->code->closure_size < 0) { + /* case-lambda */ + int cnt, i; + mzshort *arities; + + cnt = ((Scheme_Native_Closure *)p)->code->closure_size; + cnt = -(cnt + 1); + arities = ((Scheme_Native_Closure *)p)->code->u.arities; + for (i = 0; i < cnt; i++) { + if (arities[i] == num_rands) { + *extract_case = (long)&((Scheme_Native_Closure *)0x0)->vals[i]; + return 1; + } + } + } else { + /* not a case-lambda... */ + if (scheme_native_arity_check(p, num_rands) + /* If it also accepts num_rands + 1, then it has a vararg, + so don't try direct_native. */ + && !scheme_native_arity_check(p, num_rands + 1)) { + return 1; + } + } + } + + return 0; +} + static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, mz_jit_state *jitter, int is_tail, int multi_ok, int no_call) { @@ -2460,6 +2491,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ Scheme_Object *rator, *v, *arg; int reorder_ok = 0; int args_already_in_place = 0; + long extract_case = 0; /* when direct_native, non-0 => offset to extract case-lambda case */ START_JIT_DATA(); rator = (alt_rands ? alt_rands[0] : app->args[0]); @@ -2494,32 +2526,36 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } } } - } else if ((t == scheme_toplevel_type) - && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST)) { - /* We can re-order evaluation of the rator. */ - reorder_ok = 1; + } else if (t == scheme_toplevel_type) { + if (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST) { + /* We can re-order evaluation of the rator. */ + reorder_ok = 1; - if (jitter->nc) { - Scheme_Object *p; + if (jitter->nc) { + Scheme_Object *p; - p = extract_global(rator, jitter->nc); - p = ((Scheme_Bucket *)p)->val; - if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) { - if (scheme_native_arity_check(p, num_rands) - /* If it also accepts num_rands + 1, then it has a vararg, - so don't try direct_native. */ - && !scheme_native_arity_check(p, num_rands + 1)) { - direct_native = 1; - - if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos) - && (num_rands < MAX_SHARED_CALL_RANDS)) { + p = extract_global(rator, jitter->nc); + p = ((Scheme_Bucket *)p)->val; + if (can_direct_native(p, num_rands, &extract_case)) { + direct_native = 1; + + if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos) + && (num_rands < MAX_SHARED_CALL_RANDS)) { if (is_tail) direct_self = 1; else if (jitter->self_nontail_code) nontail_self = 1; - } - } - } + } + } + } + } else if (jitter->nc) { + Scheme_Object *p; + + p = extract_global(rator, jitter->nc); + if (((Scheme_Bucket_With_Flags *)p)->flags & GLOB_IS_CONSISTENT) { + if (can_direct_native(((Scheme_Bucket *)p)->val, num_rands, &extract_case)) + direct_native = 1; + } } } else if (SAME_TYPE(t, scheme_closure_type)) { Scheme_Closure_Data *data; @@ -2543,7 +2579,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } #ifdef JIT_PRECISE_GC - /* We can get this closure's pointer back frmo the Scheme stack. */ + /* We can get this closure's pointer back from the Scheme stack. */ if (nontail_self) direct_self = 1; #endif @@ -2693,6 +2729,11 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ else scheme_indirect_call_count++; + if (direct_native && extract_case) { + /* extract case from case-lambda */ + jit_ldxi_p(JIT_V1, JIT_V1, extract_case); + } + if (no_call) { /* leave actual call to inlining code */ } else if (!(direct_self && is_tail) @@ -2748,7 +2789,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ code = generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, nontail_self); shared_non_tail_code[dp][num_rands][mo] = code; } - LOG_IT(("<-non-tail %d %d %d %d\n", dp, num_rands, mo)); + LOG_IT(("<-non-tail %d %d %d\n", dp, num_rands, mo)); code = shared_non_tail_code[dp][num_rands][mo]; if (nontail_self) { diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 28156d0998..581bc8569f 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4083,6 +4083,18 @@ static void *eval_module_body_k(void) return NULL; } +#if 0 +# define LOG_RUN_DECLS long start_time +# define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds()) +# define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \ + scheme_write_to_string(mod->modname, NULL), \ + scheme_get_process_milliseconds() - start_time)) +#else +# define LOG_RUN_DECLS /* empty */ +# define LOG_START_RUN(mod) /* empty */ +# define LOG_END_RUN(mod) /* empty */ +#endif + static void eval_module_body(Scheme_Env *menv) { Scheme_Thread *p; @@ -4092,6 +4104,7 @@ static void eval_module_body(Scheme_Env *menv) int i, cnt; int volatile save_phase_shift; mz_jmp_buf newbuf, * volatile savebuf; + LOG_RUN_DECLS; menv->running = 1; menv->ran = 1; @@ -4104,6 +4117,8 @@ static void eval_module_body(Scheme_Env *menv) return; } + LOG_START_RUN(menv->module); + save_runstack = scheme_push_prefix(menv, m->prefix, m->me->src_modidx, menv->link_midx, 0, menv->phase); @@ -4149,6 +4164,8 @@ static void eval_module_body(Scheme_Env *menv) scheme_pop_prefix(save_runstack); } + + LOG_END_RUN(menv->module); } void scheme_run_module(Scheme_Env *menv, int set_ns) @@ -5218,6 +5235,18 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) return data; } +#if 0 +# define LOG_EXPAND_DECLS long start_time +# define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) +# define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \ + scheme_write_to_string(mod->modname, NULL), \ + scheme_get_process_milliseconds() - start_time)) +#else +# define LOG_EXPAND_DECLS /* empty */ +# define LOG_START_EXPAND(mod) /* empty */ +# define LOG_END_EXPAND(mod) /* empty */ +#endif + static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { @@ -5229,6 +5258,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *mbval, *orig_ii; int saw_mb, check_mb = 0; int restore_confusing_name = 0; + LOG_EXPAND_DECLS; if (!scheme_is_toplevel(env)) scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); @@ -5256,6 +5286,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, rmp = scheme_intern_resolved_module_path(rmp); m->modname = rmp; + LOG_START_EXPAND(m); + if (SAME_OBJ(m->modname, kernel_modname)) { /* Too confusing. Give it a different name while compiling. */ Scheme_Object *k2; @@ -5492,6 +5524,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, menv->rename_set = NULL; } + LOG_END_EXPAND(m); + SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm); return fm; } diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index e148da794e..746f83350e 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -1977,20 +1977,28 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, src = obj; if (SAME_OBJ(src, obj)) { + int l; + const char *s; + Scheme_Object *name; + print_utf8_string(pp, "#<", 0, 2); /* used to have "struct:" prefix */ - { - int l; - const char *s; - Scheme_Object *name = SCHEME_STRUCT_NAME_SYM(obj); - - s = scheme_symbol_name_and_size(name, (unsigned int *)&l, - (pp->print_struct - ? SCHEME_SNF_FOR_TS - : (pp->can_read_pipe_quote - ? SCHEME_SNF_PIPE_QUOTE - : SCHEME_SNF_NO_PIPE_QUOTE))); - print_utf8_string(pp, s, 0, l); - } + if (scheme_reduced_procedure_struct + && scheme_is_struct_instance(scheme_reduced_procedure_struct, obj)) { + /* Since scheme_proc_struct_name_source() didn't redirect, this one + must have a name. */ + print_utf8_string(pp, "procedure:", 0, 10); + name = ((Scheme_Structure *)obj)->slots[2]; + } else { + name = SCHEME_STRUCT_NAME_SYM(obj); + } + + s = scheme_symbol_name_and_size(name, (unsigned int *)&l, + (pp->print_struct + ? SCHEME_SNF_FOR_TS + : (pp->can_read_pipe_quote + ? SCHEME_SNF_PIPE_QUOTE + : SCHEME_SNF_NO_PIPE_QUOTE))); + print_utf8_string(pp, s, 0, l); PRINTADDRESS(pp, obj); print_utf8_string(pp, ">", 0, 1); } else { diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 61f22b0fa8..5f08fc194b 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 943 +#define EXPECTED_PRIM_COUNT 945 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 0ff2debbc0..231003d3e1 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -514,11 +514,15 @@ extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator); /* hash tables and globals */ /*========================================================================*/ +/* a primitive constant: */ #define GLOB_IS_CONST 1 -#define GLOB_IS_PRIMITIVE 4 -#define GLOB_IS_PERMANENT 8 +/* always defined as the same kind of value (e.g., proc with a particular arity): */ +#define GLOB_IS_CONSISTENT 2 +/* a kernel constant: */ #define GLOB_HAS_REF_ID 16 +/* can cast to Scheme_Bucket_With_Home: */ #define GLOB_HAS_HOME_PTR 32 +/* Scheme-level constant (cannot be changed further): */ #define GLOB_IS_IMMUTATED 64 typedef struct { diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index d46f0d5598..c5a40ac424 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.6" +#define MZSCHEME_VERSION "4.1.3.8" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 6 +#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 6434106e2b..58a0ecaea4 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -2951,7 +2951,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base } else { /* Duplicate the hash table: */ Scheme_Hash_Table *oht = (Scheme_Hash_Table *)struct_type->props; - for (i = oht->count; i--; ) { + for (i = oht->size; i--; ) { if (oht->vals[i]) { prop = oht->keys[i]; scheme_hash_set(ht, prop, oht->vals[i]); @@ -3301,19 +3301,19 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv) Scheme_Object *parent = argv[1]; if (!SCHEME_FALSEP(parent) && !((Scheme_Struct_Type *)parent)->prefab_key) { bad = ("make-struct-type: generative supertype disallowed" - " for non-generative structure type with name: "); + " for non-generative structure type with name: %S"); } else if (!SCHEME_NULLP(props)) { bad = ("make-struct-type: properties disallowed" - " for non-generative structure type with name: "); + " for non-generative structure type with name: %S"); } else if (proc_attr) { bad = ("make-struct-type: procedure specification disallowed" - " for non-generative structure type with name: "); + " for non-generative structure type with name: %S"); } else if (guard) { bad = ("make-struct-type: guard disallowed" - " for non-generative structure type with name: "); + " for non-generative structure type with name: %S"); } if (bad) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, bad, inspector); + scheme_raise_exn(MZEXN_FAIL_CONTRACT, bad, argv[0]); } } diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 9be87b2d56..2d7a8d2d80 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -2318,7 +2318,7 @@ static Scheme_Object *make_mapped_k(void) static void make_mapped(Scheme_Cert *cert) { - Scheme_Cert *stop; + Scheme_Cert *stop, *c2; Scheme_Object *pr; Scheme_Hash_Table *ht; @@ -2349,7 +2349,18 @@ static void make_mapped(Scheme_Cert *cert) make_mapped(stop); } - ht = scheme_make_hash_table_equal(); + /* Check whether an `eq?' table will work: */ + for (c2 = cert; c2 != stop; c2 = c2->next) { + if (c2->key) + break; + if (!SCHEME_INTP(c2->mark)) + break; + } + + if (c2 == stop) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = scheme_make_hash_table_equal(); pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop); cert->mapped = pr; @@ -2699,12 +2710,12 @@ Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx) /* Does not include negative marks */ { WRAP_POS awl; - Scheme_Object *acur_mark, *first = scheme_null, *last = NULL, *p; + Scheme_Object *acur_mark, *p, *marks = scheme_null; WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); while (1) { - /* Skip over renames, cancelled marks, and negative marks: */ + /* Skip over renames, immediately-canceled marks, and negative marks: */ acur_mark = NULL; while (1) { if (WRAP_POS_END_P(awl)) @@ -2727,16 +2738,14 @@ Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx) } if (acur_mark) { - p = scheme_make_pair(acur_mark, scheme_null); - if (!last) - first = p; + if (SCHEME_PAIRP(marks) && SAME_OBJ(acur_mark, SCHEME_CAR(marks))) + marks = SCHEME_CDR(marks); else - SCHEME_CDR(last) = p; - last = p; + marks = scheme_make_pair(acur_mark, marks); } if (WRAP_POS_END_P(awl)) - return first; + return scheme_reverse(marks); } } @@ -3082,7 +3091,7 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) return scheme_false; } -XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) +static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) /* Compares the marks in two wraps lists. A result of 2 means that the result depended on a barrier env. For a rib-based renaming, we need to check only up to the rib, and the barrier effect important for @@ -3094,100 +3103,174 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Obje WRAP_POS awl; WRAP_POS bwl; Scheme_Object *acur_mark, *bcur_mark; +# define FAST_STACK_SIZE 4 + Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE]; + Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya; + int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE; int used_barrier = 0; WRAP_POS_COPY(awl, *_awl); WRAP_POS_COPY(bwl, *_bwl); + /* A simple way to compare marks would be to make two lists of + marks. The loop below attempts to speed up that process by + discovering common and canceled marks early, so they can be + omitted from the lists. The "stack" arrays accumulate the parts + of the list that can't be skipped that way. */ + while (1) { - /* Skip over renames and cancelled marks: */ + /* Skip over renames and canceled marks: */ acur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(awl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = WRAP_POS_FIRST(awl); - WRAP_POS_INC(awl); - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(awl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(awl); - } else { - WRAP_POS_INIT_END(awl); - used_barrier = 1; - } - } - } else { - WRAP_POS_INC(awl); + while (1) { /* loop for canceling stack */ + /* this loop handles immediately canceled marks */ + while (1) { + if (WRAP_POS_END_P(awl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) { + if (acur_mark) { + if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { + acur_mark = NULL; + WRAP_POS_INC(awl); + } else + break; + } else { + acur_mark = WRAP_POS_FIRST(awl); + WRAP_POS_INC(awl); + } + } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { + if (SCHEME_FALSEP(barrier_env)) { + WRAP_POS_INC(awl); + } else { + /* See if the barrier environment is in this rib. */ + Scheme_Lexical_Rib *rib; + rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl); + for (rib = rib->next; rib; rib = rib->next) { + if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) + break; + } + if (!rib) { + WRAP_POS_INC(awl); + } else { + WRAP_POS_INIT_END(awl); + used_barrier = 1; + } + } + } else { + WRAP_POS_INC(awl); + } } + /* Maybe cancel a mark on the stack */ + if (acur_mark && a_mark_cnt) { + if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) { + --a_mark_cnt; + if (a_mark_cnt) { + acur_mark = a_mark_stack[a_mark_cnt - 1]; + --a_mark_cnt; + break; + } else + acur_mark = NULL; + } else + break; + } else + break; } + bcur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(bwl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) { - if (bcur_mark) { - if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) { - bcur_mark = NULL; - WRAP_POS_INC(bwl); - } else - break; - } else { - bcur_mark = WRAP_POS_FIRST(bwl); - WRAP_POS_INC(bwl); - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(bwl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(bwl); - } else { - WRAP_POS_INIT_END(bwl); - used_barrier = 1; - } - } - } else { - WRAP_POS_INC(bwl); + while (1) { /* loop for canceling stack */ + while (1) { + if (WRAP_POS_END_P(bwl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) { + if (bcur_mark) { + if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) { + bcur_mark = NULL; + WRAP_POS_INC(bwl); + } else + break; + } else { + bcur_mark = WRAP_POS_FIRST(bwl); + WRAP_POS_INC(bwl); + } + } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { + if (SCHEME_FALSEP(barrier_env)) { + WRAP_POS_INC(bwl); + } else { + /* See if the barrier environment is in this rib. */ + Scheme_Lexical_Rib *rib; + rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl); + for (rib = rib->next; rib; rib = rib->next) { + if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) + break; + } + if (!rib) { + WRAP_POS_INC(bwl); + } else { + WRAP_POS_INIT_END(bwl); + used_barrier = 1; + } + } + } else { + WRAP_POS_INC(bwl); + } } + /* Maybe cancel a mark on the stack */ + if (bcur_mark && b_mark_cnt) { + if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) { + --b_mark_cnt; + if (b_mark_cnt) { + bcur_mark = b_mark_stack[b_mark_cnt - 1]; + --b_mark_cnt; + break; + } else + bcur_mark = NULL; + } else + break; + } else + break; } /* Same mark? */ - if (!SAME_OBJ(acur_mark, bcur_mark)) - return 0; + if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) { + /* Not the same, so far; push onto stacks in case they're + cancelled later */ + if (acur_mark) { + if (a_mark_cnt >= a_mark_size) { + a_mark_size *= 2; + naya = MALLOC_N(Scheme_Object*, a_mark_size); + memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt); + a_mark_stack = naya; + } + a_mark_stack[a_mark_cnt++] = acur_mark; + } + if (bcur_mark) { + if (b_mark_cnt >= b_mark_size) { + b_mark_size *= 2; + naya = MALLOC_N(Scheme_Object*, b_mark_size); + memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt); + b_mark_stack = naya; + } + b_mark_stack[b_mark_cnt++] = bcur_mark; + } + } /* Done if both reached the end: */ - if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) - return used_barrier + 1; + if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) { + if (a_mark_cnt == b_mark_cnt) { + while (a_mark_cnt--) { + if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt])) + return 0; + } + return used_barrier + 1; + } else + return 0; + } } } static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark) -/* Checks for positive or negative (certificate-only) mark */ +/* Checks for positive or negative (certificate-only) mark. + FIXME: canceling marks are detected only when they're immediately + canceling (i.e., no canceled marks in between). */ { WRAP_POS awl; Scheme_Object *acur_mark; @@ -3226,7 +3309,8 @@ static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark) } static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) -/* Adds both positive and negative marks to marks table */ +/* Adds both positive and negative marks to marks table. This may add too many + marks, because it detects only immediately canceling marks. */ { WRAP_POS awl; Scheme_Object *acur_mark; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 00c61b81ee..4484b91f90 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -681,26 +681,27 @@ void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v) static Scheme_Object * define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, - Resolve_Prefix *rp, Scheme_Env *dm_env, Scheme_Dynamic_State *dyn_state) + Resolve_Prefix *rp, Scheme_Env *dm_env, + Scheme_Dynamic_State *dyn_state) { - Scheme_Object *name, *macro, *vals, *var; + Scheme_Object *name, *macro, *vals_expr, *vals, *var; int i, g, show_any; Scheme_Bucket *b; Scheme_Object **save_runstack = NULL; - vals = SCHEME_VEC_ELS(vec)[0]; + vals_expr = SCHEME_VEC_ELS(vec)[0]; if (dm_env) { scheme_prepare_exp_env(dm_env); save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals, dyn_state); + vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); if (defmacro == 2) dm_env = NULL; else scheme_pop_prefix(save_runstack); } else { - vals = _scheme_eval_linked_expr_multi(vals); + vals = _scheme_eval_linked_expr_multi(vals_expr); dm_env = NULL; } @@ -735,7 +736,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1); if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; } } } @@ -767,7 +768,11 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1); if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + int flags = GLOB_IS_IMMUTATED; + if (SCHEME_PROCP(vals_expr) + || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type)) + flags |= GLOB_IS_CONSISTENT; + ((Scheme_Bucket_With_Flags *)b)->flags |= flags; } if (defmacro) diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c index c4276797b7..3ce6103a36 100644 --- a/src/mzscheme/utils/xcglue.c +++ b/src/mzscheme/utils/xcglue.c @@ -18,9 +18,9 @@ arguments v... (primitive-class-prepare-struct-type! prim-class gen-property - gen-value preparer dispatcher) - prepares a class's struct-type for - objects generated C-side; returns a constructor, predicate, - and a struct:type for derived classes. The constructor and + gen-value preparer dispatcher extra-props) - prepares a class's + struct-type for objects generated C-side; returns a constructor, + predicate, and a struct:type for derived classes. The constructor and struct:type map the given dispatcher to the class. The preparer takes a symbol naming the method. It returns a @@ -30,6 +30,8 @@ method-specific value produced by the prepaper. It returns a method procedure. + The extra-props argument is a list of property--value pairs. + (primitive-class-find-method prim-class sym) - gets the method for the given symbol. @@ -169,6 +171,19 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv) scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv); scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv); + props = argv[5]; + while (SCHEME_PAIRP(props)) { + name = SCHEME_CAR(props); + if (!SCHEME_PAIRP(name)) + break; + if (SCHEME_TYPE(SCHEME_CAR(name)) != scheme_struct_property_type) + break; + props = SCHEME_CDR(props); + } + if (!SCHEME_NULLP(props)) + scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv); + props = argv[5]; + objscheme_something_prepared = 1; c = ((Scheme_Class *)argv[0]); @@ -197,7 +212,7 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv) (c->sup ? ((Scheme_Class *)c->sup)->base_struct_type : object_struct), NULL, 0, 0, NULL, - NULL, NULL); + props, NULL); c->base_struct_type = base_stype; /* Type to use when instantiating from C: */ @@ -522,7 +537,7 @@ void objscheme_init(Scheme_Env *env) scheme_install_xc_global("primitive-class-prepare-struct-type!", scheme_make_prim_w_arity(class_prepare_struct_type, "primitive-class-prepare-struct-type!", - 5, 5), + 6, 6), env); scheme_install_xc_global("primitive-class-find-method", diff --git a/src/mzscheme/utils/xcglue.h b/src/mzscheme/utils/xcglue.h index 43a123d1f0..7c046608b7 100644 --- a/src/mzscheme/utils/xcglue.h +++ b/src/mzscheme/utils/xcglue.h @@ -264,6 +264,7 @@ typedef double nndouble; # define CONSTRUCTOR_ARGS(x) () # define CONSTRUCTOR_INIT(x) /* empty */ # define ASSELF sElF-> +# define SELF__ sElF # define INIT_NULLED_OUT = NULLED_OUT # define INIT_NULLED_ARRAY(x) = x # define INA_comma , @@ -284,6 +285,7 @@ typedef double nndouble; # define CONSTRUCTOR_ARGS(x) x # define CONSTRUCTOR_INIT(x) x # define ASSELF /* empty */ +# define SELF__ this # define INIT_NULLED_OUT /* empty */ # define INIT_NULLED_ARRAY(x) /* empty */ # define INA_comma /* empty */ diff --git a/src/mzscheme/utils/xctocc b/src/mzscheme/utils/xctocc index 64b65a2b04..753a5f3e6d 100755 --- a/src/mzscheme/utils/xctocc +++ b/src/mzscheme/utils/xctocc @@ -20,6 +20,7 @@ $key_include = '@INCLUDE '; $key_boolean = '@BOOLEAN '; $key_classbase = '@CLASSBASE '; $key_interface = '@INTERFACE '; +$key_implements = '@IMPLEMENTS '; $key_classid = '@CLASSID '; $key_global = '@GLOBAL '; $key_header = '@HEADER '; @@ -61,6 +62,7 @@ sub ResetObjParams $global = 0; $implementor = ""; $interfacestring = ""; + $implements = ""; } &ResetObjParams(); @@ -85,6 +87,7 @@ sub ReadFile { $marks{'H'} = 'H'; $marks{'v'} = 'v'; $marks{'m'} = 'm'; + $marks{'M'} = 'M'; $ifzero = 0; open(SOUT, ">${file}.ss"); @@ -168,8 +171,11 @@ sub ReadFile { $oldclassmk = $mkbase; $newclass = 'os_' . $base; } elsif (&StartsWithKey($_, $key_interface)) { - $_ = &Wash(&SkipKey($_, $key_classbase)); + $_ = &Wash(&SkipKey($_, $key_interface)); $interfacestring =$_; + } elsif (&StartsWithKey($_, $key_implements)) { + $_ = &Wash(&SkipKey($_, $key_implements)); + $implements =$_; } elsif (&StartsWithKey($_, $key_global)) { &ResetObjParams(); $global = 1; @@ -347,6 +353,9 @@ sub ReadFields { $virtual = 1; } elsif ($mark eq 'm') { $externalmethod = 1; + } elsif ($mark eq 'M') { + $externalmethod = 1; + $virtual = 1; } ($s, $casename) = split(/<>/, $s); @@ -805,7 +814,11 @@ sub DoPrintClass if ($virtual) { &OIStart; print " " . &NormalType($returntype) - . " ${globalname}${func}("; + . " ${globalname}${func}"; + if ($externalmethod) { + print "_method"; + } + print "("; &PrintParams(1); print ");\n"; &OIEnd; @@ -1076,6 +1089,7 @@ sub DoPrintClass } else { print SOUT "#f"; } + print SOUT " ($implements)"; if ($iargnames ne 'BYPOS') { print SOUT " ($iargnames)"; } else { @@ -1333,7 +1347,13 @@ sub PrintFailureHandling if ($callback) { print "obj->"; } - print "ASSELF ${oldclass}::${func}("; + if (!$externalmethod) { + print "ASSELF ${oldclass}::"; + } + print "${func}("; + if ($externalmethod) { + printf("SELF__, "); + } &PrintArgs(1); print ");"; } elsif ($exception ne '' && $exception ne 'SUPER') { @@ -1367,7 +1387,11 @@ sub PrintMethod print $func; print "(int n, Scheme_Object *p[]);\n\n"; - print &NormalType($returntype) . " ${methodfuncname}("; + print &NormalType($returntype) . " ${methodfuncname}"; + if ($externalmethod) { + print "_method"; + } + print "("; &PrintParams(0); $pcount = $paramnum; @@ -1875,7 +1899,7 @@ sub PrintCallRealMethod print "));\n\n"; } else { print "$prefix "; - if ($virtual) { + if ($virtual && !$externalmethod) { print "if (((Scheme_Class_Object *)p[0])->primflag)\n"; print "$prefix "; print $ret_val if ($returntype ne 'void'); @@ -2205,7 +2229,7 @@ sub PrintBundleVar $symtype = $1; print "$wvs(bundle_symset_${symtype}($var))"; } else { - print STDERR "Unknown type ${paramtype} in $func.\n"; + print STDERR "Unknown type ${paramtype} in $func [for bundle].\n"; } } @@ -2436,7 +2460,7 @@ sub PrintUnbundleVar $symtype = $1; print "WITH_VAR_STACK(unbundle_symset_${symtype}($var, $stop))"; } else { - print STDERR "Unknown type ${paramtype} in $func.\n"; + print STDERR "Unknown type ${paramtype} in $func [for unbundle].\n"; } } @@ -2806,7 +2830,7 @@ sub PrintTypecheck $symtype = $1; print "WITH_REMEMBERED_STACK(istype_symset_${symtype}($var, $stop))"; } else { - print STDERR "Unknown type ${paramtype} in $func.\n"; + print STDERR "Unknown type ${paramtype} in $func [for typecheck].\n"; } } diff --git a/src/worksp/README b/src/worksp/README index 0a68c8cbd0..f3d41b11af 100644 --- a/src/worksp/README +++ b/src/worksp/README @@ -243,7 +243,7 @@ plt\lib\ on start-up. The relative DLL path is embedded in each executable, and it can be replaced with a path of up to 512 characters. The path is stored in -the exeuctable in wide-character format, and it is stored immediately +the executable in wide-character format, and it is stored immediately after the wide-character tag "dLl dIRECTORy:" with a wide NUL terminator. The path can be either absolute or relative; in the latter case, the relative path is resolved with respect to the diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 0a148967f0..36cd703726 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@