suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merged changes from the trunk.

Browse Source 
svn: r17892
This commit is contained in:
Carl Eastlund 2010-01-30 04:59:20 +00:00
commit 2513e7d6e0
205 changed files with 5077 additions and 2910 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/2htdp/private/image-more.ss
View File

@ -2,6 +2,7 @@
(require "../../mrlib/image-core.ss" (require "../../mrlib/image-core.ss"
"img-err.ss" "img-err.ss"
scheme/match
scheme/contract scheme/contract
scheme/class scheme/class
scheme/gui/base scheme/gui/base
@ -117,7 +118,7 @@
(overlay/internal 'middle 'middle image (cons image2 image3))) (overlay/internal 'middle 'middle image (cons image2 image3)))
;; underlay : image image image ... -> image ;; underlay : image image image ... -> image
(define (underlay image image2 . image3) (define/chk (underlay image image2 . image3)
(let ([imgs (reverse (list* image image2 image3))]) (let ([imgs (reverse (list* image image2 image3))])
(overlay/internal 'middle 'middle (car imgs) (cdr imgs)))) (overlay/internal 'middle 'middle (car imgs) (cdr imgs))))
@ -279,9 +280,10 @@
(crop/internal x1 y1 width height image)) (crop/internal x1 y1 width height image))
(define (crop/internal x1 y1 width height image) (define (crop/internal x1 y1 width height image)
(let ([iw (min width (get-right image))] (let* ([iw (min width (get-right image))]
[ih (min height (get-bottom image))]) [ih (min height (get-bottom image))]
(make-image (make-crop (rectangle-points iw ih) [points (rectangle-points iw ih)])
(make-image (make-crop points
(make-translate (- x1) (- y1) (image-shape image))) (make-translate (- x1) (- y1) (image-shape image)))
(make-bb iw (make-bb iw
ih ih
@ -363,26 +365,28 @@
(- (ltrb-bottom ltrb) (ltrb-top ltrb))) (- (ltrb-bottom ltrb) (ltrb-top ltrb)))
#f))) #f)))
(define (rotate-normalized-shape angle shape) (define/contract (rotate-normalized-shape angle shape)
(-> number? normalized-shape? normalized-shape?)
(cond (cond
[(overlay? shape) [(overlay? shape)
(let ([top-shape (rotate-normalized-shape angle (overlay-top shape))] (let ([top-shape (rotate-normalized-shape angle (overlay-top shape))]
[bottom-shape (rotate-simple angle (overlay-bottom shape))]) [bottom-shape (rotate-cn-or-simple-shape angle (overlay-bottom shape))])
(make-overlay top-shape bottom-shape))] (make-overlay top-shape bottom-shape))]
[else [else
(rotate-cropped-simple angle shape)])) (rotate-cn-or-simple-shape angle shape)]))
;; rotate-cropped-simple : angle cropped-simple-shape -> cropped-simple-shape (define/contract (rotate-cn-or-simple-shape angle shape)
(define (rotate-cropped-simple angle shape) (-> number? cn-or-simple-shape? cn-or-simple-shape?)
(cond (cond
[(crop? shape) [(crop? shape)
(make-crop (rotate-points angle (crop-points shape)) (make-crop (rotate-points angle (crop-points shape))
(rotate-cropped-simple angle (crop-shape shape)))] (rotate-normalized-shape angle (crop-shape shape)))]
[else [else
(rotate-simple angle shape)])) (rotate-simple angle shape)]))
;; rotate-simple : angle simple-shape -> simple-shape ;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape) (define (rotate-simple θ simple-shape)
(-> number? simple-shape? simple-shape?)
(cond (cond
[(line-segment? simple-shape) [(line-segment? simple-shape)
(make-line-segment (rotate-point (line-segment-start simple-shape) (make-line-segment (rotate-point (line-segment-start simple-shape)
@ -425,21 +429,21 @@
(min (ltrb-right ltrb1) (ltrb-right ltrb2)) (min (ltrb-right ltrb1) (ltrb-right ltrb2))
(min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2)))) (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
;; normalized-shape-bb : normalized-shape -> ltrb (define/contract (normalized-shape-bb shape)
(define (normalized-shape-bb shape) (-> normalized-shape? ltrb?)
(cond (cond
[(overlay? shape) [(overlay? shape)
(let ([top-ltrb (normalized-shape-bb (overlay-top shape))] (let ([top-ltrb (normalized-shape-bb (overlay-top shape))]
[bottom-ltrb (simple-bb (overlay-bottom shape))]) [bottom-ltrb (cn-or-simple-shape-bb (overlay-bottom shape))])
(union-ltrb top-ltrb bottom-ltrb))] (union-ltrb top-ltrb bottom-ltrb))]
[else [else
(cropped-simple-bb shape)])) (cn-or-simple-shape-bb shape)]))
;; cropped-simple-bb : cropped-simple-shape -> ltrb (define/contract (cn-or-simple-shape-bb shape)
(define (cropped-simple-bb shape) (-> cn-or-simple-shape? ltrb?)
(cond (cond
[(crop? shape) [(crop? shape)
(let ([ltrb (cropped-simple-bb (crop-shape shape))] (let ([ltrb (normalized-shape-bb (crop-shape shape))]
[crop-ltrb (points->ltrb (crop-points shape))]) [crop-ltrb (points->ltrb (crop-points shape))])
(intersect-ltrb crop-ltrb ltrb))] (intersect-ltrb crop-ltrb ltrb))]
[else [else
@ -448,7 +452,8 @@
;; simple-bb : simple-shape -> ltrb ;; simple-bb : simple-shape -> ltrb
;; returns the bounding box of 'shape' ;; returns the bounding box of 'shape'
;; (only called for rotated shapes, so bottom=baseline) ;; (only called for rotated shapes, so bottom=baseline)
(define (simple-bb simple-shape) (define/contract (simple-bb simple-shape)
(-> simple-shape? ltrb?)
(cond (cond
[(line-segment? simple-shape) [(line-segment? simple-shape)
(let ([x1 (point-x (line-segment-start simple-shape))] (let ([x1 (point-x (line-segment-start simple-shape))]
@ -484,6 +489,7 @@
(make-ltrb left top right bottom))) (make-ltrb left top right bottom)))
(define (np-atomic-bb atomic-shape) (define (np-atomic-bb atomic-shape)
(-> np-atomic-shape? (values number? number? number? number?))
(cond (cond
[(ellipse? atomic-shape) [(ellipse? atomic-shape)
(let ([θ (ellipse-angle atomic-shape)]) (let ([θ (ellipse-angle atomic-shape)])
@ -554,6 +560,7 @@
;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape ;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape
(define (rotate-atomic θ atomic-shape) (define (rotate-atomic θ atomic-shape)
(-> number? np-atomic-shape? np-atomic-shape?)
(cond (cond
[(ellipse? atomic-shape) [(ellipse? atomic-shape)
(cond (cond

2
collects/2htdp/private/img-err.ss
View File

@ -49,7 +49,7 @@
[(define/chk (fn-name args ... . final-arg) body ...) [(define/chk (fn-name args ... . final-arg) body ...)
(identifier? #'final-arg) (identifier? #'final-arg)
(let ([len (length (syntax->list #'(args ...)))]) (let ([len (length (syntax->list #'(args ...)))])
(with-syntax ([(i ...) (build-list len values)]) (with-syntax ([(i ...) (build-list len add1)])
#`(define (fn-name args ... . final-arg) #`(define (fn-name args ... . final-arg)
(let ([args (check/normalize 'fn-name 'args args i)] ... (let ([args (check/normalize 'fn-name 'args args i)] ...
[final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j))) [final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j)))

908
collects/2htdp/tests/image-equality-performance.ss Normal file
View File

@ -0,0 +1,908 @@
#lang scheme
#|
This is a file from Guillaume that ran very slowly with the
htdp/image library; here it is used as a performance test.
Porting to #lang scheme +2htdp/image consisted of adding requires,
changing overlay/xy to underlay/xy, defining empty-scene, and
adding the check-expect macro (and related code).
Also added the timing code at the end.
|#
(require 2htdp/image
(only-in mrlib/image-core
skip-image-equality-fast-path))
(define-syntax (check-expect stx)
(syntax-case stx ()
[(_ a b)
(with-syntax ([line (syntax-line stx)])
#'(set! tests (cons (list (λ () a) (λ () b) line)
tests)))]))
(define tests '())
(define (run-tests)
(for-each
(λ (l)
(let ([a-res ((list-ref l 0))]
[b-res ((list-ref l 1))]
[line (list-ref l 2)])
(unless (equal? a-res b-res)
(error 'test "test failed; expected ~s and ~s to be equal, but they weren't, line ~a"
a-res
b-res
line))))
tests))
(define (empty-scene w h)
(overlay
(rectangle w h 'solid 'white)
(rectangle w h 'outline 'black)))
;;Program for creating game of croos-circle game
;;contract :image->image
;;defining a union square
;;A square is either
;;A square is blank
;;A square is cross
;;A square is Circle
;;defining width of square
(define square-width 150)
;;defining th height and width of scene
(define width (* square-width 3))
(define height (* square-width 3))
;;defining the image circle
(define Circle (underlay/xy (circle 20 'solid 'orange) 0 0 (circle 10 'solid 'white)))
;;defining the image cross
(define cross (underlay/xy (rectangle 10 30 'solid 'green) 0 0 (rectangle 30 10 'solid 'green)))
;;defining the blank image
(define blank (underlay/xy (rectangle square-width square-width 'solid 'red) 0 0
(rectangle (- square-width 8) (- square-width 8) 'solid 'white)))
;;Given a square returns
;;the image of square
;;draw-square :square ->image
(define (draw-square square)
(cond[(equal? 'Circle square)(underlay/xy blank 0 0 Circle)]
[(equal? 'cross square)(underlay/xy blank 0 0 cross)]
[(equal? 'blank square)blank]
))
;;test
(check-expect(draw-square 'Circle)(underlay/xy blank 0 0 Circle))
(check-expect(draw-square 'cross)(underlay/xy blank 0 0 cross))
(check-expect(draw-square 'blank)blank)
;;== Cross and circles, part #3 ==
;;define a structure for ROW
;;ROW structure used for creating a ROW in the board
;;contract ROW:image image image->image
(define-struct ROW (left middle right) #:transparent)
;; defining a blank row
(define blank-ROW (make-ROW 'blank 'blank 'blank))
;;defining the cross row
(define cross-ROW (make-ROW 'blank 'cross 'blank))
;;defineing the cross-row-blank secoend combination
(define cross-ROW-blank (make-ROW 'cross 'cross 'blank ))
;;defining a row cross-row
(define cross-row (make-ROW 'cross 'cross 'cross ))
;;defining a row blank-circle
(define blank-circle (make-ROW 'Circle 'blank 'blank))
;;defining a row cross-circle
(define cross-circle (make-ROW 'cross 'cross 'Circle ))
;;defining a row circle-cross
(define circle-cross (make-ROW 'cross 'Circle 'Circle ))
;;defining a row cross-blank
(define cross-blank (make-ROW 'cross 'blank 'blank ))
;;function for creating ROW with the square
;;contract:square square square->ROW
;template: for draw-row
;template for ROW
;(define (a-row-function a-row)
; ... (row-left a-row) ;; is a square
; ... (row-mid a-row) ;; is a square
; ... (row-right a-row)) ;; is a square
(define (draw-row row)
(underlay/xy (draw-square(ROW-left row)) (image-width blank) 0
(underlay/xy (draw-square(ROW-middle row)) (image-width blank) 0 (draw-square(ROW-right row)) )))
;;test
(check-expect (draw-row (make-ROW 'Circle 'cross 'blank))
(underlay/xy (draw-square 'Circle) (image-width blank) 0
(underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) )))
(check-expect (draw-row (make-ROW 'Circle 'cross 'blank))
(underlay/xy (draw-square 'Circle) (image-width blank) 0
(underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) )))
(check-expect (draw-row (make-ROW 'Circle 'blank 'cross))
(underlay/xy (draw-square 'Circle) (image-width blank) 0
(underlay/xy (draw-square 'blank ) (image-width blank) 0 (draw-square 'cross) )))
(check-expect (draw-row cross-ROW-blank)
(underlay/xy (draw-square 'cross) (image-width blank) 0
(underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) )))
(check-expect (draw-row cross-row )
(underlay/xy (draw-square 'cross) (image-width blank) 0
(underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'cross) )))
;;define a structure for BOARD
;;contract make-BOARD :image image image->image
(define-struct BOARD (top-row center-row bottom-row) #:transparent)
;; purpose : defining an empty board
(define empty-board (make-BOARD blank-ROW
blank-ROW
blank-ROW))
;;function for creating board with the row
;template: for draw-board
;(define (a-board-function a-row)
; ... (top-row a-row) ;; is a square
; ... (center-row a-row) ;; is a square
; ... (bottom-row a-row)) ;; is a square
;;defining the background
(define background (empty-scene width height))
;;this function will reusing the fuction draw-row for creating row
;;contract:row row row->board
;;test
(check-expect (draw-board (make-BOARD cross-ROW-blank
cross-ROW
cross-row ))
(underlay/xy (draw-row cross-ROW-blank)
0 (image-height (draw-row cross-ROW))
(underlay/xy (draw-row cross-ROW)
0 (image-height (draw-row cross-ROW))
(draw-row cross-row ))))
(check-expect (draw-board (make-BOARD cross-circle
(make-ROW 'Circle 'cross 'blank)
circle-cross))
(underlay/xy (draw-row cross-circle)
0 (image-height (draw-row cross-circle))
(underlay/xy (draw-row (make-ROW 'Circle 'cross 'blank))
0 (image-height (draw-row(make-ROW 'Circle 'cross 'blank)))
(draw-row circle-cross))))
(check-expect(draw-board (make-BOARD cross-circle
(make-ROW 'Circle 'cross 'Circle)
circle-cross))
(underlay/xy (draw-row cross-circle)
0 (image-height (draw-row cross-circle))
(underlay/xy (draw-row (make-ROW 'Circle 'cross 'Circle))
0 (image-height (draw-row (make-ROW 'Circle 'cross 'Circle)))
(draw-row circle-cross))))
(check-expect (draw-board (make-BOARD (make-ROW 'blank 'cross 'Circle)
(make-ROW 'Circle 'cross 'cross)
circle-cross))
(underlay/xy (draw-row (make-ROW 'blank 'cross 'Circle))
0 (image-height (draw-row (make-ROW 'blank 'cross 'Circle)))
(underlay/xy (draw-row (make-ROW 'Circle 'cross 'cross))
0 (image-height (draw-row (make-ROW 'Circle 'cross 'cross)))
(draw-row circle-cross))) )
(check-expect (draw-board (make-BOARD (make-ROW 'blank 'cross 'Circle)
(make-ROW 'Circle 'blank 'cross)
(make-ROW 'cross 'blank 'Circle)))
(underlay/xy (draw-row (make-ROW 'blank 'cross 'Circle))
0 (image-height (draw-row (make-ROW 'blank 'cross 'Circle)))
(underlay/xy (draw-row (make-ROW 'Circle 'blank 'cross))
0 (image-height (draw-row (make-ROW 'Circle 'blank 'cross)))
(draw-row (make-ROW 'cross 'blank 'Circle)))))
(define (draw-board board)
(underlay/xy (draw-row (BOARD-top-row board))
0 (image-height (draw-row (BOARD-top-row board)))
(underlay/xy (draw-row (BOARD-center-row board))
0 (image-height (draw-row(BOARD-center-row board)))
(draw-row (BOARD-bottom-row board)))))
;;purpose: given the x coordinate of the mouse click and returns
;;the symbol 'L, the symbol 'M, or the symbol 'R,
;;depending on whether that X position falls on the right, the middle or the left of the board.
;;contract: which-column:: number -> symbol
;;test
(check-expect (which-column (* square-width .5)) 'L)
(check-expect (which-column (* square-width 1.5)) 'M)
(check-expect (which-column (* square-width 2.3)) 'R)
(define (which-column x-pos)
(cond[(and (>= x-pos 0)(<= x-pos square-width))'L]
[(and (>= x-pos (+ square-width 1))(<= x-pos (* 2 square-width)))'M]
[(and (>= x-pos (+ (* 2 square-width) 1))(<= x-pos (* 3 square-width)))'R]
[else "play in the board,you played outside the square"]))
;;purpose: given the y coordinate of the mouse click and returns
;;the symbol 'T, the symbol 'C, or the symbol 'B,
;;depending on whether that Y position falls on the top, the center or the bottom of the board.
;;contract: which-row:: number -> symbol
;;test
(check-expect (which-row (* square-width .6)) 'T)
(check-expect (which-row (* square-width 1.3)) 'C)
(check-expect (which-row (* square-width 2.7)) 'B)
(define (which-row y-pos)
(cond[(and (>= y-pos 0)(<= y-pos square-width))'T]
[(and (>= y-pos (+ square-width 1))(<= y-pos (* 2 square-width)))'C]
[(and (>= y-pos (+ (* 2 square-width) 1))(<= y-pos (* 3 square-width)))'B]
[else "play in the board,you played outside the square"]))
;;purpose: give the row and the square to be played and returns a new row replacing the left square
;; play-on-left : row square ->row
;;test
(check-expect (play-on-left (make-ROW 'blank 'cross 'Circle) 'Circle)
(make-ROW 'Circle 'cross 'Circle))
(check-expect (play-on-left (make-ROW 'blank 'cross 'Circle) 'cross)
cross-circle)
(check-expect (play-on-left cross-ROW 'Circle)
(make-ROW 'Circle 'cross 'blank))
(define (play-on-left row play)
(make-ROW play (ROW-middle row) (ROW-right row)))
;;purpose: give the row and the square to be played and returns a new row replacing the middle square
;; play-on-middle : row square ->row
;;test
(check-expect (play-on-middle (make-ROW 'blank 'blank 'Circle) 'Circle)
(make-ROW 'blank 'Circle 'Circle))
(check-expect (play-on-middle (make-ROW 'blank 'blank 'Circle) 'cross)
(make-ROW 'blank 'cross 'Circle))
(check-expect (play-on-middle blank-ROW 'Circle)
(make-ROW 'blank 'Circle 'blank))
(define (play-on-middle row play)
(make-ROW (ROW-left row) play (ROW-right row)))
;;purpose: give the row and the square to be played and returns a new row replacing the right square
;; play-on-right : row square ->row
;;test
(check-expect (play-on-right blank-ROW 'Circle)
(make-ROW 'blank 'blank 'Circle))
(check-expect (play-on-right (make-ROW 'blank 'Circle 'blank) 'cross)
(make-ROW 'blank 'Circle 'cross))
(check-expect (play-on-right blank-ROW 'Circle)
(make-ROW 'blank 'blank 'Circle))
(define (play-on-right row play)
(make-ROW (ROW-left row) (ROW-middle row) play ))
;;purpose : given the row, which column ,square to be played returns new row replacing the column
;; play-on-row : row square symbol -> row
(check-expect (play-on-row blank-ROW 'L 'Circle)
(make-ROW 'Circle 'blank 'blank))
(check-expect (play-on-row blank-ROW 'M 'Circle)
(make-ROW 'blank 'Circle 'blank))
(check-expect (play-on-row blank-ROW 'R 'Circle)
(make-ROW 'blank 'blank 'Circle))
(define (play-on-row row column-label play)
(cond [(equal? column-label 'L) (make-ROW play (ROW-middle row) (ROW-right row))]
[(equal? column-label 'M) (make-ROW (ROW-left row) play (ROW-right row))]
[(equal? column-label 'R) (make-ROW (ROW-left row) (ROW-middle row) play)]
[else row]))
;;purpose given a board, a square to be played and the label of the position to be played
;;returns a new board with the square to be played at the labeled position on the top row
;; play-on-board-at-top : board square symbol -> board
;;test
(check-expect (play-on-board-at-top empty-board 'Circle 'L)
(make-BOARD (make-ROW 'Circle 'blank 'blank)
blank-ROW
blank-ROW))
(check-expect (play-on-board-at-top empty-board 'Circle 'M)
(make-BOARD (make-ROW 'blank 'Circle 'blank)
blank-ROW
blank-ROW))
(check-expect (play-on-board-at-top empty-board 'cross 'R)
(make-BOARD (make-ROW 'blank 'blank 'cross)
blank-ROW
blank-ROW))
(define (play-on-board-at-top board play column-label)
(make-BOARD(play-on-row (BOARD-top-row board) column-label play)
(BOARD-center-row board)(BOARD-bottom-row board))
)
;;purpose given a board, a square to be played and the label of the position to be played
;;returns a new board with the square to be played at the labeled position on the middle row
;; play-on-board-at-top : board square symbol -> board
;;test
(check-expect (play-on-board-at-middle empty-board 'Circle 'L)
(make-BOARD blank-ROW
(make-ROW 'Circle 'blank 'blank)
blank-ROW))
(check-expect (play-on-board-at-middle empty-board 'Circle 'M)
(make-BOARD blank-ROW
(make-ROW 'blank 'Circle 'blank)
blank-ROW))
(check-expect (play-on-board-at-middle empty-board 'cross 'R)
(make-BOARD blank-ROW
(make-ROW 'blank 'blank 'cross)
blank-ROW))
(define (play-on-board-at-middle board play column-label)
(make-BOARD (BOARD-top-row board) (play-on-row (BOARD-center-row board) column-label play)
(BOARD-bottom-row board))
)
;;purpose given a board, a square to be played and the label of the position to be played
;;returns a new board with the square to be played at the labeled position on the bottom row
;; play-on-board-at-top : board square symbol -> board
;;test
(check-expect (play-on-board-at-bottom empty-board 'Circle 'L)
(make-BOARD blank-ROW
blank-ROW
(make-ROW 'Circle 'blank 'blank)))
(check-expect (play-on-board-at-bottom empty-board 'Circle 'M)
(make-BOARD blank-ROW
blank-ROW
(make-ROW 'blank 'Circle 'blank)))
(check-expect (play-on-board-at-bottom empty-board 'cross 'R)
(make-BOARD blank-ROW
blank-ROW
(make-ROW 'blank 'blank 'cross)))
(define (play-on-board-at-bottom board play column-label)
(make-BOARD (BOARD-top-row board) (BOARD-center-row board)
(play-on-row (BOARD-bottom-row board) column-label play)
)
)
;;purpose :given the board ,square to be played,column and row label and returns a new board
;;with the square to be played at the position reffered
;; play-on-board : board square symbol symbol -> board
;;test
(check-expect (play-on-board empty-board 'cross 'R 'T)
(make-BOARD (make-ROW 'blank 'blank 'cross )
blank-ROW
blank-ROW))
(check-expect (play-on-board empty-board 'cross 'L 'C)
(make-BOARD blank-ROW
cross-blank
blank-ROW))
(check-expect (play-on-board empty-board 'cross 'M 'B)
(make-BOARD blank-ROW
blank-ROW
cross-ROW))
(define (play-on-board board play column-label row-label)
(cond [(equal? row-label 'T) (play-on-board-at-top board play column-label)]
[(equal? row-label 'C) (play-on-board-at-middle board play column-label)]
[(equal? row-label 'B) (play-on-board-at-bottom board play column-label)]
[else board]))
;;purpose : Given a board structure, a return the image of that board centered on the scene.
;;create-board:board->scene
;;test
(check-expect (create-board (make-BOARD blank-ROW
blank-ROW
cross-ROW))
(place-image (draw-board (make-BOARD blank-ROW
blank-ROW
cross-ROW))
(/ square-width 2)(/ square-width 2) background))
(check-expect (create-board (make-BOARD (make-ROW 'Circle 'cross 'Circle)
blank-ROW
cross-ROW))
(place-image (draw-board (make-BOARD (make-ROW 'Circle 'cross 'Circle)
blank-ROW
cross-ROW))
(/ square-width 2)(/ square-width 2) background))
(check-expect (create-board (make-BOARD (make-ROW 'Circle 'cross 'blank)
blank-ROW
cross-ROW))
(place-image (draw-board (make-BOARD (make-ROW 'Circle 'cross 'blank)
blank-ROW
cross-ROW))
(/ square-width 2)(/ square-width 2) background))
(define (create-board board)
(place-image (draw-board board)(/ square-width 2)(/ square-width 2) background)
)
;; clack1 : Mouse handler. Plays a cross (always a cross) where the mouse is clicked, on button-up.
;; clack1 : board number number symbol -> board
(define (clack1 board x y event)
(cond [(symbol=? event 'button-up)
(play-on-board board 'cross (which-column x) (which-row y))]
[else board]))
(check-expect (clack1 (make-BOARD blank-ROW
blank-ROW
cross-ROW) 40 68 'button-up)
(make-BOARD cross-blank
blank-ROW
cross-ROW))
(check-expect (clack1 (make-BOARD blank-ROW
blank-ROW
cross-ROW) 160 168 'button-up)
(make-BOARD blank-ROW
(make-ROW 'blank 'cross 'blank)
cross-ROW))
(check-expect (clack1 (make-BOARD blank-ROW
blank-ROW
blank-ROW) 310 365 'button-up)
(make-BOARD blank-ROW
blank-ROW
(make-ROW 'blank 'blank 'cross)
))
;; purpose : Given the current player, return which player goes next.
;; other-player : square -> square
(define (other-player play)
(cond [(equal? play 'Circle) 'cross]
[(equal? play 'cross) 'Circle]))
(check-expect (other-player 'cross) 'Circle)
(check-expect (other-player 'Circle) 'cross)
;; purpose : Given a horz. pos (either 'L, 'M or 'R), finds the content of that square.
;; lookup-square : row symbol -> square
(define (lookup-square column-label row)
(cond [(equal? column-label 'L)(ROW-left row)]
[(equal? column-label 'M)(ROW-middle row)]
[(equal? column-label 'R)(ROW-right row)]))
(check-expect(lookup-square 'L (make-ROW 'blank 'Circle 'cross)) 'blank)
(check-expect(lookup-square 'M (make-ROW 'blank 'Circle 'cross)) 'Circle)
(check-expect(lookup-square 'R (make-ROW 'blank 'Circle 'cross)) 'cross)
;; lookup-row : Given a vert. pos (either 'T, 'C or 'B), finds that row.
;; lookup-row : board symbol -> row
(define(lookup-row row-label board)
(cond [(equal? row-label 'T)(BOARD-top-row board)]
[(equal? row-label 'C)(BOARD-center-row board)]
[(equal? row-label 'B)(BOARD-bottom-row board)]))
(check-expect(lookup-row 'T (make-BOARD (make-ROW 'cross 'blank 'Circle)
blank-ROW
blank-ROW)) (make-ROW 'cross 'blank 'Circle))
(check-expect(lookup-row 'C (make-BOARD blank-ROW
(make-ROW 'cross 'blank 'Circle)
blank-ROW)) (make-ROW 'cross 'blank 'Circle))
(check-expect(lookup-row 'B (make-BOARD blank-ROW
blank-ROW
(make-ROW 'cross 'blank 'Circle)
)) (make-ROW 'cross 'blank 'Circle))
;; lookup : Given a horz. and a vert. pos, finds that square.
;; lookup : board symbol symbol -> square
(define (lookup board column-label row-label)
(lookup-square column-label (lookup-row row-label board)))
(check-expect(lookup(make-BOARD (make-ROW 'cross 'blank 'Circle)
blank-ROW
blank-ROW) 'L 'T) 'cross)
(check-expect(lookup(make-BOARD blank-ROW
(make-ROW 'cross 'blank 'Circle)
blank-ROW) 'M 'C) 'blank)
(check-expect(lookup(make-BOARD blank-ROW
blank-ROW
(make-ROW 'cross 'blank 'Circle)
) 'R 'B) 'Circle)
;; move-legal? : Return true if the square at horizondal and vertical position is blank.
;; move-legal? : board symbol symbol -> boolean
(define(move-legal? board column-label row-label)
(equal? (lookup board column-label row-label) 'blank))
(check-expect (move-legal? empty-board 'L 'C) true)
(check-expect (move-legal? (make-BOARD blank-ROW
(make-ROW 'Circle 'cross cross)
blank-ROW)
'M 'C) false)
;;define a structure for game
;;contract make-game :square board number->game
(define-struct GAME (next-player board move-count) #:transparent)
;;defining the initial-game
(define initial-game (make-GAME 'cross empty-board 0))
;;purpose: Given a game and a horz. and vert. position, the next player plays in that square, if legal. The move-count goes up by 1,and the next-player switches hand.
;; play-on-game : game symbol symbol -> game
(check-expect(play-on-game initial-game 'L 'T)
(make-GAME 'Circle
(make-BOARD cross-blank blank-ROW blank-ROW) 1))
(check-expect(play-on-game (make-GAME 'Circle
(make-BOARD cross-blank blank-ROW blank-ROW) 1)
'M 'C )
(make-GAME 'cross
(make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
blank-ROW) 2))
(check-expect(play-on-game(make-GAME 'cross
(make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
blank-ROW) 2)
'R 'B)
(make-GAME 'Circle
(make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
(make-ROW 'blank 'blank 'cross)) 3))
(define (play-on-game game column-label row-label)
(cond [ (move-legal? (GAME-board game) column-label row-label)
(make-GAME (other-player (GAME-next-player game))
(play-on-board (GAME-board game) (GAME-next-player game) column-label row-label)
(+ (GAME-move-count game) 1))]
[else game]))
;; game-over? : Returns true when the game is over.
;; game-over? : game -> boolean
(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
(make-ROW 'blank 'blank 'cross))3)) false)
(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-ROW-blank
(make-ROW 'blank 'Circle 'blank)
(make-ROW 'blank 'blank 'cross))3)) false)
(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-circle
(make-ROW 'cross 'Circle 'cross)
(make-ROW 'Circle 'cross 'Circle))9))true)
(define (game-over? game)
(>= (GAME-move-count game) 9))
;; clack2 : Mouse handler. Plays the game on button-up.
;; clack2 : game number number symbol -> game
(check-expect (clack2 initial-game 90 90 'button-up)
(make-GAME 'Circle
(make-BOARD cross-blank blank-ROW blank-ROW) 1))
(check-expect (clack2 (make-GAME 'Circle
(make-BOARD cross-blank blank-ROW blank-ROW) 1)
160 160 'button-up)
(make-GAME 'cross
(make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
blank-ROW) 2))
(check-expect (clack2 (make-GAME 'cross
(make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
blank-ROW) 2)310 310 'button-up)
(make-GAME 'Circle (make-BOARD cross-blank
(make-ROW 'blank 'Circle 'blank)
(make-ROW 'blank 'blank 'cross)) 3))
(define (clack2 game x y event)
(cond [(symbol=? event 'button-up)
(play-on-game game (which-column x) (which-row y))]
[else game]))
;; game->scene : Draws a game
;; game->scene : game -> scene
(check-expect (game->scene (make-GAME 'Circle
(make-BOARD cross-blank blank-ROW blank-ROW) 1))
(place-image (draw-board (make-BOARD cross-blank blank-ROW blank-ROW))
(/ square-width 2)(/ square-width 2) background))
(check-expect (game->scene (make-GAME 'cross
(make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW) 1))
(place-image (draw-board (make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW))
(/ square-width 2)(/ square-width 2) background))
(define (game->scene game)
(place-image (draw-board (GAME-board game)) (/ square-width 2)(/ square-width 2) background)
)
;; winning-triple? : Return true if a, b, and c are all the same symbol as player.
;; winning-triple? : symbol symbol symbol symbol -> boolean
(check-expect (winning-triple? 'cross 'cross 'cross 'cross)true)
(check-expect (winning-triple? 'Circle 'Circle 'blank 'cross)false)
(check-expect (winning-triple? 'Circle 'Circle 'Circle 'Circle)true)
(check-expect (winning-triple? 'cross 'blank 'cross 'cross)false)
(define (winning-triple? player a b c)
(and(and (equal? player a)(equal? player b))(equal? player c)))
;; winning-row? : Returns true if the indicated row is a win for the given player.
;; winning-row? : board square symbol -> boolean
(check-expect (winning-row? (make-BOARD cross-row
circle-cross
(make-ROW 'Circle 'blank 'blank))
'cross 'T)true)
(check-expect (winning-row? (make-BOARD (make-ROW 'cross 'blank 'Circle)
circle-cross
(make-ROW 'blank 'cross 'blank))
'Circle 'C)false)
(check-expect (winning-row? (make-BOARD (make-ROW 'cross 'Circle 'blank )
(make-ROW 'cross 'Circle 'cross)
(make-ROW 'Circle 'Circle 'Circle))
'Circle 'B)true)
(define (winning-row? board player vertical-pos)
(cond[(equal? vertical-pos 'T)(winning-triple? player (ROW-left (BOARD-top-row board))
(ROW-middle (BOARD-top-row board))
(ROW-right (BOARD-top-row board)))]
[(equal? vertical-pos 'C)(winning-triple? player (ROW-left (BOARD-center-row board))
(ROW-middle (BOARD-center-row board))
(ROW-right (BOARD-center-row board)))]
[(equal? vertical-pos 'B)(winning-triple? player (ROW-left (BOARD-bottom-row board))
(ROW-middle (BOARD-bottom-row board))
(ROW-right (BOARD-bottom-row board)))]
[else false]
))
;; winning-column? : Return true if the indicated column is a win for the given player.
;; winnnig-column? : board square symbol -> boolean
(check-expect (winning-column? (make-BOARD cross-ROW-blank
circle-cross
cross-blank)
'cross 'L)true)
(check-expect (winning-column? (make-BOARD circle-cross
circle-cross
(make-ROW 'blank 'Circle 'blank))
'Circle 'M)true)
(check-expect (winning-column? (make-BOARD circle-cross
(make-ROW 'cross 'blank 'Circle)
(make-ROW 'Circle 'Circle 'Circle))
'Circle 'R)true)
(check-expect (winning-column? (make-BOARD circle-cross
cross-blank
(make-ROW 'Circle 'Circle 'Circle))
'Circle 'R)false)
(define (winning-column? board player horizontal-pos)
(cond[(equal? horizontal-pos 'L)(winning-triple? player (ROW-left (BOARD-top-row board))
(ROW-left (BOARD-center-row board))
(ROW-left (BOARD-bottom-row board)))]
[(equal? horizontal-pos 'M)(winning-triple? player (ROW-middle (BOARD-top-row board))
(ROW-middle (BOARD-center-row board))
(ROW-middle (BOARD-bottom-row board)))]
[(equal? horizontal-pos 'R)(winning-triple? player (ROW-right (BOARD-top-row board))
(ROW-right (BOARD-center-row board))
(ROW-right (BOARD-bottom-row board)))]
[else false]
))
;; winning-down-diagonal? : Return true if the top-left to bottom-right diagonal is a win.
;; winning-down-diagonal? : board square -> boolean
(check-expect (winning-down-diagonal?(make-BOARD (make-ROW 'Circle 'Circle 'Circle)
(make-ROW 'cross 'Circle 'blank)
(make-ROW 'cross 'blank 'Circle))
'Circle)true)
(check-expect (winning-down-diagonal?(make-BOARD circle-cross
cross-blank
(make-ROW 'Circle 'blank 'Circle))
'Circle)false)
(check-expect (winning-down-diagonal?(make-BOARD (make-ROW 'cross 'blank 'cross )
(make-ROW 'Circle 'cross 'blank)
(make-ROW 'blank 'Circle 'cross))
'cross)true)
(define (winning-down-diagonal? board player)
(and (equal? player (ROW-right (BOARD-bottom-row board))) (and (equal? player(ROW-middle (BOARD-center-row board)))
(equal? player (ROW-left (BOARD-top-row board))))))
;; winning-up-diagonal? : Return true if the bottom-left to top-right diagonal is a win.
;; winning-up-diagonal? : board square -> boolean
(check-expect (winning-up-diagonal?(make-BOARD circle-cross
(make-ROW 'cross 'Circle 'blank)
(make-ROW 'Circle 'blank 'Circle))
'Circle)true)
(check-expect (winning-up-diagonal?(make-BOARD circle-cross
cross-blank
(make-ROW 'Circle 'blank 'Circle))
'Circle)false)
(check-expect (winning-up-diagonal?(make-BOARD (make-ROW 'cross 'blank 'cross )
(make-ROW 'Circle 'cross 'blank)
(make-ROW 'cross 'blank 'Circle))
'cross)true)
(define (winning-up-diagonal? board player)
(and (equal? player (ROW-left (BOARD-bottom-row board))) (and (equal? player(ROW-middle (BOARD-center-row board)))
(equal? player (ROW-right (BOARD-top-row board))))))
;; winning-board? : Returns true if the given board is a win for the given player.
;; winning-board? : board square -> boolean
(check-expect (winning-board? (make-BOARD cross-row
circle-cross
blank-circle)
'cross)true)
(check-expect (winning-board? (make-BOARD circle-cross
cross-row
blank-circle)
'cross)true)
(check-expect (winning-board? (make-BOARD circle-cross
blank-circle
cross-row )
'cross)true)
(check-expect (winning-board? (make-BOARD (make-ROW 'Circle 'cross 'cross)
(make-ROW 'Circle 'cross 'Circle)
blank-circle)
'Circle)true)
(check-expect (winning-board? (make-BOARD (make-ROW 'cross 'Circle 'cross)
circle-cross
(make-ROW 'Circle 'Circle 'blank))
'Circle)true)
(check-expect (winning-board? (make-BOARD cross-circle
circle-cross
(make-ROW 'Circle 'blank 'Circle))
'Circle)true)
(check-expect (winning-board? (make-BOARD cross-circle
circle-cross
blank-circle)
'Circle)true)
(check-expect (winning-board? (make-BOARD (make-ROW 'cross 'Circle 'cross)
cross-circle
(make-ROW 'Circle 'blank 'cross))
'cross)true)
(define (winning-board? board player)
(or (winning-up-diagonal? board player)
(or (winning-down-diagonal? board player)
(or (winning-row? board player 'T)
(or (winning-row? board player 'C)
(or (winning-row? board player 'B)
(or (winning-column? board player 'L)
(or (winning-column? board player 'M)
(winning-column? board player 'R)))))))))
;; game-over-or-win? : Returns true when the game is over either because the board is full,
;; or because someone won.
;; game-over-or-win? : game -> boolean
(check-expect (game-over-or-win? (make-GAME 'Circle
(make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW) 3))false)
(check-expect (game-over-or-win? (make-GAME 'Circle
(make-BOARD (make-ROW 'cross 'blank 'Circle)
(make-ROW 'blank 'cross 'Circle)
(make-ROW 'cross 'blank 'Circle))7))true)
(check-expect (game-over-or-win? (make-GAME 'cross
(make-BOARD cross-circle
(make-ROW 'Circle 'cross 'Circle)
(make-ROW 'cross 'Circle 'cross))9))
true)
(define (game-over-or-win? game)
(or (winning-board? (GAME-board game) (GAME-next-player game))
(game-over? game)))
(collect-garbage) (collect-garbage) (collect-garbage)
(printf "running tests with fast path optimization in place\n")
(time (run-tests))
(printf "running tests without fast path optimization in place\n")
(parameterize ([skip-image-equality-fast-path #t])
(time (run-tests)))

103
collects/2htdp/tests/test-image.ss
View File

@ -32,7 +32,9 @@
make-ellipse make-ellipse
make-polygon make-polygon
make-point make-point
make-crop ) make-crop
crop?
normalized-shape?)
(only-in "../private/image-more.ss" (only-in "../private/image-more.ss"
bring-between bring-between
swizzle) swizzle)
@ -1319,6 +1321,37 @@
2 7 2 7
(circle 4 'solid 'black))) (circle 4 'solid 'black)))
;; this test case checks to make sure the number of crops doesn't
;; grow when normalizing shapes.
(let* ([an-image
(crop
0 0 50 50
(crop
0 10 60 60
(crop
10 0 60 60
(overlay
(overlay
(ellipse 20 50 'solid 'red)
(ellipse 30 40 'solid 'black))
(overlay
(ellipse 20 50 'solid 'red)
(ellipse 30 40 'solid 'black))))))]
[an-image+crop
(crop 40 40 10 10 an-image)])
(define (count-crops s)
(define crops 0)
(let loop ([s s])
(when (crop? s)
(set! crops (+ crops 1)))
(when (struct? s)
(for-each loop (vector->list (struct->vector s)))))
crops)
(test (+ (count-crops (normalize-shape (image-shape an-image))) 1)
=>
(count-crops (normalize-shape (image-shape an-image+crop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -1458,3 +1491,71 @@
#rx"^polygon: expected <image-color>") #rx"^polygon: expected <image-color>")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; random testing of normalization
;; make sure normalization actually normalizes
;; and that normalization doesn't introduce new structs
;;
(require redex/reduction-semantics)
(define-language 2htdp/image
(image (rectangle size size mode color)
(line coord coord color)
(add-curve (rectangle size size mode color)
coord coord pull angle
coord coord pull angle
color)
(overlay image image)
(overlay/xy image coord coord image)
(underlay image image)
(underlay/xy image coord coord image)
(crop coord coord size size image)
(scale/xy size size image)
(scale size image)
(rotate angle image))
(size big-nat)
(mode 'outline 'solid "outline" "solid")
(color "red" 'red "blue" "orange" "green" "black")
(coord big-int)
(pull 0 1/2 1/3 2 (/ big-nat (+ 1 big-nat)))
(angle 0 90 45 30 180 natural (* 4 natural))
; Redex tends to choose small numbers.
(big-nat (+ (* 10 natural) natural))
(big-int (+ (* 10 integer) integer)))
(define-namespace-anchor anchor)
(define (image-struct-count obj)
(let ([counts (make-hash)])
(let loop ([obj obj])
(when (struct? obj)
(let ([stuff (vector->list (struct->vector obj))])
(unless (member (car stuff) '(struct:translate struct:scale)) ;; skip these becuase normalization eliminates them
(hash-set! counts (car stuff) (+ 1 (hash-ref counts (car stuff) 0))))
(for-each loop (cdr stuff)))))
(sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x))))))
(define (check-image-properties img-sexp img)
(let* ([raw-size (image-struct-count (image-shape img))]
[normalized (normalize-shape (image-shape img) values)]
[norm-size (image-struct-count normalized)])
(unless (normalized-shape? normalized)
(error 'test-image.ss "found a non-normalized shape after normalization:\n~s"
img-sexp))
(unless (equal? norm-size raw-size)
(error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s"
img-sexp raw-size norm-size))))
(time
(redex-check
2htdp/image
image
(check-image-properties
(term image)
(eval (term image) (namespace-anchor->namespace anchor)))
#:attempts 1000))

34
collects/compiler/private/xform.ss
View File

@ -586,22 +586,24 @@
(define per-block-push? #t) (define per-block-push? #t)
(define gc-var-stack-mode (define gc-var-stack-mode
(ormap (lambda (e) (let loop ([e-raw e-raw])
(cond (ormap (lambda (e)
[(and (pragma? e) (cond
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))) [(and (pragma? e)
'table] (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
[(and (tok? e) 'table]
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)) [(and (tok? e)
'thread-local] (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
[(and (tok? e) 'thread-local]
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)) [(and (tok? e)
'getspecific] (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
[(and (tok? e) 'getspecific]
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) [(and (tok? e)
'function] (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION))
[else #f])) 'function]
e-raw)) [(braces? e) (loop (seq->list (seq-in e)))]
[else #f]))
e-raw)))
;; The code produced by xform uses a number of macros. These macros ;; The code produced by xform uses a number of macros. These macros
;; make the transformation about a little easier to debug, and they ;; make the transformation about a little easier to debug, and they

3
collects/drscheme/private/drscheme-normal.ss
View File

@ -78,6 +78,9 @@
(set-splash-char-observer (set-splash-char-observer
(λ (evt) (λ (evt)
(let ([ch (send evt get-key-code)]) (let ([ch (send evt get-key-code)])
(when (and (eq? ch #\q)
(send evt get-control-down))
(exit))
(when (char? ch) (when (char? ch)
;; as soon as something is typed, load the bitmaps ;; as soon as something is typed, load the bitmaps
(load-magic-images) (load-magic-images)

5
collects/drscheme/private/drsig.ss
View File

@ -79,10 +79,11 @@
;show-syntax-error-context ;show-syntax-error-context
)) ))
(define-signature drscheme:module-langauge-cm^ (define-signature drscheme:module-language-cm^
(module-language<%>)) (module-language<%>))
(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ (define-signature drscheme:module-language^ extends drscheme:module-language-cm^
(add-module-language (add-module-language
module-language-name
module-language-put-file-mixin)) module-language-put-file-mixin))
(define-signature drscheme:module-langauge-tools-cm^ (define-signature drscheme:module-langauge-tools-cm^

150
collects/drscheme/private/frame.ss
View File

@ -300,107 +300,97 @@
;; asks the user for a .plt file, either from the web or from ;; asks the user for a .plt file, either from the web or from
;; a file on the disk and installs it. ;; a file on the disk and installs it.
(define (install-plt-file parent) (define (install-plt-file parent)
(define pref (preferences:get 'drscheme:install-plt-dialog))
(define dialog (define dialog
(instantiate dialog% () (new dialog% [parent parent]
(parent parent) [label (string-constant install-plt-file-dialog-title)]
(alignment '(left center)) [alignment '(left center)]))
(label (string-constant install-plt-file-dialog-title))))
(define tab-panel (define tab-panel
(instantiate tab-panel% () (new tab-panel% [parent dialog]
(parent dialog) [callback (λ (x y) (update-panels))]
(callback (λ (x y) (update-panels))) [choices (list (string-constant install-plt-web-tab)
(choices (list (string-constant install-plt-web-tab) (string-constant install-plt-file-tab))]))
(string-constant install-plt-file-tab))))) (define outer-swapping-panel
(define outer-swapping-panel (instantiate horizontal-panel% () (new horizontal-panel% [parent tab-panel]
(parent tab-panel) [stretchable-height #f]))
(stretchable-height #f))) (define spacing-panel
(define spacing-panel (instantiate horizontal-panel% () (new horizontal-panel% [parent outer-swapping-panel]
(stretchable-width #f) [stretchable-width #f]
(parent outer-swapping-panel) [min-width 20]))
(min-width 20))) (define swapping-panel
(define swapping-panel (instantiate panel:single% () (new panel:single% [parent outer-swapping-panel]
(parent outer-swapping-panel) [alignment '(left center)]
(alignment '(left center)) [stretchable-width #t] [stretchable-height #f]))
(stretchable-width #t) (define file-panel
(stretchable-height #f))) (new horizontal-panel% [parent swapping-panel]
(define file-panel (instantiate horizontal-panel% () [stretchable-width #t] [stretchable-height #f]))
(parent swapping-panel) (define url-panel
(stretchable-width #t) (new horizontal-panel% [parent swapping-panel]
(stretchable-height #f))) [stretchable-height #f]))
(define url-panel (instantiate horizontal-panel% () (define button-panel
(parent swapping-panel) (new horizontal-panel% [parent dialog]
(stretchable-height #f))) [stretchable-height #f] [alignment '(right center)]))
(define button-panel (instantiate horizontal-panel% () (define file-text-field
(parent dialog) (new text-field% [parent file-panel]
(stretchable-height #f) [callback void] [min-width 300] [stretchable-width #t]
(alignment '(right center)))) [init-value (caddr pref)]
(define file-text-field (instantiate text-field% () [label (string-constant install-plt-filename)]))
(parent file-panel) (define file-button
(callback void) (new button% [parent file-panel]
(min-width 300) [callback (λ (x y) (browse))]
(stretchable-width #t) [label (string-constant browse...)]))
(label (string-constant install-plt-filename)))) (define url-text-field
(define file-button (instantiate button% () (new text-field% [parent url-panel]
(parent file-panel) [min-width 300] [stretchable-width #t] [callback void]
(label (string-constant browse...)) [init-value (cadr pref)]
(callback (λ (x y) (browse))))) [label (string-constant install-plt-url)]))
(define url-text-field (instantiate text-field% ()
(parent url-panel)
(label (string-constant install-plt-url))
(min-width 300)
(stretchable-width #t)
(callback void)))
(define-values (ok-button cancel-button) (define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons (gui-utils:ok/cancel-buttons
button-panel button-panel
(λ (x y) (λ (x y) (set! cancel? #f) (send dialog show #f))
(set! cancel? #f) (λ (x y) (send dialog show #f))))
(send dialog show #f))
(λ (x y)
(send dialog show #f))))
;; browse : -> void ;; browse : -> void
;; gets the name of a file from the user and ;; gets the name of a file from the user and updates file-text-field
;; updates file-text-field
(define (browse) (define (browse)
(let ([filename (finder:get-file #f "" #f "" dialog)]) (let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename (when filename
(send file-text-field set-value (path->string filename))))) (send file-text-field set-value (path->string filename)))))
;; from-web? : -> boolean ;; from-web? : -> boolean
;; returns #t if the user has selected a web address ;; returns #t if the user has selected a web address
(define (from-web?) (define (from-web?)
(zero? (send tab-panel get-selection))) (zero? (send tab-panel get-selection)))
(define cancel? #t) (define cancel? #t)
(define (update-panels) (define (update-panels)
(send swapping-panel active-child (define w? (from-web?))
(if (from-web?) (define t (if w? url-text-field file-text-field))
url-panel (send swapping-panel active-child (if w? url-panel file-panel))
file-panel))) (send t focus)
(send (send t get-editor) set-position
0 (string-length (send t get-value))))
;; initialize
(send tab-panel set-selection (if (car pref) 0 1))
(update-panels) (update-panels)
(send dialog show #t) (send dialog show #t)
(preferences:set 'drscheme:install-plt-dialog
(list (from-web?)
(send url-text-field get-value)
(send file-text-field get-value)))
(cond (cond
[cancel? (void)] [cancel? (void)]
[(from-web?) [(from-web?)
(install-plt-from-url (trim-whitespace (send url-text-field get-value)) parent)] (install-plt-from-url
[else (let* ([url (send url-text-field get-value)]
(parameterize ([error-display-handler drscheme:init:original-error-display-handler]) ;; trim whitespaces
(run-installer (string->path (send file-text-field get-value))))])) [url (regexp-replace #rx"^ +" url "")]
[url (regexp-replace #rx" +$" url "")])
;; trim-whitespace: string -> string (if (regexp-match? #rx"^(?:[^/:]*://|$)" url)
;; Trims the whitespace surrounding a string. url
(define (trim-whitespace a-str) (string-append "http://" url)))
(cond parent)]
[(regexp-match #px"^\\s*(.*[^\\s])\\s*$" [else (parameterize ([error-display-handler
a-str) drscheme:init:original-error-display-handler])
=> second] (run-installer
[else (string->path (send file-text-field get-value))))]))
a-str]))
;; install-plt-from-url : string (union #f dialog%) -> void ;; install-plt-from-url : string (union #f dialog%) -> void
;; downloads and installs a .plt file from the given url ;; downloads and installs a .plt file from the given url

265
collects/drscheme/private/language-configuration.ss
View File

@ -19,6 +19,11 @@
(define original-output (current-output-port)) (define original-output (current-output-port))
(define (printfo . args) (apply fprintf original-output args)) (define (printfo . args) (apply fprintf original-output args))
(define sc-use-language-in-source "Use the language declared in the source")
(define sc-choose-a-language "Choose a language")
(define sc-lang-in-source-discussion
"The #lang line at the start of a program declares its language. This is the default and preferred mode for DrScheme.")
(provide language-configuration@) (provide language-configuration@)
(define-unit language-configuration@ (define-unit language-configuration@
@ -28,7 +33,8 @@
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:help-desk: drscheme:help-desk^]) [prefix drscheme:help-desk: drscheme:help-desk^]
[prefix drscheme:module-language: drscheme:module-language^])
(export drscheme:language-configuration/internal^) (export drscheme:language-configuration/internal^)
;; settings-preferences-symbol : symbol ;; settings-preferences-symbol : symbol
@ -341,9 +347,11 @@
cached-fringe) cached-fringe)
(define/override (on-select i) (define/override (on-select i)
(if (and i (is-a? i hieritem-language<%>)) (cond
(something-selected i) [(and i (is-a? i hieritem-language<%>))
(nothing-selected))) (something-selected i)]
[else
(non-language-selected)]))
;; this is used only because we set `on-click-always' ;; this is used only because we set `on-click-always'
(define/override (on-click i) (define/override (on-click i)
(when (and i (is-a? i hierarchical-list-compound-item<%>)) (when (and i (is-a? i hierarchical-list-compound-item<%>))
@ -353,12 +361,55 @@
(when (and i (is-a? i hieritem-language<%>)) (when (and i (is-a? i hieritem-language<%>))
(something-selected i) (something-selected i)
(ok-handler 'execute))) (ok-handler 'execute)))
(super-instantiate (parent)) (super-new [parent parent])
;; do this so we can expand/collapse languages on a single click ;; do this so we can expand/collapse languages on a single click
(send this on-click-always #t))) (send this on-click-always #t)))
(define outermost-panel (make-object horizontal-pane% parent)) (define outermost-panel (make-object horizontal-pane% parent))
(define languages-hier-list (make-object selectable-hierlist% outermost-panel)) (define languages-choice-panel (new vertical-panel%
[parent outermost-panel]
[alignment '(left top)]))
(define use-language-in-source-rb
(new radio-box%
[label #f]
[choices (list sc-use-language-in-source)]
[parent languages-choice-panel]
[callback
(λ (rb evt)
(module-language-selected)
(send use-chosen-language-rb set-selection #f))]))
(define in-source-discussion-panel (new horizontal-panel%
[parent languages-choice-panel]
[stretchable-height #f]))
(define in-source-discussion-spacer (new horizontal-panel%
[parent in-source-discussion-panel]
[stretchable-width #f]
[min-width 32]))
(define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel))
(define use-chosen-language-rb
(new radio-box%
[label #f]
[choices (list sc-choose-a-language)]
[parent languages-choice-panel]
[callback
(λ (this-rb evt)
(let ([i (send languages-hier-list get-selected)])
(cond
[(and i (is-a? i hieritem-language<%>))
(something-selected i)]
[else
(non-language-selected)]))
(send use-language-in-source-rb set-selection #f))]))
(define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel]))
(define languages-hier-list-spacer (new horizontal-panel%
[parent languages-hier-list-panel]
[stretchable-width #f]
[min-width 16]))
(define languages-hier-list (new selectable-hierlist%
[parent languages-hier-list-panel]
[style '(no-border no-hscroll hide-vscroll transparent)]))
(define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details-outer-panel (make-object vertical-pane% outermost-panel))
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
(define details-panel (make-object panel:single% details/manual-parent-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel))
@ -395,19 +446,39 @@
(init-rest args) (init-rest args)
(public selected) (public selected)
(define (selected) (define (selected)
(let ([ldp (get-language-details-panel)]) (update-gui-based-on-selected-language language get-language-details-panel get/set-settings))
(when ldp
(send details-panel active-child ldp)))
(send one-line-summary-message set-label (send language get-one-line-summary))
(send revert-to-defaults-button enable #t)
(set! get/set-selected-language-settings get/set-settings)
(set! selected-language language))
(apply super-make-object args)))) (apply super-make-object args))))
;; nothing-selected : -> void (define (update-gui-based-on-selected-language language get-language-details-panel get/set-settings)
(let ([ldp (get-language-details-panel)])
(when ldp
(send details-panel active-child ldp)))
(send one-line-summary-message set-label (send language get-one-line-summary))
(send revert-to-defaults-button enable #t)
(set! get/set-selected-language-settings get/set-settings)
(set! selected-language language))
(define (module-language-selected)
;; need to deselect things in the languages-hier-list at this point.
;(send languages-hier-list select #f)
(send use-chosen-language-rb set-selection #f)
(send use-language-in-source-rb set-selection 0)
(ok-handler 'enable)
(send details-button enable #t)
(update-gui-based-on-selected-language module-language*language
module-language*get-language-details-panel
module-language*get/set-settings))
(define module-language*language 'module-language*-not-yet-set)
(define module-language*get-language-details-panel 'module-language*-not-yet-set)
(define module-language*get/set-settings 'module-language*-not-yet-set)
;; non-language-selected : -> void
;; updates the GUI and selected-language and get/set-selected-language-settings ;; updates the GUI and selected-language and get/set-selected-language-settings
;; for when no language is selected. ;; for when some non-language is selected in the hierlist
(define (nothing-selected) (define (non-language-selected)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(send revert-to-defaults-button enable #f) (send revert-to-defaults-button enable #f)
(send details-panel active-child no-details-panel) (send details-panel active-child no-details-panel)
(send one-line-summary-message set-label "") (send one-line-summary-message set-label "")
@ -418,6 +489,8 @@
;; something-selected : item -> void ;; something-selected : item -> void
(define (something-selected item) (define (something-selected item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(send item selected)) (send item selected))
@ -449,7 +522,7 @@
positions numbers)) positions numbers))
(when (null? (cdr positions)) (when (null? (cdr positions))
(unless (equal? positions (list "Module")) (unless (equal? positions (list drscheme:module-language:module-language-name))
(error 'drscheme:language (error 'drscheme:language
"Only the module language may be at the top level. Other languages must have at least two levels"))) "Only the module language may be at the top level. Other languages must have at least two levels")))
@ -488,17 +561,7 @@
[get-language-details-panel (lambda () language-details-panel)] [get-language-details-panel (lambda () language-details-panel)]
[get/set-settings (lambda x (apply real-get/set-settings x))] [get/set-settings (lambda x (apply real-get/set-settings x))]
[position (car positions)] [position (car positions)]
[number (car numbers)] [number (car numbers)])
[mixin (compose
number-mixin
(language-mixin language get-language-details-panel get/set-settings))]
[item
(send hier-list new-item
(if second-number
(compose second-number-mixin mixin)
mixin))]
[text (send item get-editor)]
[delta (send language get-style-delta)])
(set! construct-details (set! construct-details
(let ([old construct-details]) (let ([old construct-details])
@ -529,24 +592,40 @@
[else [else
(get/set-settings (send language default-settings))]))))) (get/set-settings (send language default-settings))])))))
(send item set-number number) (cond
(when second-number [(equal? positions (list drscheme:module-language:module-language-name))
(send item set-second-number second-number)) (set! module-language*language language)
(send text insert position) (set! module-language*get-language-details-panel get-language-details-panel)
(when delta (set! module-language*get/set-settings get/set-settings)]
(cond [else
[(list? delta) (let* ([mixin (compose
(for-each (λ (x) number-mixin
(send text change-style (language-mixin language get-language-details-panel get/set-settings))]
(car x) [item
(cadr x) (send hier-list new-item
(caddr x))) (if second-number
delta)] (compose second-number-mixin mixin)
[(is-a? delta style-delta%) mixin))]
(send text change-style [text (send item get-editor)]
(send language get-style-delta) [delta (send language get-style-delta)])
0 (send item set-number number)
(send text last-position))])))] (when second-number
(send item set-second-number second-number))
(send text insert position)
(when delta
(cond
[(list? delta)
(for-each (λ (x)
(send text change-style
(car x)
(cadr x)
(caddr x)))
delta)]
[(is-a? delta style-delta%)
(send text change-style
(send language get-style-delta)
0
(send text last-position))])))]))]
[else (let* ([position (car positions)] [else (let* ([position (car positions)]
[number (car numbers)] [number (car numbers)]
[sub-ht/sub-hier-list [sub-ht/sub-hier-list
@ -662,32 +741,38 @@
;; and selects the current language ;; and selects the current language
(define (open-current-language) (define (open-current-language)
(when (and language-to-show settings-to-show) (when (and language-to-show settings-to-show)
(let ([language-position (send language-to-show get-language-position)]) (cond
(cond [(equal? language-to-show
[(null? (cdr language-position)) module-language*language)
;; nothing to open here (module-language-selected)]
;; this should only be the module language [else
(send (car (send languages-hier-list get-items)) select #t) (send use-chosen-language-rb set-selection 0)
(void)] (send use-language-in-source-rb set-selection #f)
[else (let ([language-position (send language-to-show get-language-position)])
(let loop ([hi languages-hier-list] (cond
[(null? (cdr language-position))
;; nothing to open here
(send (car (send languages-hier-list get-items)) select #t)
(void)]
[else
(let loop ([hi languages-hier-list]
;; skip the first position, since it is flattened into the dialog ;; skip the first position, since it is flattened into the dialog
[first-pos (cadr language-position)] [first-pos (cadr language-position)]
[position (cddr language-position)]) [position (cddr language-position)])
(let ([child (let ([child
;; know that this `car' is okay by construction of the dialog ;; know that this `car' is okay by construction of the dialog
(car (car
(filter (λ (x) (filter (λ (x)
(equal? (send (send x get-editor) get-text) (equal? (send (send x get-editor) get-text)
first-pos)) first-pos))
(send hi get-items)))]) (send hi get-items)))])
(cond (cond
[(null? position) [(null? position)
(send child select #t)] (send child select #t)]
[else [else
(send child open) (send child open)
(loop child (car position) (cdr position))])))])))) (loop child (car position) (cdr position))])))]))])))
;; docs-callback : -> void ;; docs-callback : -> void
(define (docs-callback) (define (docs-callback)
@ -826,6 +911,44 @@
(and get/set-selected-language-settings (and get/set-selected-language-settings
(get/set-selected-language-settings)))))) (get/set-selected-language-settings))))))
(define (add-discussion p)
(let* ([t (new text:standard-style-list%)]
[c (new editor-canvas%
[stretchable-width #t]
[horizontal-inset 0]
[vertical-inset 0]
[parent p]
[style '(no-border auto-vscroll no-hscroll transparent)]
[editor t])])
(send c set-line-count 3)
(send t set-styles-sticky #f)
(send t set-autowrap-bitmap #f)
(let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))]
[do-insert
(λ (str tt-style?)
(let ([before (send t last-position)])
(send t insert str before before)
(cond
[tt-style?
(send t change-style
(send (send t get-style-list) find-named-style "Standard")
before (send t last-position))]
[else
(send t change-style
(send (send t get-style-list) basic-style)
before (send t last-position))])
(send t change-style size-sd before (send t last-position))))])
(let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)])
(do-insert (car strs) #f)
(unless (null? (cdr strs))
(do-insert "#lang" #t)
(loop (cdr strs)))))
(send t hide-caret #t)
(send t auto-wrap #t)
(send t lock #t)))
(define panel-background-editor-canvas% (define panel-background-editor-canvas%
(class editor-canvas% (class editor-canvas%
(inherit get-dc get-client-size) (inherit get-dc get-client-size)

5
collects/drscheme/private/main.ss
View File

@ -152,6 +152,11 @@
(λ (x) (and (list? x) (λ (x) (and (list? x)
(andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) (andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x)))
x)))) x))))
(preferences:set-default 'drscheme:install-plt-dialog
'(#t "" "") ; url-selected?, url string, file string
(λ (x) (and (list? x) (= 3 (length x))
(boolean? (car x))
(andmap string? (cdr x)))))
(preferences:set-un/marshall (preferences:set-un/marshall
'drscheme:user-defined-keybindings 'drscheme:user-defined-keybindings

18
collects/drscheme/private/module-language.ss
View File

@ -29,7 +29,7 @@
(define module-language<%> (define module-language<%>
(interface () (interface ()
)) get-users-language-name))
;; add-module-language : -> void ;; add-module-language : -> void
;; adds the special module-only language to drscheme ;; adds the special module-only language to drscheme
@ -53,10 +53,24 @@
(define default-full-trace? #t) (define default-full-trace? #t)
(define default-auto-text "#lang scheme\n") (define default-auto-text "#lang scheme\n")
(define module-language-name "Determine langauge from source")
;; module-mixin : (implements drscheme:language:language<%>) ;; module-mixin : (implements drscheme:language:language<%>)
;; -> (implements drscheme:language:language<%>) ;; -> (implements drscheme:language:language<%>)
(define (module-mixin %) (define (module-mixin %)
(class* % (drscheme:language:language<%> module-language<%>) (class* % (drscheme:language:language<%> module-language<%>)
(inherit get-language-name)
(define/public (get-users-language-name defs-text)
(let* ([i (open-input-text-editor defs-text)]
[l (with-handlers ((exn:fail? (λ (x) '?)))
(read-language i (lambda () '?)))])
(if (eq? '? l)
(get-language-name)
(regexp-replace #rx".*#(?:!|lang ) *"
(send defs-text get-text 0 (file-position i))
""))))
(define/override (use-namespace-require/copy?) #f) (define/override (use-namespace-require/copy?) #f)
(define/augment (capability-value key) (define/augment (capability-value key)
@ -328,7 +342,7 @@
(super-new (super-new
[module #f] [module #f]
[language-position (list "Module")] [language-position (list module-language-name)]
[language-numbers (list -32768)]))) [language-numbers (list -32768)])))
;; can be called with #f to just kill the repl (in case we want to kill it ;; can be called with #f to just kill the repl (in case we want to kill it

24
collects/drscheme/private/rep.ss
View File

@ -89,7 +89,8 @@ TODO
(prefix drscheme:text: drscheme:text^) (prefix drscheme:text: drscheme:text^)
(prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:debug: drscheme:debug^) (prefix drscheme:debug: drscheme:debug^)
[prefix drscheme:eval: drscheme:eval^]) [prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:module-language: drscheme:module-language^])
(export (rename drscheme:rep^ (export (rename drscheme:rep^
[-text% text%] [-text% text%]
[-text<%> text<%>])) [-text<%> text<%>]))
@ -402,9 +403,15 @@ TODO
default-settings? default-settings?
(drscheme:language-configuration:language-settings-settings language-settings))) (drscheme:language-configuration:language-settings-settings language-settings)))
(define (extract-language-name language-settings) (define (extract-language-name language-settings defs-text)
(send (drscheme:language-configuration:language-settings-language language-settings) (cond
get-language-name)) [(is-a? (drscheme:language-configuration:language-settings-language language-settings)
drscheme:module-language:module-language<%>)
(send (drscheme:language-configuration:language-settings-language language-settings)
get-users-language-name defs-text)]
[else
(send (drscheme:language-configuration:language-settings-language language-settings)
get-language-name)]))
(define (extract-language-style-delta language-settings) (define (extract-language-style-delta language-settings)
(send (drscheme:language-configuration:language-settings-language language-settings) (send (drscheme:language-configuration:language-settings-language language-settings)
get-style-delta)) get-style-delta))
@ -1587,7 +1594,7 @@ TODO
(let-values (((before after) (let-values (((before after)
(insert/delta (insert/delta
this this
(extract-language-name user-language-settings) (extract-language-name user-language-settings definitions-text)
dark-green-delta dark-green-delta
(extract-language-style-delta user-language-settings))) (extract-language-style-delta user-language-settings)))
((url) (extract-language-url user-language-settings))) ((url) (extract-language-url user-language-settings)))
@ -1618,6 +1625,7 @@ TODO
(reset-regions (list (list (last-position) (last-position)))) (reset-regions (list (list (last-position) (last-position))))
(set-unread-start-point (last-position)) (set-unread-start-point (last-position))
(set-insertion-point (last-position)) (set-insertion-point (last-position))
(set! indenting-limit (last-position))
(set-allow-edits #f) (set-allow-edits #f)
(set! repl-header-end #f) (set! repl-header-end #f)
(end-edit-sequence)) (end-edit-sequence))
@ -1653,6 +1661,12 @@ TODO
(end-edit-sequence) (end-edit-sequence)
(clear-undos)) (clear-undos))
(define indenting-limit 0)
(define/override (get-limit n)
(cond
[(< n indenting-limit) 0]
[else indenting-limit]))
;; avoid calling paragraph-start-position very often. ;; avoid calling paragraph-start-position very often.
(define repl-header-end #f) (define repl-header-end #f)
(define/private (get-repl-header-end) (define/private (get-repl-header-end)

4
collects/framework/private/text.ss
View File

@ -1758,6 +1758,9 @@ WARNING: printf is rebound in the body of the unit to always
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin ((class->interface text%)) (clever-file-format<%>) (mixin ((class->interface text%)) (clever-file-format<%>)
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
;; all-string-snips : -> boolean
;; returns #t when it is safe to save this file in 'text mode.
(define/private (all-string-snips) (define/private (all-string-snips)
(let loop ([s (find-first-snip)]) (let loop ([s (find-first-snip)])
(cond (cond
@ -1765,6 +1768,7 @@ WARNING: printf is rebound in the body of the unit to always
[(is-a? s string-snip%) [(is-a? s string-snip%)
(loop (send s next))] (loop (send s next))]
[else #f]))) [else #f])))
(define/augment (on-save-file name format) (define/augment (on-save-file name format)
(let ([all-strings? (all-string-snips)]) (let ([all-strings? (all-string-snips)])
(cond (cond

18
collects/framework/splash.ss
View File

@ -280,19 +280,11 @@
(define quit-on-close? #t) (define quit-on-close? #t)
(define splash-tlw% (define splash-tlw%
(case (system-type) (class dialog%
[(unix) (define/augment (on-close)
(class dialog% (when quit-on-close?
(define/augment (on-close) (exit)))
(when quit-on-close? (super-new)))
(exit)))
(super-new))]
[else
(class frame%
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new [style '(no-resize-border)]))]))
(define splash-canvas% (define splash-canvas%
(class canvas% (class canvas%

5
collects/honu/main.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require "private/honu-typed-scheme.ss" (require "private/honu-typed-scheme.ss"
;; "private/honu.ss"
"private/macro.ss") "private/macro.ss")
(provide (rename-out (#%dynamic-honu-module-begin #%module-begin) (provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
@ -10,11 +11,15 @@
(honu-* *) (honu-* *)
(honu-/ /) (honu-/ /)
(honu-- -) (honu-- -)
(honu-? ?)
(honu-: :)
(honu-comma |,|)
) )
#%datum #%datum
true true
false false
display display
display2
newline newline
else else
(rename-out (rename-out

122
collects/honu/private/honu-typed-scheme.ss
View File

@ -6,6 +6,7 @@
syntax/name syntax/name
syntax/define syntax/define
syntax/parse syntax/parse
syntax/parse/experimental
scheme/splicing scheme/splicing
"contexts.ss" "contexts.ss"
"util.ss" "util.ss"
@ -22,17 +23,18 @@
;; macro for defining literal tokens that can be used in macros ;; macro for defining literal tokens that can be used in macros
(define-syntax-rule (define-literal name ...) (define-syntax-rule (define-literal name ...)
(begin (begin
(define-syntax name (lambda (stx) (define-syntax name (lambda (stx)
(raise-syntax-error 'name (raise-syntax-error 'name
"this is a literal and cannot be used outside a macro"))) "this is a literal and cannot be used outside a macro")))
...)) ...))
(define-literal honu-return) (define-literal honu-return)
(define-literal semicolon) (define-literal semicolon)
(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-% (define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-%
honu-= honu-+= honu--= honu-*= honu-/= honu-%= honu-= honu-+= honu--= honu-*= honu-/= honu-%=
honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=) honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
honu-? honu-: honu-comma)
;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
@ -43,9 +45,9 @@
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!) (define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
(make-struct-type 'honu-trans #f 1 0 #f (make-struct-type 'honu-trans #f 1 0 #f
(list (list prop:honu-transformer #t)) (list (list prop:honu-transformer #t))
(current-inspector) 0)) (current-inspector) 0))
(define (make-honu-transformer proc) (define (make-honu-transformer proc)
(unless (and (procedure? proc) (unless (and (procedure? proc)
@ -66,6 +68,7 @@
(and (positive? (string-length str)) (and (positive? (string-length str))
(memq (string-ref str 0) sym-chars))))))) (memq (string-ref str 0) sym-chars)))))))
;; returns a transformer or #f
(define (get-transformer stx) (define (get-transformer stx)
;; if its an identifier and bound to a transformer return it ;; if its an identifier and bound to a transformer return it
(define (bound-transformer stx) (define (bound-transformer stx)
@ -355,6 +358,7 @@
x(2) x(2)
|# |#
(define (parse-block-one/2 stx context) (define (parse-block-one/2 stx context)
(define (parse-one stx context) (define (parse-one stx context)
(define-syntax-class block (define-syntax-class block
@ -364,28 +368,63 @@ x(2)
[pattern (type:id name:id (#%parens args ...) body:block . rest) [pattern (type:id name:id (#%parens args ...) body:block . rest)
#:with result #'(define (name args ...) #:with result #'(define (name args ...)
body.result)]) body.result)])
(define-syntax-class expr
[pattern f]) (define (syntax-object-position mstart end)
(if (stx-null? end)
(length (syntax->list mstart))
(let loop ([start mstart]
[count 0])
;; (printf "Checking ~a vs ~a\n" start end)
(cond
[(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)]
[(eq? (stx-car start) (stx-car end)) count]
;; [(equal? start end) count]
[else (loop (stx-cdr start) (add1 count))]))))
(define-primitive-splicing-syntax-class (expr)
#:attrs (result)
#:description "expr"
(lambda (stx fail)
(cond
[(stx-null? stx) (fail)]
[(get-transformer stx) => (lambda (transformer)
(let-values ([(used rest)
(transformer stx context)])
(list rest (syntax-object-position stx rest)
used)))]
[else (syntax-case stx ()
[(f . rest) (list #'rest 1 #'f)])])))
#;
(define-splicing-syntax-class expr
[pattern (~seq f ...) #:with result])
(define-splicing-syntax-class call (define-splicing-syntax-class call
[pattern (~seq e:expr (#%parens arg:expression-1)) #:literals (honu-comma)
#:with call #'(e arg.result)]) [pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...))
#:with call #'(e.result arg.result ...)])
(define-splicing-syntax-class expression-last (define-splicing-syntax-class expression-last
[pattern (~seq call:call) #:with result #'call.call] [pattern (~seq call:call) #:with result #'call.call]
[pattern (~seq x:number) #:with result #'x] [pattern (~seq x:number) #:with result #'x]
[pattern (~seq e:expr) #:with result #'e.result]
) )
(define-syntax-rule (define-infix-operator name next [operator reducer] ...) (define-syntax-rule (define-infix-operator name next [operator reducer] ...)
(define-splicing-syntax-class name (begin
#:literals (operator ...) (define-syntax-class operator-class
[pattern (~seq (~var left next) operator (~var right name)) #:literals (operator ...)
#:with result (reducer #'left.result #'right.result)] (pattern operator #:attr func reducer)
... ...)
[pattern (~seq (~var exp next)) (define-splicing-syntax-class name
#:with result #'exp.result] (pattern (~seq (~var left next)
)) (~optional (~seq (~var op operator-class) (~var right name))))
#:with result
(cond [(attribute right)
((attribute op.func) #'left.result #'right.result)]
[else
#'left.result])))))
;; TODO: maybe just have a precedence macro that creates all these constructs
;; (infix-operators ([honu-* ...] ;; (infix-operators ([honu-* ...]
;; [honu-- ...]) ;; [honu-- ...])
;; ([honu-+ ...] ;; ([honu-+ ...]
@ -414,23 +453,6 @@ x(2)
#'(begin #'(begin
result ...)))])) result ...)))]))
#;
(infix-operators expression-1 expression-last
([honu-+ (syntax-lambda (left right)
#'(+ left right))]
[honu-- (syntax-lambda (left right)
#'(- left right))])
([honu-* (syntax-lambda (left right)
#'(* left right))]
[honu-/ (syntax-lambda (left right)
#'(/ left right))]))
(define-syntax-class expression-top
[pattern (e:expression-1 semicolon . rest)
#:with result #'e.result])
;; infix operators in the appropriate precedence level ;; infix operators in the appropriate precedence level
;; things defined lower in the table have a higher precedence. ;; things defined lower in the table have a higher precedence.
;; the first set of operators is `expression-1' ;; the first set of operators is `expression-1'
@ -462,10 +484,25 @@ x(2)
[honu-% (sl (left right) #'(modulo left right))] [honu-% (sl (left right) #'(modulo left right))]
[honu-/ (sl (left right) #'(/ left right))]))) [honu-/ (sl (left right) #'(/ left right))])))
(define-splicing-syntax-class ternary
#:literals (honu-? honu-:)
[pattern (~seq condition:expression-1 (~optional (~seq honu-? on-true:ternary
honu-: on-false:ternary)))
#:with result
(cond [(attribute on-true)
#'(if condition.result on-true.result on-false.result)]
[else #'condition.result])])
(define-syntax-class expression-top
#:literals (semicolon)
[pattern (e:ternary semicolon . rest)
#:with result #'e.result])
;; (printf "~a\n" (syntax-class-parse function stx)) ;; (printf "~a\n" (syntax-class-parse function stx))
(syntax-parse stx (syntax-parse stx
[function:function (values #'function.result #'function.rest)] [function:function (values #'function.result #'function.rest)]
[expr:expression-top (values #'expr.result #'expr.rest)] [expr:expression-top (values #'expr.result #'expr.rest)]
#;
[(x:number . rest) (values #'x #'rest)] [(x:number . rest) (values #'x #'rest)]
)) ))
(cond (cond
@ -519,7 +556,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(lambda (stx ctx) (lambda (stx ctx)
(define (parse-complete-block stx) (define (parse-complete-block stx)
;; (printf "Parsing complete block ~a\n" (syntax->datum stx)) ;; (printf "Parsing complete block ~a\n" (syntax->datum stx))
(with-syntax ([(exprs ...) (parse-block stx ctx)]) (with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)])
#'(begin exprs ...)) #'(begin exprs ...))
#; #;
(let-values ([(a b) (let-values ([(a b)
@ -551,7 +588,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[(_ condition:paren-expr on-true:block else on-false:block . rest) [(_ condition:paren-expr on-true:block else on-false:block . rest)
;; (printf "used if with else\n") ;; (printf "used if with else\n")
(let ([result #'(if condition.expr on-true.line on-false.line)]) (let ([result #'(if condition.expr on-true.line on-false.line)])
(expression-result ctx result #'rest))] (expression-result ctx result (syntax/loc #'rest rest)))]
[(_ condition:paren-expr on-true:block . rest) [(_ condition:paren-expr on-true:block . rest)
;; (printf "used if with no else\n") ;; (printf "used if with no else\n")
(let ([result #'(when condition.expr on-true.line)]) (let ([result #'(when condition.expr on-true.line)])
@ -643,11 +680,16 @@ if (foo){
(define-syntax (honu-top stx) (define-syntax (honu-top stx)
(raise-syntax-error #f "interactive use is not yet supported")) (raise-syntax-error #f "interactive use is not yet supported"))
(define (display2 x y)
(printf "~a ~a" x y))
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) ;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx () (syntax-case stx ()
[(_) #'(begin (void))] [(_) #'(begin (void))]
[(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body [(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
the-expression-context
#;
the-top-block-context)]) the-top-block-context)])
;; (printf "Rest is ~a\n" (syntax->datum rest)) ;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code] (with-syntax ([code code]

2
collects/macro-debugger/expand.ss
View File

@ -25,7 +25,7 @@
(define (expand/show-predicate stx show?) (define (expand/show-predicate stx show?)
(let-values ([(result deriv) (trace/result stx)]) (let-values ([(result deriv) (trace/result stx)])
(when (exn? result) (raise result)) (when (exn? result) (raise result))
(let-values ([(_steps _uses stx exn2) (let-values ([(_steps _defs _uses stx exn2)
(parameterize ((macro-policy show?)) (parameterize ((macro-policy show?))
(reductions+ deriv))]) (reductions+ deriv))])
(when (exn? exn2) (raise exn2)) (when (exn? exn2) (raise exn2))

9
collects/macro-debugger/stepper-text.ss
View File

@ -93,13 +93,6 @@
((if display-like? display write) (syntax-dummy-val obj) port)] ((if display-like? display write) (syntax-dummy-val obj) port)]
[else [else
(error 'pretty-print-hook "unexpected special value: ~e" obj)])) (error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-extend-style-table)
(let* ([ids identifier-list]
[syms (map (lambda (x) (hash-ref stx=>flat x)) ids)]
[like-syms (map syntax-e ids)])
(pretty-print-extend-style-table (pp-better-style-table)
syms
like-syms)))
(define (pp-better-style-table) (define (pp-better-style-table)
(pretty-print-extend-style-table (pretty-print-current-style-table) (pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list) (map car extended-style-list)
@ -107,7 +100,7 @@
(parameterize (parameterize
([pretty-print-size-hook pp-size-hook] ([pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook] [pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table)]) [pretty-print-current-style-table (pp-better-style-table)])
(pretty-print/defaults datum))) (pretty-print/defaults datum)))
(define (->show-function show) (define (->show-function show)

2
collects/meta/dist-specs.ss
View File

@ -344,7 +344,7 @@ mz-manuals := (scribblings: "main/") ; generates main pages (next line)
(notes: "COPYING.LIB" "COPYING-libscheme.txt") (notes: "COPYING.LIB" "COPYING-libscheme.txt")
(doc: "doc-license.txt") ; needed (when docs are included) (doc: "doc-license.txt") ; needed (when docs are included)
(doc+src: "reference/" "guide/" "quick/" "more/" (doc+src: "reference/" "guide/" "quick/" "more/"
"foreign/" "inside/" "futures/" "foreign/" "inside/" "futures/" "places/"
"honu/") "honu/")
(doc: "*.{html|css|js|sxref}") (doc: "*.{html|css|js|sxref}")
(scribblings: "{{info|icons}.ss|*.png}" "compiled") (scribblings: "{{info|icons}.ss|*.png}" "compiled")

2
collects/mred/private/check.ss
View File

@ -117,7 +117,7 @@
(unless (and (integer? i) (exact? i) (not (negative? i))) (unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who) (raise-type-error (who->name who)
(if false-ok? (if false-ok?
"non-negative exact integeror #f" "non-negative exact integer or #f"
"non-negative exact integer" ) "non-negative exact integer" )
i)))) i))))

33
collects/mred/private/mritem.ss
View File

@ -264,40 +264,47 @@
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-orientation cwho style) (check-orientation cwho style)
(check-non-negative-integer cwho selection))) (check-non-negative-integer/false cwho selection)))
(private-field (private-field
[wx #f]) [wx #f])
(private (private
[check-button [check-button
(lambda (method n) (lambda (method n false-ok?)
(check-non-negative-integer `(method radio-box% ,method) n) ((if false-ok?
(unless (< n (length chcs)) check-non-negative-integer/false
(raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n)))]) check-non-negative-integer)
`(method radio-box% ,method) n)
(when n
(unless (< n (length chcs))
(raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n))))])
(override (override
[enable (entry-point [enable (entry-point
(case-lambda (case-lambda
[(on?) (send wx enable on?)] [(on?) (send wx enable on?)]
[(which on?) (check-button 'enable which) [(which on?) (check-button 'enable which #f)
(send wx enable which on?)]))] (send wx enable which on?)]))]
[is-enabled? (entry-point [is-enabled? (entry-point
(case-lambda (case-lambda
[() (send wx is-enabled?)] [() (send wx is-enabled?)]
[(which) (check-button 'is-enabled? which) [(which) (check-button 'is-enabled? which #f)
(send wx is-enabled? which)]))]) (send wx is-enabled? which)]))])
(public (public
[get-number (lambda () (length chcs))] [get-number (lambda () (length chcs))]
[get-item-label (lambda (n) [get-item-label (lambda (n)
(check-button 'get-item-label n) (check-button 'get-item-label n #f)
(list-ref chcs n))] (list-ref chcs n))]
[get-item-plain-label (lambda (n) [get-item-plain-label (lambda (n)
(check-button 'get-item-plain-label n) (check-button 'get-item-plain-label n #f)
(wx:label->plain-label (list-ref chcs n)))] (wx:label->plain-label (list-ref chcs n)))]
[get-selection (entry-point (lambda () (send wx get-selection)))] [get-selection (entry-point (lambda () (let ([v (send wx get-selection)])
(if (equal? v -1)
#f
v))))]
[set-selection (entry-point [set-selection (entry-point
(lambda (v) (lambda (v)
(check-button 'set-selection v) (check-button 'set-selection v #t)
(send wx set-selection v)))]) (send wx set-selection (or v -1))))])
(sequence (sequence
(as-entry (as-entry
(lambda () (lambda ()
@ -317,7 +324,7 @@
(length choices)) (length choices))
selection)))) selection))))
label parent callback #f))) label parent callback #f)))
(when (positive? selection) (when (or (not selection) (positive? selection))
(set-selection selection))))) (set-selection selection)))))
(define slider% (define slider%

2
collects/mred/private/wxme/style.ss
View File

@ -621,7 +621,7 @@
(define/public (s-set-as-basic slist) (define/public (s-set-as-basic slist)
(set! style-list slist) (set! style-list slist)
(set! name "basic") (set! name "Basic")
(set! base-style #f) (set! base-style #f)
(set! nonjoin-delta (new style-delta%)) (set! nonjoin-delta (new style-delta%))

47
collects/mrlib/hierlist/hierlist-unit.ss
View File

@ -10,10 +10,10 @@
(require (rename mzlib/list sort* sort) (require (rename mzlib/list sort* sort)
mzlib/etc) mzlib/etc)
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png)) (define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png)) (define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask))
(define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png)) (define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png/mask))
(define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png)) (define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png/mask))
(provide hierlist@) (provide hierlist@)
(define-unit hierlist@ (define-unit hierlist@
@ -93,7 +93,10 @@
(send dc draw-bitmap-section bitmap (send dc draw-bitmap-section bitmap
(+ x (max 0 (- (/ size 2) (/ bw 2)))) (+ x (max 0 (- (/ size 2) (/ bw 2))))
(+ y (max 0 (- (/ size 2) (/ bh 2)))) (+ y (max 0 (- (/ size 2) (/ bh 2))))
0 0 (min bw (+ size 2)) (min bh (+ size 2)))))] 0 0 (min bw (+ size 2)) (min bh (+ size 2))
'solid
(send the-color-database find-color "black")
(send bitmap get-loaded-mask))))]
[size-cache-invalid (lambda () (set! size-calculated? #f))] [size-cache-invalid (lambda () (set! size-calculated? #f))]
[on-event [on-event
(lambda (dc x y mediax mediay event) (lambda (dc x y mediax mediay event)
@ -340,7 +343,8 @@
[parent-snip parent-snp] [parent-snip parent-snp]
[children null] [children null]
[new-children null] [new-children null]
[no-sublists? #f]) [no-sublists? #f]
[transparent? #f])
(private (private
[append-children! (lambda () [append-children! (lambda ()
(unless (null? new-children) (unless (null? new-children)
@ -350,17 +354,19 @@
[insert-item [insert-item
(lambda (mixin snip% whitespace?) (lambda (mixin snip% whitespace?)
(let ([s (make-object snip% this top top-select (add1 depth) mixin)]) (let ([s (make-object snip% this top top-select (add1 depth) mixin)])
(send s use-style-background transparent?)
(begin-edit-sequence) (begin-edit-sequence)
(unless (and (null? children) (unless (and (null? children)
(null? new-children)) (null? new-children))
(insert #\newline (last-position))) (insert #\newline (last-position)))
(when whitespace? (when whitespace?
(insert (make-whitespace) (last-position))) (insert (make-whitespace) (last-position)))
(insert s (last-position)) (insert s (last-position))
(end-edit-sequence) (end-edit-sequence)
(set! new-children (cons s new-children)) (set! new-children (cons s new-children))
(send s get-item)))]) (send s get-item)))])
(public (public
[set-transparent (λ (t?) (set! transparent? (and t? #t)))]
[get-parent-snip (lambda () parent-snip)] [get-parent-snip (lambda () parent-snip)]
[deselect-all [deselect-all
(lambda () (lambda ()
@ -479,7 +485,7 @@
;; Snip for a compound list item ;; Snip for a compound list item
(define hierarchical-list-snip% (define hierarchical-list-snip%
(class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f]) (class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f])
(private-field (private-field
[parent prnt] [parent prnt]
[top tp]) [top tp])
@ -583,11 +589,19 @@
[content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)] [content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)]
[arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))] [arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))]
[whitespace (make-object whitespace-snip%)]) [whitespace (make-object whitespace-snip%)])
(override
[use-style-background
(λ (x)
(super use-style-background x)
(send title-snip use-style-background x)
(send content-snip use-style-background x)
(send content-buffer set-transparent x))])
(public (public
[get-arrow-snip (lambda () arrow)]) [get-arrow-snip (lambda () arrow)])
(sequence (inherit style-background-used?)
(sequence
(super-init main-buffer #f 0 0 0 0 0 0 0 0) (super-init main-buffer #f 0 0 0 0 0 0 0 0)
(send main-buffer hide-caret #t) (send main-buffer hide-caret #t)
(send main-buffer insert arrow) (send main-buffer insert arrow)
(when title (send title-buffer insert title)) (when title (send title-buffer insert title))
(when content (send content-buffer insert content)) (when content (send content-buffer insert content))
@ -637,7 +651,7 @@
(send list-keymap map-function "return" "toggle-open/closed") (send list-keymap map-function "return" "toggle-open/closed")
(define hierarchical-list% (define hierarchical-list%
(class100 editor-canvas% (parent [style '(no-hscroll)]) (class100 editor-canvas% (parent [style '(no-hscroll)])
(inherit min-width min-height allow-tab-exit) (inherit min-width min-height allow-tab-exit)
(rename [super-on-char on-char] (rename [super-on-char on-char]
[super-on-focus on-focus]) [super-on-focus on-focus])
@ -702,8 +716,14 @@
(send (car l) scroll-to)] (send (car l) scroll-to)]
[else (loop (cdr l))])))] [else (loop (cdr l))])))]
[select (lambda (i) [select (lambda (i)
(send i select #t) (cond
(send i scroll-to))] [i
(send i select #t)
(send i scroll-to)]
[(and (allow-deselect) selected)
(send selected show-select #f)
(set! selected #f)
(set! selected-item #f)]))]
[click-select (lambda (i) [click-select (lambda (i)
(send i click-select #t) (send i click-select #t)
(send i scroll-to))] (send i scroll-to))]
@ -854,6 +874,7 @@
[selected #f] [selected #f]
[selected-item #f]) [selected-item #f])
(sequence (sequence
(send top-buffer set-transparent (member 'transparent style))
(super-init parent top-buffer style) (super-init parent top-buffer style)
(allow-tab-exit #t) (allow-tab-exit #t)
(send top-buffer set-cursor arrow-cursor) (send top-buffer set-cursor arrow-cursor)

113
collects/mrlib/image-core.ss
View File

@ -1,5 +1,4 @@
#lang scheme/base #lang scheme/base
#| #|
This library is the part of the 2htdp/image This library is the part of the 2htdp/image
@ -157,12 +156,12 @@ has been moved out).
(define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes) (define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes)
;; a normalized-shape (subtype of shape) is either ;; a normalized-shape (subtype of shape) is either
;; - (make-overlay normalized-shape cropped-simple-shape) ;; - (make-overlay normalized-shape cn-or-simple-shape)
;; - cropped-simple-shape ;; - cn-or-simple-shape
;; a cropped-simple-shape is either ;; an cn-or-simple-shape is either:
;; - (make-crop (listof points) cropped-simple-shape)
;; - simple-shape ;; - simple-shape
;; - (make-crop (listof points) normalized-shape)
;; a simple-shape (subtype of shape) is ;; a simple-shape (subtype of shape) is
;; - (make-translate dx dy np-atomic-shape)) ;; - (make-translate dx dy np-atomic-shape))
@ -378,16 +377,10 @@ has been moved out).
[dy 0] [dy 0]
[x-scale 1] [x-scale 1]
[y-scale 1] [y-scale 1]
[crops '()] ;; (listof (listof point))
[bottom #f]) [bottom #f])
(define (scale-point p) (define (scale-point p)
(make-point (+ dx (* x-scale (point-x p))) (make-point (+ dx (* x-scale (point-x p)))
(+ dy (* y-scale (point-y p))))) (+ dy (* y-scale (point-y p)))))
(define (add-crops shape)
(let loop ([crops crops])
(cond
[(null? crops) shape]
[else (make-crop (car crops) (loop (cdr crops)))])))
(cond (cond
[(translate? shape) [(translate? shape)
(loop (translate-shape shape) (loop (translate-shape shape)
@ -395,7 +388,6 @@ has been moved out).
(+ dy (* y-scale (translate-dy shape))) (+ dy (* y-scale (translate-dy shape)))
x-scale x-scale
y-scale y-scale
crops
bottom)] bottom)]
[(scale? shape) [(scale? shape)
(loop (scale-shape shape) (loop (scale-shape shape)
@ -403,34 +395,36 @@ has been moved out).
dy dy
(* x-scale (scale-x shape)) (* x-scale (scale-x shape))
(* y-scale (scale-y shape)) (* y-scale (scale-y shape))
crops
bottom)] bottom)]
[(overlay? shape) [(overlay? shape)
(loop (overlay-bottom shape) (loop (overlay-bottom shape)
dx dy x-scale y-scale crops dx dy x-scale y-scale
(loop (overlay-top shape) (loop (overlay-top shape)
dx dy x-scale y-scale crops dx dy x-scale y-scale
bottom))] bottom))]
[(crop? shape) [(crop? shape)
(loop (crop-shape shape) (let* ([inside (loop (crop-shape shape)
dx dy x-scale y-scale dx dy x-scale y-scale
(cons (map scale-point (crop-points shape)) crops) #f)]
bottom)] [this-one
(make-crop (map scale-point (crop-points shape))
inside)])
(if bottom
(make-overlay bottom this-one)
this-one))]
[(polygon? shape) [(polygon? shape)
(let* ([this-one (let* ([this-one
(add-crops (make-polygon (map scale-point (polygon-points shape))
(make-polygon (map scale-point (polygon-points shape)) (polygon-mode shape)
(polygon-mode shape) (scale-color (polygon-color shape) x-scale y-scale))])
(scale-color (polygon-color shape) x-scale y-scale)))])
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))] (f this-one)))]
[(line-segment? shape) [(line-segment? shape)
(let ([this-one (let ([this-one
(add-crops (make-line-segment (scale-point (line-segment-start shape))
(make-line-segment (scale-point (line-segment-start shape)) (scale-point (line-segment-end shape))
(scale-point (line-segment-end shape)) (scale-color (line-segment-color shape) x-scale y-scale))])
(scale-color (line-segment-color shape) x-scale y-scale)))])
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))] (f this-one)))]
@ -439,27 +433,40 @@ has been moved out).
;; between the two points when it is drawn, ;; between the two points when it is drawn,
;; so we don't need to scale it here ;; so we don't need to scale it here
(let ([this-one (let ([this-one
(add-crops (make-curve-segment (scale-point (curve-segment-start shape))
(make-curve-segment (scale-point (curve-segment-start shape)) (curve-segment-s-angle shape)
(curve-segment-s-angle shape) (curve-segment-s-pull shape)
(curve-segment-s-pull shape) (scale-point (curve-segment-end shape))
(scale-point (curve-segment-end shape)) (curve-segment-e-angle shape)
(curve-segment-e-angle shape) (curve-segment-e-pull shape)
(curve-segment-e-pull shape) (scale-color (curve-segment-color shape) x-scale y-scale))])
(scale-color (curve-segment-color shape) x-scale y-scale)))])
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))] (f this-one)))]
[(np-atomic-shape? shape) [(np-atomic-shape? shape)
(let ([this-one (let ([this-one
(add-crops (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
(make-translate dx dy (scale-np-atomic x-scale y-scale shape)))])
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))] (f this-one)))]
[else [else
(error 'normalize-shape "unknown shape ~s\n" shape)]))) (error 'normalize-shape "unknown shape ~s\n" shape)])))
(define (normalized-shape? s)
(cond
[(overlay? s)
(and (normalized-shape? (overlay-top s))
(cn-or-simple-shape? (overlay-bottom s)))]
[else
(cn-or-simple-shape? s)]))
(define (cn-or-simple-shape? s)
(cond
[(crop? s)
(normalized-shape? (crop-shape s))]
[else
(simple-shape? s)]))
(define (simple-shape? shape) (define (simple-shape? shape)
(or (and (translate? shape) (or (and (translate? shape)
(np-atomic-shape? (translate-shape shape))) (np-atomic-shape? (translate-shape shape)))
@ -555,22 +562,30 @@ has been moved out).
(define (render-normalized-shape shape dc dx dy) (define (render-normalized-shape shape dc dx dy)
(cond (cond
[(overlay? shape) [(overlay? shape)
(render-cropped-simple-shape (overlay-bottom shape) dc dx dy) (render-cn-or-simple-shape (overlay-bottom shape) dc dx dy)
(render-normalized-shape (overlay-top shape) dc dx dy)] (render-normalized-shape (overlay-top shape) dc dx dy)]
[else [else
(render-cropped-simple-shape shape dc dx dy)])) (render-cn-or-simple-shape shape dc dx dy)]))
(define (render-cropped-simple-shape shape dc dx dy) (define last-cropped-points (make-parameter #f))
(define (render-cn-or-simple-shape shape dc dx dy)
(cond (cond
[(crop? shape) [(crop? shape)
(let ([old-region (send dc get-clipping-region)] (let ([points (crop-points shape)])
[new-region (new region% [dc dc])] (cond
[path (polygon-points->path (crop-points shape))]) [(equal? points (last-cropped-points))
(send new-region set-path path dx dy) (render-normalized-shape (crop-shape shape) dc dx dy)]
(when old-region (send new-region intersect old-region)) [else
(send dc set-clipping-region new-region) (let ([old-region (send dc get-clipping-region)]
(render-cropped-simple-shape (crop-shape shape) dc dx dy) [new-region (new region% [dc dc])]
(send dc set-clipping-region old-region))] [path (polygon-points->path points)])
(send new-region set-path path dx dy)
(when old-region (send new-region intersect old-region))
(send dc set-clipping-region new-region)
(parameterize ([last-cropped-points points])
(render-normalized-shape (crop-shape shape) dc dx dy))
(send dc set-clipping-region old-region))]))]
[else [else
(render-simple-shape shape dc dx dy)])) (render-simple-shape shape dc dx dy)]))
@ -932,4 +947,4 @@ the mask bitmap and the original bitmap are all together in a single bytes!
;; method names ;; method names
(provide get-shape get-bb get-normalized? get-normalized-shape) (provide get-shape get-bb get-normalized? get-normalized-shape)
(provide np-atomic-shape? atomic-shape? simple-shape?) (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)

10
collects/mrlib/scribblings/hierlist/list.scrbl
View File

@ -16,7 +16,15 @@ Creates a hierarchical-list control.
'resize-corner 'deleted 'transparent)) 'resize-corner 'deleted 'transparent))
'(no-hscroll)])]{ '(no-hscroll)])]{
Creates the control.} Creates the control.
If the style @scheme['transparent] is passed, then the
@method[editor-snip% use-style-background] method will be
called with @scheme[#t] when editor snips are created as part of
the hierarchical list, ensuring that the entire control is
transparent.
}
@defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>) @defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>)

4
collects/r5rs/main.ss
View File

@ -209,7 +209,9 @@
form)] form)]
[((unquote-splicing e) . rest) [((unquote-splicing e) . rest)
(if (zero? depth) (if (zero? depth)
#`(mappend e #,(loop #'rest depth)) (if (null? (syntax-e #'rest))
#'e ;; Note: we're not check for a list
#`(mappend e #,(loop #'rest depth)))
#`(mcons (mcons 'unquote-splicing #`(mcons (mcons 'unquote-splicing
#,(loop #'(e) (sub1 depth))) #,(loop #'(e) (sub1 depth)))
#,(loop #'rest depth)))] #,(loop #'rest depth)))]

1
collects/redex/pict.ss
View File

@ -59,6 +59,7 @@
[default-style (parameter/c text-style/c)] [default-style (parameter/c text-style/c)]
[non-terminal-style (parameter/c text-style/c)] [non-terminal-style (parameter/c text-style/c)]
[non-terminal-subscript-style (parameter/c text-style/c)] [non-terminal-subscript-style (parameter/c text-style/c)]
[non-terminal-superscript-style (parameter/c text-style/c)]
[linebreaks (parameter/c (or/c false/c (listof boolean?)))] [linebreaks (parameter/c (or/c false/c (listof boolean?)))]
[curly-quotes-for-strings (parameter/c boolean?)] [curly-quotes-for-strings (parameter/c boolean?)]
[white-bracket-sizing (parameter/c [white-bracket-sizing (parameter/c

22
collects/redex/private/core-layout.ss
View File

@ -7,6 +7,7 @@
texpict/utils texpict/utils
texpict/mrpict texpict/mrpict
scheme/match
scheme/gui/base scheme/gui/base
scheme/class) scheme/class)
@ -21,6 +22,7 @@
label-style label-style
non-terminal-style non-terminal-style
non-terminal-subscript-style non-terminal-subscript-style
non-terminal-superscript-style
label-font-size label-font-size
default-font-size default-font-size
metafunction-font-size metafunction-font-size
@ -688,18 +690,15 @@
'modern 'modern
(default-font-size)))))] (default-font-size)))))]
[(and (symbol? atom) [(and (symbol? atom)
(regexp-match #rx"^([^_]*)_(.*)$" (symbol->string atom))) (regexp-match #rx"^([^_^]*)_([^^]*)\\^?(.*)$" (symbol->string atom)))
=> =>
(λ (m) (match-lambda
(let* ([first-part (cadr m)] [(list _ nt sub sup)
[second-part (caddr m)] (let* ([sub-pict (basic-text sub (non-terminal-subscript-style))]
[first-span (- span (string-length first-part))]) [sup-pict (basic-text sup (non-terminal-superscript-style))]
(list [sub+sup (lbl-superimpose sub-pict sup-pict)])
(non-terminal->token col first-span first-part) (list (non-terminal->token col span nt)
(make-string-token (+ col first-span) (make-pict-token (+ col span) 0 sub+sup)))])]
(- span first-span)
second-part
(non-terminal-subscript-style)))))]
[(or (memq atom all-nts) [(or (memq atom all-nts)
(memq atom '(number variable variable-except variable-not-otherwise-mentioned))) (memq atom '(number variable variable-except variable-not-otherwise-mentioned)))
(list (non-terminal->token col span (format "~s" atom)))] (list (non-terminal->token col span (format "~s" atom)))]
@ -747,6 +746,7 @@
(define (unksc str) (pink-background ((current-text) str 'modern (default-font-size)))) (define (unksc str) (pink-background ((current-text) str 'modern (default-font-size))))
(define non-terminal-style (make-parameter '(italic . roman))) (define non-terminal-style (make-parameter '(italic . roman)))
(define non-terminal-subscript-style (make-parameter `(subscript . ,(non-terminal-style)))) (define non-terminal-subscript-style (make-parameter `(subscript . ,(non-terminal-style))))
(define non-terminal-superscript-style (make-parameter `(superscript . ,(non-terminal-style))))
(define default-style (make-parameter 'roman)) (define default-style (make-parameter 'roman))
(define metafunction-style (make-parameter 'swiss)) (define metafunction-style (make-parameter 'swiss))
(define (metafunction-text str) ((current-text) str (metafunction-style) (metafunction-font-size))) (define (metafunction-text str) ((current-text) str (metafunction-style) (metafunction-font-size)))

462
collects/redex/private/rg.ss
View File

@ -14,9 +14,6 @@
(define (exotic-choice? [random random]) (= 0 (random 5))) (define (exotic-choice? [random random]) (= 0 (random 5)))
(define (use-lang-literal? [random random]) (= 0 (random 20))) (define (use-lang-literal? [random random]) (= 0 (random 20)))
(define (preferred-production? attempt [random random])
(and (>= attempt preferred-production-threshold)
(zero? (random 2))))
(define default-check-attempts 1000) (define default-check-attempts 1000)
@ -57,27 +54,8 @@
(define (pick-string lang-lits attempt [random random]) (define (pick-string lang-lits attempt [random random])
(random-string lang-lits (random-natural 1/5 random) attempt random)) (random-string lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt name cross? lang attempt pref-prods (define (pick-nts name cross? lang attempt)
[random random] (nt-rhs (nt-by-name lang name cross?)))
[pref-prod? preferred-production?])
(let ([prods (nt-rhs (nt-by-name lang name cross?))])
(cond [(and pref-prods (pref-prod? attempt random))
(hash-ref
((if cross? pref-prods-cross pref-prods-non-cross)
pref-prods)
name)]
[else prods])))
(define-struct pref-prods (cross non-cross))
(define (pick-preferred-productions lang)
(let ([pick (λ (sel)
(for/hash ([nt (sel lang)])
(values (nt-name nt)
(list (pick-from-list (nt-rhs nt))))))])
(make-pref-prods
(pick compiled-lang-cclang)
(pick compiled-lang-lang))))
(define (pick-from-list l [random random]) (list-ref l (random (length l)))) (define (pick-from-list l [random random]) (list-ref l (random (length l))))
@ -118,9 +96,6 @@
(define proportion-at-size 1/10) (define proportion-at-size 1/10)
(define post-threshold-incr 50) (define post-threshold-incr 50)
(define preferred-production-threshold
(+ retry-threshold 2000))
;; Determines the parameter p for which random-natural's expected value is E ;; Determines the parameter p for which random-natural's expected value is E
(define (expected-value->p E) (define (expected-value->p E)
;; E = 0 => p = 1, which breaks random-natural ;; E = 0 => p = 1, which breaks random-natural
@ -177,11 +152,11 @@
who what attempts (if (= attempts 1) "" "s"))]) who what attempts (if (= attempts 1) "" "s"))])
(raise (make-exn:fail:redex:generation-failure str (current-continuation-marks))))) (raise (make-exn:fail:redex:generation-failure str (current-continuation-marks)))))
(define (generate lang decisions@ user-gen retries what) (define (generate lang decisions@ what)
(define-values/invoke-unit decisions@ (define-values/invoke-unit decisions@
(import) (export decisions^)) (import) (export decisions^))
(define ((generate-nt lang base-cases generate pref-prods) (define ((generate-nt lang base-cases generate retries)
name cross? size attempt in-hole env) name cross? size attempt in-hole env)
(let*-values (let*-values
([(term _) ([(term _)
@ -193,10 +168,10 @@
(min-prods (nt-by-name lang name cross?) (min-prods (nt-by-name lang name cross?)
((if cross? base-cases-cross base-cases-non-cross) ((if cross? base-cases-cross base-cases-non-cross)
base-cases)) base-cases))
((next-non-terminal-decision) name cross? lang attempt pref-prods)))]) ((next-non-terminal-decision) name cross? lang attempt)))])
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
(λ (_ env) (mismatches-satisfied? env)) (λ (_ env) (mismatches-satisfied? env))
size attempt)]) size attempt retries)])
term)) term))
(define (generate-sequence ellipsis generate env length) (define (generate-sequence ellipsis generate env length)
@ -222,18 +197,18 @@
(values (cons term terms) (cons env envs)))))]) (values (cons term terms) (cons env envs)))))])
(values seq (merge-environments envs)))) (values seq (merge-environments envs))))
(define (generate/pred name gen pred init-sz init-att) (define (generate/pred name gen pred init-sz init-att retries)
(let ([pre-threshold-incr (let ([pre-threshold-incr
(ceiling (ceiling
(/ (- retry-threshold init-att) (/ (- retry-threshold init-att)
(* proportion-before-threshold retries)))] (* proportion-before-threshold (add1 retries))))]
[incr-size? [incr-size?
(λ (remain) (λ (remain)
(zero? (zero?
(modulo (sub1 remain) (modulo (sub1 remain)
(ceiling (* proportion-at-size (ceiling (* proportion-at-size
retries)))))]) retries)))))])
(let retry ([remaining retries] (let retry ([remaining (add1 retries)]
[size init-sz] [size init-sz]
[attempt init-att]) [attempt init-att])
(if (zero? remaining) (if (zero? remaining)
@ -279,120 +254,109 @@
(cons (make-bind (binder-name key) val) bindings) (cons (make-bind (binder-name key) val) bindings)
bindings)))) bindings))))
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat) (define (generate-pat lang sexp retries size attempt env in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt)) (define recur (curry generate-pat lang sexp retries size attempt))
(define recur/pat (recur env in-hole)) (define recur/pat (recur env in-hole))
(define ((recur/pat/size-attempt pat) size attempt) (define ((recur/pat/size-attempt pat) size attempt)
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) (generate-pat lang sexp retries size attempt env in-hole pat))
(define clang (rg-lang-clang lang)) (define clang (rg-lang-clang lang))
(define gen-nt (define gen-nt
(generate-nt (generate-nt
clang clang
(rg-lang-base-cases lang) (rg-lang-base-cases lang)
(curry generate-pat lang sexp pref-prods user-gen user-acc) (curry generate-pat lang sexp retries)
pref-prods)) retries))
(define (default-gen user-acc) (match pat
(match pat [`number (values ((next-number-decision) attempt) env)]
[`number (values ((next-number-decision) attempt) env)] [`natural (values ((next-natural-decision) attempt) env)]
[`natural (values ((next-natural-decision) attempt) env)] [`integer (values ((next-integer-decision) attempt) env)]
[`integer (values ((next-integer-decision) attempt) env)] [`real (values ((next-real-decision) attempt) env)]
[`real (values ((next-real-decision) attempt) env)] [`(variable-except ,vars ...)
[`(variable-except ,vars ...) (generate/pred 'variable
(generate/pred 'variable (recur/pat/size-attempt 'variable)
(recur/pat/size-attempt 'variable) (λ (var _) (not (memq var vars)))
(λ (var _) (not (memq var vars))) size attempt retries)]
size attempt)] [`variable
[`variable (values ((next-variable-decision) (rg-lang-lits lang) attempt)
(values ((next-variable-decision) (rg-lang-lits lang) attempt) env)]
env)] [`variable-not-otherwise-mentioned
[`variable-not-otherwise-mentioned (generate/pred 'variable
(generate/pred 'variable (recur/pat/size-attempt 'variable)
(recur/pat/size-attempt 'variable) (λ (var _) (not (memq var (compiled-lang-literals clang))))
(λ (var _) (not (memq var (compiled-lang-literals clang)))) size attempt retries)]
size attempt)] [`(variable-prefix ,prefix)
[`(variable-prefix ,prefix) (define (symbol-append prefix suffix)
(define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let-values ([(term env) (recur/pat 'variable)])
(let-values ([(term env) (recur/pat 'variable)]) (values (symbol-append prefix term) env))]
(values (symbol-append prefix term) env))] [`string
[`string (values ((next-string-decision) (rg-lang-lits lang) attempt)
(values ((next-string-decision) (rg-lang-lits lang) attempt) env)]
env)] [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) (recur/pat/size-attempt pat)
(recur/pat/size-attempt pat) (λ (_ env) (condition (bindings env)))
(λ (_ env) (condition (bindings env))) size attempt retries)]
size attempt)] [`(name ,(? symbol? id) ,p)
[`(name ,(? symbol? id) ,p) (let-values ([(term env) (recur/pat p)])
(let-values ([(term env) (recur/pat p)]) (values term (hash-set env (make-binder id) term)))]
(values term (hash-set env (make-binder id) term)))] [`hole (values in-hole env)]
[`hole (values in-hole env)] [`(in-hole ,context ,contractum)
[`(in-hole ,context ,contractum) (let-values ([(term env) (recur/pat contractum)])
(let-values ([(term env) (recur/pat contractum)]) (recur env term context))]
(recur env term context))] [`(hide-hole ,pattern) (recur env the-hole pattern)]
[`(hide-hole ,pattern) (recur env the-hole pattern)] [`any
[`any (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] [(term _) (generate-pat new-lang
; Don't use preferred productions for the sexp language. sexp
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)] retries
[(term _) (generate-pat new-lang size
sexp attempt
pref-prods empty-env
user-gen the-hole
user-acc nt)])
size (values term env))]
attempt [(? (is-nt? clang))
empty-env (values (gen-nt pat #f size attempt in-hole env) env)]
the-hole [(struct binder ((or (? (is-nt? clang) nt)
nt)]) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
(values term env))] (generate/prior pat env (λ () (recur/pat nt)))]
[(? (is-nt? clang)) [(struct binder ((or (? built-in? b)
(values (gen-nt pat #f size attempt in-hole env) env)] (app (symbol-match named-nt-rx) (? built-in? b)))))
[(struct binder ((or (? (is-nt? clang) nt) (generate/prior pat env (λ () (recur/pat b)))]
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(generate/prior pat env (λ () (recur/pat nt)))] (? symbol? (? (is-nt? clang) nt)))))
[(struct binder ((or (? built-in? b) (let-values ([(term _) (recur/pat nt)])
(app (symbol-match named-nt-rx) (? built-in? b))))) (values term (hash-set env pat term)))]
(generate/prior pat env (λ () (recur/pat b)))] [(struct mismatch (name (app (symbol-match mismatch-nt-rx)
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(? symbol? (? (is-nt? clang) nt))))) (let-values ([(term _) (recur/pat b)])
(let-values ([(term _) (recur/pat nt)]) (values term (hash-set env pat term)))]
(values term (hash-set env pat term)))] [`(cross ,(? symbol? cross-nt))
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (values (gen-nt cross-nt #t size attempt in-hole env) env)]
(? symbol? (? built-in? b))))) [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
(let-values ([(term _) (recur/pat b)]) [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(values term (hash-set env pat term)))] (let*-values ([(length) (let ([prior (hash-ref env class #f)])
[`(cross ,(? symbol? cross-nt)) (if prior prior ((next-sequence-decision) attempt)))]
(values (gen-nt cross-nt #t size attempt in-hole env) env)] [(seq env) (generate-sequence ellipsis recur env length)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] [(rest env) (recur (hash-set (hash-set env class length) name length)
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) in-hole rest)])
(let*-values ([(length) (let ([prior (hash-ref env class #f)]) (values (append seq rest) env))]
(if prior prior ((next-sequence-decision) attempt)))] [(list-rest pat rest)
[(seq env) (generate-sequence ellipsis recur env length)] (let*-values
[(rest env) (recur (hash-set (hash-set env class length) name length) ([(pat-term env) (recur/pat pat)]
in-hole rest)]) [(rest-term env) (recur env in-hole rest)])
(values (append seq rest) env))] (values (cons pat-term rest-term) env))]
[(list-rest pat rest) [else
(let*-values (error what "unknown pattern ~s\n" pat)]))
([(pat-term env) (recur/pat pat)]
[(rest-term env) (recur env in-hole rest)])
(values (cons pat-term rest-term) env))]
[else
(error what "unknown pattern ~s\n" pat)]))
(user-gen
pat size in-hole user-acc env attempt
(λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env])
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
default-gen))
(let ([rg-lang (prepare-lang lang)] (let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)]) [rg-sexp (prepare-lang sexp)])
(λ (pat) (λ (pat)
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
(λ (size attempt) (λ (size attempt retries)
(let-values ([(term env) (let-values ([(term env)
(generate/pred (generate/pred
pat pat
@ -400,16 +364,14 @@
(generate-pat (generate-pat
rg-lang rg-lang
rg-sexp rg-sexp
((next-pref-prods-decision) (rg-lang-clang rg-lang)) retries
user-gen
#f
size size
attempt attempt
empty-env empty-env
the-hole the-hole
parsed)) parsed))
(λ (_ env) (mismatches-satisfied? env)) (λ (_ env) (mismatches-satisfied? env))
size attempt)]) size attempt retries)])
(values term (bindings env)))))))) (values term (bindings env))))))))
(define-struct base-cases (cross non-cross)) (define-struct base-cases (cross non-cross))
@ -681,36 +643,35 @@
x x
(raise-type-error 'redex-check "reduction-relation" x))) (raise-type-error 'redex-check "reduction-relation" x)))
(define (defer-all pat size in-hole acc env att recur defer) (define-for-syntax (term-generator lang pat decisions@ what)
(defer acc))
(define-for-syntax (term-generator lang pat decisions@ custom retries what)
(with-syntax ([pattern (with-syntax ([pattern
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
(language-id-nts lang what) (language-id-nts lang what)
what #t pat)]) what #t pat)])
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern))) #`((generate #,lang #,decisions@ '#,what) `pattern)))
(define-syntax (generate-term stx) (define-syntax (generate-term stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang pat size . kw-args) [(name lang pat size . kw-args)
(with-syntax ([(attempt retries custom) (with-syntax ([(attempt retries)
(parse-kw-args `((#:attempt . 1) (parse-kw-args `((#:attempt-num . 1)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)]) stx)])
(with-syntax ([generate (term-generator #'lang (syntax/loc stx
#'pat ((generate-term lang pat) size #:attempt-num attempt #:retries retries)))]
#'(generation-decisions) [(name lang pat)
#'custom (with-syntax ([make-gen (term-generator #'lang
#'retries #'pat
'generate-term)]) #'(generation-decisions)
(syntax/loc stx (syntax-e #'name))])
(let-values ([(term _) (generate size attempt)]) (syntax/loc stx
term))))] (let ([generate make-gen])
[(_ lang pat size) (λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
(syntax/loc stx (generate-term lang pat size #:attempt 1))])) (let ([att (assert-nat 'name attempt-num)]
[ret (assert-nat 'name retries)])
(let-values ([(term _) (generate size att ret)])
term))))))]))
(define-for-syntax (show-message stx) (define-for-syntax (show-message stx)
(syntax-case stx () (syntax-case stx ()
@ -734,12 +695,12 @@
(let-values ([(names names/ellipses) (let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'redex-check) (extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)] 'redex-check #t #'pat)]
[(attempts-stx source-stx retries-stx custom-stx) [(attempts-stx source-stx retries-stx print?-stx)
(apply values (apply values
(parse-kw-args `((#:attempts . ,#'default-check-attempts) (parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:source . #f) (#:source . #f)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:custom . ,#'defer-all)) (#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx))]) stx))])
(with-syntax ([(name ...) names] (with-syntax ([(name ...) names]
@ -752,17 +713,7 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([att (assert-nat 'redex-check #,attempts-stx)] (let ([att (assert-nat 'redex-check #,attempts-stx)]
[ret (assert-nat 'redex-check #,retries-stx)] [ret (assert-nat 'redex-check #,retries-stx)]
[custom (contract [print? #,print?-stx])
(-> any/c natural-number/c any/c any/c hash? natural-number/c
(->* (any/c)
(#:size natural-number/c
#:contractum any/c
#:acc any/c
#:env hash?)
(values any/c hash?))
(-> any/c (values any/c hash?))
(values any/c hash?))
#,custom-stx '+ '-)])
(unsyntax (unsyntax
(if source-stx (if source-stx
#`(let-values ([(metafunc/red-rel num-cases) #`(let-values ([(metafunc/red-rel num-cases)
@ -776,27 +727,32 @@
metafunc/red-rel metafunc/red-rel
property property
random-decisions@ random-decisions@
custom
(max 1 (floor (/ att num-cases))) (max 1 (floor (/ att num-cases)))
ret ret
'redex-check 'redex-check
show (and print? show)
(test-match lang pat) (test-match lang pat)
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
#`(check-prop #`(check-prop
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check) #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
property att show))) property att ret (and print? show)))))))))]))
(void))))))]))
(define (format-attempts a) (define (format-attempts a)
(format "~a attempt~a" a (if (= 1 a) "" "s"))) (format "~a attempt~a" a (if (= 1 a) "" "s")))
(define (check-prop generator property attempts show) (define (check-prop generator property attempts retries show)
(when (check generator property attempts show) (let ([c (check generator property attempts retries show)])
(show (format "no counterexamples in ~a\n" (if (counterexample? c)
(format-attempts attempts))))) (unless show c) ; check printed it
(if show
(show (format "no counterexamples in ~a\n"
(format-attempts attempts)))
#t))))
(define (check generator property attempts show (define-struct (exn:fail:redex:test exn:fail:redex) (source term))
(define-struct counterexample (term) #:transparent)
(define (check generator property attempts retries show
#:source [source #f] #:source [source #f]
#:match [match #f] #:match [match #f]
#:match-fail [match-fail #f]) #:match-fail [match-fail #f])
@ -804,14 +760,21 @@
(if (zero? remaining) (if (zero? remaining)
#t #t
(let ([attempt (add1 (- attempts remaining))]) (let ([attempt (add1 (- attempts remaining))])
(let-values ([(term bindings) (generator (attempt->size attempt) attempt)]) (let-values ([(term bindings) (generator (attempt->size attempt) attempt retries)])
(if (andmap (λ (bindings) (if (andmap (λ (bindings)
(with-handlers (with-handlers
([exn:fail? ([exn:fail?
(λ (exn) (λ (exn)
(show (when show
(format "checking ~s raises an exception\n" term)) (show (format "checking ~s raises an exception\n" term)))
(raise exn))]) (raise
(if show
exn
(make-exn:fail:redex:test
(format "checking ~s raises an exception:\n~a" term (exn-message exn))
(current-continuation-marks)
exn
term))))])
(property term bindings))) (property term bindings)))
(cond [(and match match-fail (match term)) (cond [(and match match-fail (match term))
=> (curry map (compose make-bindings match-bindings))] => (curry map (compose make-bindings match-bindings))]
@ -819,22 +782,22 @@
[else (list bindings)])) [else (list bindings)]))
(loop (sub1 remaining)) (loop (sub1 remaining))
(begin (begin
(show (when show
(format "counterexample found after ~a~a:\n" (show
(format-attempts attempt) (format "counterexample found after ~a~a:\n"
(if source (format " with ~a" source) ""))) (format-attempts attempt)
(pretty-print term (current-output-port)) (if source (format " with ~a" source) "")))
#f))))))) (pretty-print term (current-output-port)))
(make-counterexample term))))))))
(define-syntax (check-metafunction-contract stx) (define-syntax (check-metafunction-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ name . kw-args) [(_ name . kw-args)
(identifier? #'name) (identifier? #'name)
(with-syntax ([m (metafunc/err #'name stx)] (with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom) [(attempts retries)
(parse-kw-args `((#:attempts . ,#'default-check-attempts) (parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries))
(#:custom . ,#'defer-all))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -844,18 +807,19 @@
[decisions@ (generation-decisions)] [decisions@ (generation-decisions)]
[att (assert-nat 'check-metafunction-contract attempts)]) [att (assert-nat 'check-metafunction-contract attempts)])
(check-prop (check-prop
((generate lang decisions@ custom retries 'check-metafunction-contract) ((generate lang decisions@ 'check-metafunction-contract)
(if dom dom '(any (... ...)))) (if dom dom '(any (... ...))))
(λ (t _) (λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)]) (with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t))) (begin (term (name ,@t)) #t)))
att att
retries
show))))])) show))))]))
(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show (define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show
[match #f] [match #f]
[match-fail #f]) [match-fail #f])
(let ([lang-gen (generate lang decisions@ custom retries what)]) (let ([lang-gen (generate lang decisions@ what)])
(let-values ([(pats srcs) (let-values ([(pats srcs)
(cond [(metafunc-proc? mf/rr) (cond [(metafunc-proc? mf/rr)
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr)) (values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
@ -863,47 +827,53 @@
[(reduction-relation? mf/rr) [(reduction-relation? mf/rr)
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr)) (values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
(reduction-relation-srcs mf/rr))])]) (reduction-relation-srcs mf/rr))])])
(when (for/and ([pat pats] [src srcs]) (let loop ([pats pats] [srcs srcs])
(with-handlers ([exn:fail:redex:generation-failure? (if (and (null? pats) (null? srcs))
; Produce an error message that blames the LHS as a whole. (if show
(λ (_) (show
(raise-gen-fail what (format "LHS of ~a" src) retries))]) (format "no counterexamples in ~a (with each clause)\n"
(check (format-attempts attempts)))
(lang-gen pat) #t)
prop (let ([c (with-handlers ([exn:fail:redex:generation-failure?
attempts ; Produce an error message that blames the LHS as a whole.
show (λ (_)
#:source src (raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))])
#:match match (check
#:match-fail match-fail))) (lang-gen (car pats))
(show prop
(format "no counterexamples in ~a (with each clause)\n" attempts
(format-attempts attempts))))))) retries
show
#:source (car srcs)
#:match match
#:match-fail match-fail))])
(if (counterexample? c)
(unless show c)
(loop (cdr pats) (cdr srcs)))))))))
(define-syntax (check-metafunction stx) (define-syntax (check-metafunction stx)
(syntax-case stx () (syntax-case stx ()
[(_ name property . kw-args) [(_ name property . kw-args)
(with-syntax ([m (metafunc/err #'name stx)] (with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom) [(attempts retries print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:custm . ,#'defer-all)) (#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx)] stx)])
[show (show-message stx)]) (with-syntax ([show (show-message stx)])
(syntax/loc stx (syntax/loc stx
(let ([att (assert-nat 'check-metafunction attempts)] (let ([att (assert-nat 'check-metafunction attempts)]
[ret (assert-nat 'check-metafunction retries)]) [ret (assert-nat 'check-metafunction retries)])
(check-lhs-pats (check-lhs-pats
(metafunc-proc-lang m) (metafunc-proc-lang m)
m m
(λ (term _) (property term)) (λ (term _) (property term))
(generation-decisions) (generation-decisions)
custom att
att ret
ret 'check-metafunction
'check-metafunction (and print? show))))))]))
show))))]))
(define (reduction-relation-srcs r) (define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) (map (λ (proc) (or (rewrite-proc-name proc)
@ -917,11 +887,11 @@
(define-syntax (check-reduction-relation stx) (define-syntax (check-reduction-relation stx)
(syntax-case stx () (syntax-case stx ()
[(_ relation property . kw-args) [(_ relation property . kw-args)
(with-syntax ([(attempts retries decisions@ custom) (with-syntax ([(attempts retries decisions@ print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:decisions . ,#'random-decisions@) (#:decisions . ,#'random-decisions@)
(#:custom . ,#'defer-all)) (#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -934,11 +904,10 @@
rel rel
(λ (term _) (property term)) (λ (term _) (property term))
decisions@ decisions@
custom
attempts attempts
retries retries
'check-reduction-relation 'check-reduction-relation
show))))])) (and print? show)))))]))
(define-signature decisions^ (define-signature decisions^
(next-variable-decision (next-variable-decision
@ -949,8 +918,7 @@
next-non-terminal-decision next-non-terminal-decision
next-sequence-decision next-sequence-decision
next-any-decision next-any-decision
next-string-decision next-string-decision))
next-pref-prods-decision))
(define random-decisions@ (define random-decisions@
(unit (import) (export decisions^) (unit (import) (export decisions^)
@ -959,11 +927,10 @@
(define (next-natural-decision) pick-natural) (define (next-natural-decision) pick-natural)
(define (next-integer-decision) pick-integer) (define (next-integer-decision) pick-integer)
(define (next-real-decision) pick-real) (define (next-real-decision) pick-real)
(define (next-non-terminal-decision) pick-nt) (define (next-non-terminal-decision) pick-nts)
(define (next-sequence-decision) pick-sequence-length) (define (next-sequence-decision) pick-sequence-length)
(define (next-any-decision) pick-any) (define (next-any-decision) pick-any)
(define (next-string-decision) pick-string) (define (next-string-decision) pick-string)))
(define (next-pref-prods-decision) pick-preferred-productions)))
(define generation-decisions (make-parameter random-decisions@)) (define generation-decisions (make-parameter random-decisions@))
@ -979,18 +946,17 @@
(struct-out class) (struct-out class)
(struct-out binder) (struct-out binder)
(struct-out base-cases) (struct-out base-cases)
(struct-out pref-prods)) (struct-out counterexample)
(struct-out exn:fail:redex:test))
(provide pick-from-list pick-sequence-length (provide pick-from-list pick-sequence-length pick-nts
pick-char pick-var pick-string pick-char pick-var pick-string pick-any
pick-nt pick-any pick-preferred-productions
pick-number pick-natural pick-integer pick-real pick-number pick-natural pick-integer pick-real
parse-pattern unparse-pattern parse-pattern unparse-pattern
parse-language prepare-lang parse-language prepare-lang
class-reassignments reassign-classes class-reassignments reassign-classes
default-retries proportion-at-size default-retries proportion-at-size
preferred-production-threshold retry-threshold retry-threshold proportion-before-threshold post-threshold-incr
proportion-before-threshold post-threshold-incr
is-nt? nt-by-name min-prods is-nt? nt-by-name min-prods
generation-decisions decisions^ generation-decisions decisions^
random-string random-string

88
collects/redex/redex.scrbl
View File

@ -1127,30 +1127,37 @@ metafunctions or unnamed reduction-relation cases) to application counts.}
(values (covered-cases equals-coverage) (values (covered-cases equals-coverage)
(covered-cases plus-coverage))))] (covered-cases plus-coverage))))]
@defform/subs[(generate-term language @#,ttpattern size-exp kw-args ...) @defform*/subs[[(generate-term language @#,ttpattern size-expr kw-args ...)
([kw-args (code:line #:attempts attempts-expr) (generate-term language @#,ttpattern)]
([kw-args (code:line #:attempt-num attempts-expr)
(code:line #:retries retries-expr)]) (code:line #:retries retries-expr)])
#:contracts ([size-expr natural-number/c] #:contracts ([size-expr natural-number/c]
[attempt-num-expr natural-number/c] [attempt-num-expr natural-number/c]
[retries-expr natural-number/c])]{ [retries-expr natural-number/c])]{
Generates a random term matching @scheme[pattern] (in the given language).
In its first form, @scheme[generate-term] produces a random term matching
the given pattern (according to the given language). In its second,
@scheme[generate-term] produces a procedure for constructing the same.
This procedure expects @scheme[size-expr] (below) as its sole positional
argument and allows the same optional keyword arguments as the first form.
The second form may be more efficient when generating many terms.
The argument @scheme[size-expr] bounds the height of the generated term The argument @scheme[size-expr] bounds the height of the generated term
(measured as the height of the derivation tree used to produce (measured as the height of its parse tree).
the term).
The optional keyword argument @scheme[attempt-num-expr] The optional keyword argument @scheme[attempt-num-expr]
(default @scheme[1]) provides coarse grained control over the random (default @scheme[1]) provides coarse grained control over the random
decisions made during generation. For example, the expected length of decisions made during generation; increasing @scheme[attempt-num-expr]
@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr]. tends to increase the complexity of the result. For example, the expected
length of @pattech[pattern-sequence]s increases with @scheme[attempt-num-expr].
The random generation process does not actively consider the constraints The random generation process does not actively consider the constraints
imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s when imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s; instead,
constructing a term; instead, it tests the satisfaction of it uses a ``guess and check'' strategy in which it freely generates
such constraints after it freely generates the relevant portion of the candidate terms then tests whether they happen to satisfy the constraints,
sub-term---regenerating the sub-term if necessary. The optional keyword repeating as necessary. The optional keyword argument @scheme[retries-expr]
argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times that (default @scheme[100]) bounds the number of times that
@scheme[generate-term] retries the generation of any sub-term. If @scheme[generate-term] retries the generation of any pattern. If
@scheme[generate-term] is unable to produce a satisfying term after @scheme[generate-term] is unable to produce a satisfying term after
@scheme[retries-expr] attempts, it raises an exception recognized by @scheme[retries-expr] attempts, it raises an exception recognized by
@scheme[exn:fail:redex:generation-failure?].} @scheme[exn:fail:redex:generation-failure?].}
@ -1159,11 +1166,13 @@ argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:source metafunction) (code:line #:source metafunction)
(code:line #:source relation-expr) (code:line #:source relation-expr)
(code:line #:retries retries-expr)]) (code:line #:retries retries-expr)
(code:line #:print? print?-expr)])
#:contracts ([property-expr any/c] #:contracts ([property-expr any/c]
[attempts-expr natural-number/c] [attempts-expr natural-number/c]
[relation-expr reduction-relation?] [relation-expr reduction-relation?]
[retries-expr natural-number/c])]{ [retries-expr natural-number/c]
[print?-expr any/c])]{
Searches for a counterexample to @scheme[property-expr], interpreted Searches for a counterexample to @scheme[property-expr], interpreted
as a predicate universally quantified over the pattern variables as a predicate universally quantified over the pattern variables
bound by @scheme[pattern]. @scheme[redex-check] constructs and tests bound by @scheme[pattern]. @scheme[redex-check] constructs and tests
@ -1173,8 +1182,18 @@ using the @scheme[match-bindings] produced by @scheme[match]ing
@math{t} against @scheme[pattern]. @math{t} against @scheme[pattern].
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000]) @scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000])
random terms in its search. The size and complexity of terms it generates random terms in its search. The size and complexity of these terms increase with
gradually increases with each failed attempt. each failed attempt.
When @scheme[print?-expr] produces any non-@scheme[#f] value (the default),
@scheme[redex-check] prints the test outcome on @scheme[current-output-port].
When @scheme[print?-expr] produces @scheme[#f], @scheme[redex-check] prints
nothing, instead
@itemlist[
@item{returning a @scheme[counterexample] structure when the test reveals a counterexample,}
@item{returning @scheme[#t] when all tests pass, or}
@item{raising a @scheme[exn:fail:redex:test] when checking the property raises an exception.}
]
When passed a metafunction or reduction relation via the optional @scheme[#:source] When passed a metafunction or reduction relation via the optional @scheme[#:source]
argument, @scheme[redex-check] distributes its attempts across the left-hand sides argument, @scheme[redex-check] distributes its attempts across the left-hand sides
@ -1221,6 +1240,16 @@ term that does not match @scheme[pattern].}
#:attempts 3 #:attempts 3
#:source R))] #:source R))]
@defstruct[counterexample ([term any/c]) #:inspector #f]{
Produced by @scheme[redex-check], @scheme[check-reduction-relation], and
@scheme[check-metafunction] when testing falsifies a property.}
@defstruct[(exn:fail:redex:test exn:fail:redex) ([source exn:fail?] [term any/c])]{
Raised by @scheme[redex-check], @scheme[check-reduction-relation], and
@scheme[check-metafunction] when testing a property raises an exception.
The @scheme[exn:fail:redex:test-source] component contains the exception raised by the property,
and the @scheme[exn:fail:redex:test-term] component contains the term that induced the exception.}
@defform/subs[(check-reduction-relation relation property kw-args ...) @defform/subs[(check-reduction-relation relation property kw-args ...)
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:retries retries-expr)]) (code:line #:retries retries-expr)])
@ -1865,6 +1894,7 @@ cases appear. If it is a list of numbers, then only the selected cases appear (c
@defparam[metafunction-style style text-style/c]{} @defparam[metafunction-style style text-style/c]{}
@defparam[non-terminal-style style text-style/c]{} @defparam[non-terminal-style style text-style/c]{}
@defparam[non-terminal-subscript-style style text-style/c]{} @defparam[non-terminal-subscript-style style text-style/c]{}
@defparam[non-terminal-superscript-style style text-style/c]{}
@defparam[default-style style text-style/c]{}]]{ @defparam[default-style style text-style/c]{}]]{
These parameters determine the font used for various text in These parameters determine the font used for various text in
@ -1875,15 +1905,27 @@ useful things it can be is one of the symbols @scheme['roman],
monospaced font, respectively. (It can also encode style monospaced font, respectively. (It can also encode style
information, too.) information, too.)
The label-style is used for the reduction rule label The @scheme[label-style] is used for the reduction rule label
names. The literal-style is used for names that aren't names. The @scheme[literal-style] is used for names that aren't
non-terminals that appear in patterns. The non-terminals that appear in patterns. The
metafunction-style is used for the names of @scheme[metafunction-style] is used for the names of
metafunctions. The non-terminal-style is for non-terminals metafunctions.
and non-terminal-subscript-style is used for the portion
The @scheme[non-terminal-style] is used for the names of non-terminals.
Two parameters style the text in the (optional) "underscore" component
of a non-terminal reference. The first, @scheme[non-terminal-subscript-style],
applies to the segment between the underscore and the first caret (@scheme[^])
to follow it; the second, @scheme[non-terminal-superscript-style], applies
to the segment following that caret. For example, in the non-terminal
reference @scheme[x_y_z], @scheme[x] has style @scheme[non-terminal-style],
@scheme[y] has style @scheme[non-terminal-subscript-style], and @scheme[z]
has style @scheme[non-terminal-superscript-style].
The
@scheme[non-terminal-subscript-style] is used for the portion
after the underscore in non-terminal references. after the underscore in non-terminal references.
The default-style is used for parenthesis, the dot in dotted The @scheme[default-style] is used for parenthesis, the dot in dotted
lists, spaces, the separator words in the grammar, the lists, spaces, the separator words in the grammar, the
"where" and "fresh" in side-conditions, and other places "where" and "fresh" in side-conditions, and other places
where the other parameters aren't used. where the other parameters aren't used.

4
collects/redex/reduction-semantics.ss
View File

@ -50,7 +50,9 @@
check-metafunction check-metafunction
check-metafunction-contract check-metafunction-contract
check-reduction-relation check-reduction-relation
exn:fail:redex:generation-failure?) exn:fail:redex:generation-failure?
(struct-out exn:fail:redex:test)
(struct-out counterexample))
(provide/contract (provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]

42
collects/redex/private/bitmap-test-util.ss → collects/redex/tests/bitmap-test-util.ss
View File

@ -20,16 +20,15 @@
[(_ test-exp bitmap-filename) [(_ test-exp bitmap-filename)
#`(test/proc #`(test/proc
#,(syntax-line stx) #,(syntax-line stx)
test-exp (λ () test-exp)
bitmap-filename)])) bitmap-filename)]))
(define (test/proc line-number pict raw-bitmap-filename) (define (test/proc line-number pict-thunk raw-bitmap-filename)
(set! tests (+ tests 1)) (set! tests (+ tests 1))
(let* ([bitmap-filename (let* ([pict (set-fonts/call pict-thunk)]
[bitmap-filename
(build-path (format "bmps-~a" (system-type)) (build-path (format "bmps-~a" (system-type))
(case (system-type) raw-bitmap-filename)]
[(unix) (string-append "unix-" raw-bitmap-filename)]
[else raw-bitmap-filename]))]
[old-bitmap (if (file-exists? bitmap-filename) [old-bitmap (if (file-exists? bitmap-filename)
(make-object bitmap% bitmap-filename) (make-object bitmap% bitmap-filename)
(let* ([bm (make-object bitmap% 100 20)] (let* ([bm (make-object bitmap% 100 20)]
@ -39,8 +38,8 @@
(send bdc set-bitmap #f) (send bdc set-bitmap #f)
bm))] bm))]
[new-bitmap (make-object bitmap% [new-bitmap (make-object bitmap%
(inexact->exact (pict-width pict)) (ceiling (inexact->exact (pict-width pict)))
(inexact->exact (pict-height pict)))] (ceiling (inexact->exact (pict-height pict))))]
[bdc (make-object bitmap-dc% new-bitmap)]) [bdc (make-object bitmap-dc% new-bitmap)])
(send bdc clear) (send bdc clear)
(draw-pict pict bdc 0 0) (draw-pict pict bdc 0 0)
@ -50,6 +49,33 @@
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)]) (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
(set! failed (append failed (list failed-panel)))))))) (set! failed (append failed (list failed-panel))))))))
(define (set-fonts/call thunk)
(case (system-type)
[(unix)
(let ([rewrite-style
(λ (s)
(let loop ([s s])
(cond
[(pair? s) (cons (loop (car s)) (loop (cdr s)))]
[(eq? s 'roman) (verify-face " DejaVu Serif")]
[(eq? s 'swiss) (verify-face " DejaVu Sans")]
[else s])))])
(parameterize ([label-style (rewrite-style (label-style))]
[literal-style (rewrite-style (literal-style))]
[metafunction-style (rewrite-style (metafunction-style))]
[non-terminal-style (rewrite-style (non-terminal-style))]
[non-terminal-subscript-style (rewrite-style (non-terminal-subscript-style))]
[non-terminal-superscript-style (rewrite-style (non-terminal-superscript-style))]
[default-style (rewrite-style (default-style))])
(thunk)))]
[else
(thunk)]))
(define (verify-face face)
(unless (member face (get-face-list))
(error 'verify-face "unknown face: ~s" face))
face)
(define (compute-diffs old-bitmap new-bitmap) (define (compute-diffs old-bitmap new-bitmap)
(let* ([w (max (send old-bitmap get-width) (let* ([w (max (send old-bitmap get-width)
(send new-bitmap get-width))] (send new-bitmap get-width))]

4
collects/redex/private/bitmap-test.ss → collects/redex/tests/bitmap-test.ss
View File

@ -159,5 +159,9 @@
;; make sure two metafunctions simultaneously rewritten line up properly ;; make sure two metafunctions simultaneously rewritten line up properly
(test (render-metafunctions S T TL) "metafunctions-multiple.png") (test (render-metafunctions S T TL) "metafunctions-multiple.png")
;; Non-terminal superscripts
(test (render-lw lang (to-lw (x_^abcdef x_q^abcdef)))
"superscripts.png")
(printf "bitmap-test.ss: ") (printf "bitmap-test.ss: ")
(done) (done)

0
collects/redex/private/bmps-macosx/extended-language.png → collects/redex/tests/bmps-macosx/extended-language.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.9 KiB

After

Width:  |  Height:  |  Size: 1.9 KiB

0
collects/redex/private/bmps-macosx/extended-reduction-relation.png → collects/redex/tests/bmps-macosx/extended-reduction-relation.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 394 B

After

Width:  |  Height:  |  Size: 394 B

0
collects/redex/private/bmps-macosx/language-nox.png → collects/redex/tests/bmps-macosx/language-nox.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 2.9 KiB

After

Width:  |  Height:  |  Size: 2.9 KiB

0
collects/redex/private/bmps-macosx/language.png → collects/redex/tests/bmps-macosx/language.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.9 KiB

After

Width:  |  Height:  |  Size: 5.9 KiB

0
collects/redex/private/bmps-macosx/lw.png → collects/redex/tests/bmps-macosx/lw.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.2 KiB

After

Width:  |  Height:  |  Size: 1.2 KiB

0
collects/redex/private/bmps-macosx/metafunction-Name-vertical.png → collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.7 KiB

After

Width:  |  Height:  |  Size: 4.7 KiB

0
collects/redex/private/bmps-macosx/metafunction-Name.png → collects/redex/tests/bmps-macosx/metafunction-Name.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.3 KiB

After

Width:  |  Height:  |  Size: 4.3 KiB

0
collects/redex/private/bmps-macosx/metafunction-T.png → collects/redex/tests/bmps-macosx/metafunction-T.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.6 KiB

After

Width:  |  Height:  |  Size: 4.6 KiB

0
collects/redex/private/bmps-macosx/metafunction-TL.png → collects/redex/tests/bmps-macosx/metafunction-TL.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.6 KiB

After

Width:  |  Height:  |  Size: 4.6 KiB

0
collects/redex/private/bmps-macosx/metafunction-multi-arg.png → collects/redex/tests/bmps-macosx/metafunction-multi-arg.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 8.3 KiB

After

Width:  |  Height:  |  Size: 8.3 KiB

0
collects/redex/private/bmps-macosx/metafunction-subst.png → collects/redex/tests/bmps-macosx/metafunction-subst.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.3 KiB

After

Width:  |  Height:  |  Size: 4.3 KiB

0
collects/redex/private/bmps-macosx/metafunction.png → collects/redex/tests/bmps-macosx/metafunction.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

0
collects/redex/private/bmps-macosx/metafunctions-multiple.png → collects/redex/tests/bmps-macosx/metafunctions-multiple.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 9.1 KiB

After

Width:  |  Height:  |  Size: 9.1 KiB

0
collects/redex/private/bmps-macosx/red2.png → collects/redex/tests/bmps-macosx/red2.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.1 KiB

After

Width:  |  Height:  |  Size: 5.1 KiB

0
collects/redex/private/bmps-macosx/reduction-relation.png → collects/redex/tests/bmps-macosx/reduction-relation.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.8 KiB

After

Width:  |  Height:  |  Size: 1.8 KiB

BIN
collects/redex/tests/bmps-macosx/superscripts.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 944 B

0
collects/redex/private/bmps-macosx/unix-extended-language.png → collects/redex/tests/bmps-macosx/unix-extended-language.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 2.1 KiB

After

Width:  |  Height:  |  Size: 2.1 KiB

0
collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png → collects/redex/tests/bmps-macosx/unix-extended-reduction-relation.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 507 B

After

Width:  |  Height:  |  Size: 507 B

0
collects/redex/private/bmps-macosx/unix-language-nox.png → collects/redex/tests/bmps-macosx/unix-language-nox.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.1 KiB

After

Width:  |  Height:  |  Size: 3.1 KiB

0
collects/redex/private/bmps-macosx/unix-language.png → collects/redex/tests/bmps-macosx/unix-language.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.5 KiB

After

Width:  |  Height:  |  Size: 5.5 KiB

0
collects/redex/private/bmps-macosx/unix-lw.png → collects/redex/tests/bmps-macosx/unix-lw.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.2 KiB

After

Width:  |  Height:  |  Size: 1.2 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png → collects/redex/tests/bmps-macosx/unix-metafunction-Name-vertical.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.4 KiB

After

Width:  |  Height:  |  Size: 4.4 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-Name.png → collects/redex/tests/bmps-macosx/unix-metafunction-Name.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.7 KiB

After

Width:  |  Height:  |  Size: 3.7 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-T.png → collects/redex/tests/bmps-macosx/unix-metafunction-T.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.9 KiB

After

Width:  |  Height:  |  Size: 3.9 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-TL.png → collects/redex/tests/bmps-macosx/unix-metafunction-TL.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.4 KiB

After

Width:  |  Height:  |  Size: 4.4 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png → collects/redex/tests/bmps-macosx/unix-metafunction-multi-arg.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 7.0 KiB

After

Width:  |  Height:  |  Size: 7.0 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction-subst.png → collects/redex/tests/bmps-macosx/unix-metafunction-subst.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

0
collects/redex/private/bmps-macosx/unix-metafunction.png → collects/redex/tests/bmps-macosx/unix-metafunction.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

0
collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png → collects/redex/tests/bmps-macosx/unix-metafunctions-multiple.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 10 KiB

After

Width:  |  Height:  |  Size: 10 KiB

0
collects/redex/private/bmps-macosx/unix-reduction-relation.png → collects/redex/tests/bmps-macosx/unix-reduction-relation.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.9 KiB

After

Width:  |  Height:  |  Size: 1.9 KiB

BIN
collects/redex/tests/bmps-unix/extended-language.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.5 KiB

BIN
collects/redex/tests/bmps-unix/extended-reduction-relation.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 551 B

BIN
collects/redex/tests/bmps-unix/language-nox.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

BIN
collects/redex/tests/bmps-unix/language.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.7 KiB

BIN
collects/redex/tests/bmps-unix/lw.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.4 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-Name-vertical.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.0 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-Name.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.6 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-T.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.7 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-TL.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.8 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-multi-arg.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 7.5 KiB

BIN
collects/redex/tests/bmps-unix/metafunction-subst.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.4 KiB

BIN
collects/redex/tests/bmps-unix/metafunction.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.2 KiB

BIN
collects/redex/tests/bmps-unix/metafunctions-multiple.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 13 KiB

BIN
collects/redex/tests/bmps-unix/red2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.8 KiB

BIN
collects/redex/tests/bmps-unix/reduction-relation.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.2 KiB

BIN
collects/redex/tests/bmps-unix/superscripts.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.2 KiB

0
collects/redex/private/color-test.ss → collects/redex/tests/color-test.ss
View File

0
collects/redex/private/config.ss → collects/redex/tests/config.ss
View File

4
collects/redex/private/core-layout-test.ss → collects/redex/tests/core-layout-test.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require "core-layout.ss" (require "../private/core-layout.ss"
"loc-wrapper.ss" "../private/loc-wrapper.ss"
"lw-test-util.ss" "lw-test-util.ss"
"test-util.ss" "test-util.ss"
(lib "struct.ss")) (lib "struct.ss"))

0
collects/redex/private/hole-test.ss → collects/redex/tests/hole-test.ss
View File

2
collects/redex/private/keyword-macros-test.ss → collects/redex/tests/keyword-macros-test.ss
View File

@ -1,6 +1,6 @@
#lang scheme #lang scheme
(require "keyword-macros.ss" (require "../private/keyword-macros.ss"
"test-util.ss") "test-util.ss")
(reset-count) (reset-count)

2
collects/redex/private/lw-test-util.ss → collects/redex/tests/lw-test-util.ss
View File

@ -1,5 +1,5 @@
(module lw-test-util mzscheme (module lw-test-util mzscheme
(require "loc-wrapper.ss") (require "../private/loc-wrapper.ss")
(provide normalize-lw) (provide normalize-lw)
(define (normalize-lw lw) (define (normalize-lw lw)

2
collects/redex/private/lw-test.ss → collects/redex/tests/lw-test.ss
View File

@ -51,7 +51,7 @@
(module lw-test mzscheme (module lw-test mzscheme
(require "test-util.ss" (require "test-util.ss"
"loc-wrapper.ss" "../private/loc-wrapper.ss"
"lw-test-util.ss") "lw-test-util.ss")
(reset-count) (reset-count)

2
collects/redex/private/matcher-test.ss → collects/redex/tests/matcher-test.ss
View File

@ -1,5 +1,5 @@
(module matcher-test mzscheme (module matcher-test mzscheme
(require "matcher.ss" (require "../private/matcher.ss"
(only "test-util.ss" equal/bindings?) (only "test-util.ss" equal/bindings?)
(lib "list.ss")) (lib "list.ss"))

0
collects/redex/private/pict-test.ss → collects/redex/tests/pict-test.ss
View File

267
collects/redex/private/rg-test.ss → collects/redex/tests/rg-test.ss
View File

@ -1,12 +1,15 @@
#lang scheme #lang scheme
(require "test-util.ss" (require "test-util.ss"
"reduction-semantics.ss" "../private/reduction-semantics.ss"
"matcher.ss" "../private/matcher.ss"
"term.ss" "../private/term.ss"
"rg.ss" "../private/rg.ss"
"keyword-macros.ss" "../private/keyword-macros.ss"
"error.ss") "../private/error.ss")
(define-namespace-anchor nsa)
(define ns (namespace-anchor->namespace nsa))
(reset-count) (reset-count)
@ -111,23 +114,6 @@
(test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc") (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc")
(test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc)) (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc))
(let ()
(define-language L
(a 5 (x a))
(b 4))
(test (pick-nt 'a #f L 1 'dontcare)
(nt-rhs (car (compiled-lang-lang L))))
(test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1))
(nt-rhs (car (compiled-lang-lang L))))
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
(test (pick-nt 'a #f L preferred-production-threshold
(make-pref-prods 'dont-care
(make-immutable-hash `((a ,pref))))
(make-random 0))
(list pref)))
(test (pick-nt 'b #f L preferred-production-threshold #f)
(nt-rhs (cadr (compiled-lang-lang L)))))
(define-syntax raised-exn-msg (define-syntax raised-exn-msg
(syntax-rules () (syntax-rules ()
[(_ expr) (raised-exn-msg exn:fail? expr)] [(_ expr) (raised-exn-msg exn:fail? expr)]
@ -141,7 +127,7 @@
(define (patterns . selectors) (define (patterns . selectors)
(map (λ (selector) (map (λ (selector)
(λ (name cross? lang size pref-prods) (λ (name cross? lang sizes)
(list (selector (nt-rhs (nt-by-name lang name cross?)))))) (list (selector (nt-rhs (nt-by-name lang name cross?))))))
selectors)) selectors))
@ -158,15 +144,14 @@
(test (raised-exn-msg (iter)) #rx"empty")) (test (raised-exn-msg (iter)) #rx"empty"))
(define (decisions #:var [var pick-var] (define (decisions #:var [var pick-var]
#:nt [nt pick-nt] #:nt [nt pick-nts]
#:str [str pick-string] #:str [str pick-string]
#:num [num pick-number] #:num [num pick-number]
#:nat [nat pick-natural] #:nat [nat pick-natural]
#:int [int pick-integer] #:int [int pick-integer]
#:real [real pick-real] #:real [real pick-real]
#:any [any pick-any] #:any [any pick-any]
#:seq [seq pick-sequence-length] #:seq [seq pick-sequence-length])
#:pref [pref pick-preferred-productions])
(define-syntax decision (define-syntax decision
(syntax-rules () (syntax-rules ()
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
@ -179,14 +164,13 @@
(define next-real-decision (decision real)) (define next-real-decision (decision real))
(define next-string-decision (decision str)) (define next-string-decision (decision str))
(define next-any-decision (decision any)) (define next-any-decision (decision any))
(define next-sequence-decision (decision seq)) (define next-sequence-decision (decision seq))))
(define next-pref-prods-decision (decision pref))))
(define-syntax generate-term/decisions (define-syntax generate-term/decisions
(syntax-rules () (syntax-rules ()
[(_ lang pat size attempt decisions) [(_ lang pat size attempt decisions)
(parameterize ([generation-decisions decisions]) (parameterize ([generation-decisions decisions])
(generate-term lang pat size #:attempt attempt))])) (generate-term lang pat size #:attempt-num attempt))]))
(let () (let ()
(define-language lc (define-language lc
@ -216,6 +200,17 @@
#:var (list (λ _ 'x) (λ _ 'y)))) #:var (list (λ _ 'x) (λ _ 'y))))
'(x y))) '(x y)))
(let ()
(define-language L
(n 1))
(test ((generate-term L n) 0) 1)
(test ((generate-term L n) 0 #:retries 0) 1)
(test ((generate-term L n) 0 #:attempt-num 0) 1)
(test (with-handlers ([exn:fail:syntax? exn-message])
(parameterize ([current-namespace ns])
(expand #'(generate-term M n))))
#rx"generate-term: expected a identifier defined by define-language( in: M)?$"))
;; variable-except pattern ;; variable-except pattern
(let () (let ()
(define-language var (define-language var
@ -231,17 +226,17 @@
(n natural) (n natural)
(i integer) (i integer)
(r real)) (r real))
(test (let ([n (generate-term L n 0 #:attempt 10000)]) (test (let ([n (generate-term L n 0 #:attempt-num 10000)])
(and (integer? n) (and (integer? n)
(exact? n) (exact? n)
(not (negative? n)))) (not (negative? n))))
#t) #t)
(test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42) (test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42)
(test (let ([i (generate-term L i 0 #:attempt 10000)]) (test (let ([i (generate-term L i 0 #:attempt-num 10000)])
(and (integer? i) (exact? i))) (and (integer? i) (exact? i)))
#t) #t)
(test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42) (test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42)
(test (real? (generate-term L r 0 #:attempt 10000)) #t) (test (real? (generate-term L r 0 #:attempt-num 10000)) #t)
(test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2)) (test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2))
(let () (let ()
@ -539,77 +534,23 @@
(get-output-string p) (get-output-string p)
(close-output-port p)))) (close-output-port p))))
;; preferred productions
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
(define-language L
(e (+ e e) (* e e) 7))
(define-language M (e 0) (e-e 1))
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))])
(test
(generate-term/decisions
L e 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L))))))))
#:nt (make-pick-nt (make-random 0 0 0))))
'(+ (+ 7 7) (+ 7 7)))
(test
(generate-term/decisions
L any 2 preferred-production-threshold
(decisions #:nt (patterns first)
#:var (list (λ _ 'x))
#:any (list (λ (lang sexp) (values sexp 'sexp)))))
'x)
(test
(generate-term/decisions
L any 2 preferred-production-threshold
(decisions #:pref (list (λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L))))))))
#:nt (make-pick-nt (make-random 0 0 0))
#:any (list (λ (lang sexp) (values lang 'e)))))
'(+ (+ 7 7) (+ 7 7)))
(test
(generate-term/decisions
M (cross e) 2 preferred-production-threshold
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
(term hole))
(test
(generate-term/decisions
M e-e 2 preferred-production-threshold
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
1)
(test
(let ([generated null])
(output
(λ ()
(check-reduction-relation
(reduction-relation L (--> e e))
(λ (t) (set! generated (cons t generated)))
#:decisions (decisions #:nt (make-pick-nt (make-random)
(λ (att rand) #t))
#:pref (list (λ (_) 'dontcare)
(λ (_) 'dontcare)
(λ (_) 'dontcare)
; size 0 terms prior to this attempt
(λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(car (pats L)))))))
(λ (L) (make-pref-prods
'dont-care
(make-immutable-hash `((e ,(cadr (pats L)))))))))
#:attempts 5)))
generated)
'((* 7 7) (+ 7 7) 7 7 7))))
;; redex-check ;; redex-check
(let () (let ()
(define-language lang (define-language lang
(d 5) (d 5)
(e e 4) (e e 4)
(n number)) (n number))
(test (redex-check lang d #t #:attempts 1 #:print? (not #t)) #t)
(test (redex-check lang d #f #:print? #f)
(make-counterexample 5))
(let ([exn (with-handlers ([exn:fail:redex:test? values])
(redex-check lang d (error 'boom ":(") #:print? #f)
'not-an-exn)])
(test (exn-message exn) "checking 5 raises an exception:\nboom: :(")
(test (exn-message (exn:fail:redex:test-source exn)) "boom: :(")
(test (exn:fail:redex:test-term exn) 5))
(test (output (λ () (redex-check lang d #f))) (test (output (λ () (redex-check lang d #f)))
#rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n") #rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n")
(test (output (λ () (redex-check lang d #t))) (test (output (λ () (redex-check lang d #t)))
@ -644,17 +585,28 @@
(--> 0 dontcare z))))) (--> 0 dontcare z)))))
#rx"counterexample found after 1 attempt with z:\n0\n") #rx"counterexample found after 1 attempt with z:\n0\n")
(let ([generated null]) (let ([generated null]
[R (reduction-relation
lang
(--> 1 dontcare)
(--> 2 dontcare))])
(test (output (test (output
(λ () (λ ()
(redex-check lang n (set! generated (cons (term n) generated)) (redex-check lang n (set! generated (cons (term n) generated))
#:attempts 5 #:attempts 5
#:source (reduction-relation #:source R)))
lang
(--> 1 dontcare)
(--> 2 dontcare)))))
#rx"no counterexamples.*with each clause") #rx"no counterexamples.*with each clause")
(test generated '(2 2 1 1))) (test generated '(2 2 1 1))
(test (redex-check lang any #t
#:attempts 1
#:source R
#:print? (not #t))
#t)
(test (redex-check lang any (= (term any) 1)
#:source R
#:print? #f)
(make-counterexample 2)))
(let () (let ()
(define-metafunction lang (define-metafunction lang
@ -665,7 +617,16 @@
(redex-check lang (n) (eq? 42 (term n)) (redex-check lang (n) (eq? 42 (term n))
#:attempts 1 #:attempts 1
#:source mf))) #:source mf)))
#px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")) #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")
(test (redex-check lang any #t
#:attempts 1
#:source mf
#:print? (not #t))
#t)
(test (redex-check lang any (= (car (term any)) 42)
#:source mf
#:print? #f)
(make-counterexample '(0))))
(let () (let ()
(define-metafunction lang (define-metafunction lang
@ -790,6 +751,14 @@
(E* hole E*) (E* hole E*)
(n 4)) (n 4))
(let ([R (reduction-relation
L
(--> 1 2)
(--> 2 3))])
(test (check-reduction-relation R (λ (_) #t) #:print? #f) #t)
(test (counterexample-term (check-reduction-relation R (curry = 1) #:print? #f))
2))
(let ([generated null] (let ([generated null]
[R (reduction-relation [R (reduction-relation
L L
@ -857,6 +826,11 @@
(define-metafunction empty (define-metafunction empty
[(n (side-condition any #f)) any]) [(n (side-condition any #f)) any])
(test (check-metafunction m (λ (_) #t) #:print? #f) #t)
(test (counterexample-term
(check-metafunction m (compose (curry = 1) car) #:print? #f))
'(2))
(let ([generated null]) (let ([generated null])
(test (begin (test (begin
(output (output
@ -890,89 +864,6 @@
(check-metafunction n (λ (_) #t) #:retries 42)) (check-metafunction n (λ (_) #t) #:retries 42))
#rx"check-metafunction: unable .* in 42")) #rx"check-metafunction: unable .* in 42"))
;; custom generators
(let ()
(define-language L
(x variable))
(test
(generate-term
L x_1 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (values 'x env)]
[_ (def acc)])))
'x)
(test
(let/ec k
(equal?
(generate-term
L (x x) 0
#:custom (let ([once? #f])
(λ (pat sz i-h acc env att rec def)
(match pat
['x (if once?
(k #f)
(begin
(set! once? #t)
(values 'x env)))]
[_ (def acc)]))))
'(x x)))
#t)
(test
(hash-ref
(let/ec k
(generate-term
L (x (x)) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[(struct binder ('x))
(values 'y (hash-set env pat 'y))]
[(list (struct binder ('x))) (k env)]
[_ (def acc)]))))
(make-binder 'x))
'y)
(test
(generate-term
L (in-hole hole 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[`(in-hole hole 7)
(rec 'hole #:contractum 7)]
[_ (def acc)])))
7)
(test
(let/ec k
(generate-term
L any 10
#:attempt 42
#:custom (λ (pat sz i-h acc env att rec def) (k (list sz att)))))
'(10 42))
(test
(let/ec k
(generate-term
L x 10
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (rec 7 #:size 0)]
[7 (k sz)]
[_ (def att)]))))
0)
(test
(generate-term
L (q 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['q (rec '(7 7) #:acc 8)]
[7 (values (or acc 7) env)]
[_ (def att)])))
'((8 8) 7)))
;; parse/unparse-pattern ;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
(define-language lang (x variable)) (define-language lang (x variable))

2
collects/redex/private/run-tests.ss → collects/redex/tests/run-tests.ss
View File

@ -5,7 +5,7 @@
"config.ss" "config.ss"
"test-util.ss") "test-util.ss")
(set-show-bitmaps? #t) (set-show-bitmaps? #f)
(define test-files (define test-files
'("lw-test.ss" '("lw-test.ss"

4
collects/redex/private/term-test.ss → collects/redex/tests/term-test.ss
View File

@ -1,6 +1,6 @@
(module term-test scheme (module term-test scheme
(require "term.ss" (require "../private/term.ss"
"matcher.ss" "../private/matcher.ss"
"test-util.ss") "test-util.ss")
(reset-count) (reset-count)

2
collects/redex/private/test-util.ss → collects/redex/tests/test-util.ss
View File

@ -1,6 +1,6 @@
#lang scheme #lang scheme
(require "matcher.ss" (require "../private/matcher.ss"
errortrace/errortrace-lib errortrace/errortrace-lib
errortrace/errortrace-key) errortrace/errortrace-key)
(provide test test-syn-err tests reset-count (provide test test-syn-err tests reset-count

4
collects/redex/private/tl-test.ss → collects/redex/tests/tl-test.ss
View File

@ -1,9 +1,9 @@
(module tl-test scheme (module tl-test scheme
(require "../reduction-semantics.ss" (require "../reduction-semantics.ss"
"test-util.ss" "test-util.ss"
(only-in "matcher.ss" make-bindings make-bind) (only-in "../private/matcher.ss" make-bindings make-bind)
scheme/match scheme/match
"struct.ss") "../private/struct.ss")
(reset-count) (reset-count)

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "23jan2010") #lang scheme/base (provide stamp) (define stamp "29jan2010")

19
collects/scheme/sandbox.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/port (require scheme/port
scheme/path
scheme/list scheme/list
scheme/string scheme/string
syntax/moddep syntax/moddep
@ -444,7 +445,7 @@
(cond [(and p (null? (cdr inps))) (cond [(and p (null? (cdr inps)))
(port-count-lines! p) (port-count-lines! p)
(parameterize ([current-input-port p]) (parameterize ([current-input-port p])
(begin0 ((sandbox-reader) source) (begin0 ((sandbox-reader) (or (object-name p) source))
;; close a port if we opened it ;; close a port if we opened it
(unless (eq? p (car inps)) (close-input-port p))))] (unless (eq? p (car inps)) (close-input-port p))))]
[p (error 'input->code "ambiguous inputs: ~e" inps)] [p (error 'input->code "ambiguous inputs: ~e" inps)]
@ -550,11 +551,17 @@
(module->namespace `(quote ,(syntax-e mod)))))] (module->namespace `(quote ,(syntax-e mod)))))]
[_else #f])]) [_else #f])])
;; the actual evaluation happens under the specified limits ;; the actual evaluation happens under the specified limits
((limit-thunk (lambda () (parameterize ([current-load-relative-directory
(if (and (pair? program) (eq? 'begin (car program))) (let* ([d (and (syntax? program) (syntax-source program))]
(eval* (cdr program)) [d (and (path-string? d) (path-only d))])
(eval program)) (if (and d (directory-exists? d))
(when ns (set! ns (ns)))))) d
(current-load-relative-directory)))])
((limit-thunk (lambda ()
(if (and (pair? program) (eq? 'begin (car program)))
(eval* (cdr program))
(eval program))
(when ns (set! ns (ns)))))))
(when uncovered! (when uncovered!
(let ([get (let ([ns (current-namespace)]) (let ([get (let ([ns (current-namespace)])
(lambda () (eval '(get-uncovered-expressions) ns)))]) (lambda () (eval '(get-uncovered-expressions) ns)))])

1
collects/scribble/tools/drscheme-buttons.ss
View File

@ -40,7 +40,6 @@
(dynamic-require 'scribble/run #f) (dynamic-require 'scribble/run #f)
(cond (cond
[(equal? label "HTML") [(equal? label "HTML")
(system (format "firefox ~a" (path-replace-suffix name suffix)))
(send-url/file (path-replace-suffix fn suffix))] (send-url/file (path-replace-suffix fn suffix))]
[else (system (format "open ~a" (path-replace-suffix name suffix)))])) [else (system (format "open ~a" (path-replace-suffix name suffix)))]))
(message-box "Scribble" (get-output-string p) drs-frame)) (message-box "Scribble" (get-output-string p) drs-frame))

2
collects/scribblings/gui/blurbs.ss
View File

@ -203,7 +203,7 @@ information@|details|, even if the editor currently has delayed refreshing (see
monitor @|whatsit| changes.}) monitor @|whatsit| changes.})
(define (MonitorCallbackX a b c d) (define (MonitorCallbackX a b c d)
(MonitorMethod a b @elem{the @|d|callback procedure (provided as an initialization argument)} c)) (MonitorMethod a b @elem{the @|d| callback procedure (provided as an initialization argument)} c))
(define (MonitorCallback a b c) (define (MonitorCallback a b c)
(MonitorCallbackX a b c "control")) (MonitorCallbackX a b c "control"))

2
collects/scribblings/gui/editor-overview.scrbl
View File

@ -530,7 +530,7 @@ When an editor is loaded and a header/footer record is encountered,
be loaded. be loaded.
See also @method[editor<%> write-headers-to-file] and See also @method[editor<%> write-headers-to-file] and
@method[editor<%> write-headers-to-file]. @method[editor<%> read-header-from-file].
@section[#:tag "editoreol"]{End of Line Ambiguity} @section[#:tag "editoreol"]{End of Line Ambiguity}

18
collects/scribblings/gui/radio-box-class.scrbl
View File

@ -28,7 +28,7 @@ Whenever the user changes the selected radio button, the radio box's
'vertical-label 'horizontal-label 'vertical-label 'horizontal-label
'deleted)) 'deleted))
'(vertical)] '(vertical)]
[selection exact-nonnegative-integer? 0] [selection (or/c exact-nonnegative-integer? #f) 0]
[font (is-a?/c font%) normal-control-font] [font (is-a?/c font%) normal-control-font]
[enabled any/c #t] [enabled any/c #t]
[vert-margin (integer-in 0 1000) 2] [vert-margin (integer-in 0 1000) 2]
@ -64,8 +64,9 @@ The @scheme[style] argument must include either @scheme['vertical] for a
@HVLabelNote[@scheme[style]]{radio box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{radio box} @HVLabelNote[@scheme[style]]{radio box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{radio box}
By default, the first radio button is initially selected. If By default, the first radio button is initially selected. If
@scheme[selection] is positive, it is passed to @method[radio-box% @scheme[selection] is positive or @scheme[#f], it is passed to
set-selection] to set the initial radio button selection. @method[radio-box% set-selection] to set the initial radio button
selection.
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] @FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
@ -115,10 +116,10 @@ Returns the number of radio buttons in the radio box.
} }
@defmethod[(get-selection) @defmethod[(get-selection)
exact-nonnegative-integer?]{ (or/c exact-nonnegative-integer? #f)]{
Gets the position of the selected radio button. Radio buttons are Gets the position of the selected radio button, returning @scheme[#f]
numbered from @scheme[0]. if no button is selected. Radio buttons are numbered from @scheme[0].
} }
@ -139,10 +140,11 @@ box, @|MismatchExn|.
} }
@defmethod[(set-selection [n exact-nonnegative-integer?]) @defmethod[(set-selection [n (or/c exact-nonnegative-integer? #f)])
void?]{ void?]{
Sets the selected radio button by position. (The control's callback Sets the selected radio button by position, or deselects all radio
buttons if @scheme[n] is @scheme[#f]. (The control's callback
procedure is @italic{not} invoked.) Radio buttons are numbered from procedure is @italic{not} invoked.) Radio buttons are numbered from
@scheme[0]. If @scheme[n] is equal to or larger than the number of @scheme[0]. If @scheme[n] is equal to or larger than the number of
radio buttons in the radio box, @|MismatchExn|. radio buttons in the radio box, @|MismatchExn|.

3
collects/scribblings/places/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define scribblings '(("places.scrbl" ())))

Some files were not shown because too many files have changed in this diff Show More