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

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

@ -49,7 +49,7 @@
[(define/chk (fn-name args ... . final-arg) body ...)
(identifier? #'final-arg)
(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)
(let ([args (check/normalize 'fn-name 'args args i)] ...
[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-polygon
make-point
make-crop )
make-crop
crop?
normalized-shape?)
(only-in "../private/image-more.ss"
bring-between
swizzle)
@ -1319,6 +1321,37 @@
2 7
(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>")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 gc-var-stack-mode
(ormap (lambda (e)
(cond
[(and (pragma? e)
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
'table]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
'thread-local]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
'getspecific]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION))
'function]
[else #f]))
e-raw))
(let loop ([e-raw e-raw])
(ormap (lambda (e)
(cond
[(and (pragma? e)
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
'table]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
'thread-local]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
'getspecific]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION))
'function]
[(braces? e) (loop (seq->list (seq-in e)))]
[else #f]))
e-raw)))
;; The code produced by xform uses a number of macros. These macros
;; 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
(λ (evt)
(let ([ch (send evt get-key-code)])
(when (and (eq? ch #\q)
(send evt get-control-down))
(exit))
(when (char? ch)
;; as soon as something is typed, load the bitmaps
(load-magic-images)

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

@ -79,10 +79,11 @@
;show-syntax-error-context
))
(define-signature drscheme:module-langauge-cm^
(define-signature drscheme:module-language-cm^
(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
module-language-name
module-language-put-file-mixin))
(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
;; a file on the disk and installs it.
(define (install-plt-file parent)
(define pref (preferences:get 'drscheme:install-plt-dialog))
(define dialog
(instantiate dialog% ()
(parent parent)
(alignment '(left center))
(label (string-constant install-plt-file-dialog-title))))
(new dialog% [parent parent]
[label (string-constant install-plt-file-dialog-title)]
[alignment '(left center)]))
(define tab-panel
(instantiate tab-panel% ()
(parent dialog)
(callback (λ (x y) (update-panels)))
(choices (list (string-constant install-plt-web-tab)
(string-constant install-plt-file-tab)))))
(define outer-swapping-panel (instantiate horizontal-panel% ()
(parent tab-panel)
(stretchable-height #f)))
(define spacing-panel (instantiate horizontal-panel% ()
(stretchable-width #f)
(parent outer-swapping-panel)
(min-width 20)))
(define swapping-panel (instantiate panel:single% ()
(parent outer-swapping-panel)
(alignment '(left center))
(stretchable-width #t)
(stretchable-height #f)))
(define file-panel (instantiate horizontal-panel% ()
(parent swapping-panel)
(stretchable-width #t)
(stretchable-height #f)))
(define url-panel (instantiate horizontal-panel% ()
(parent swapping-panel)
(stretchable-height #f)))
(define button-panel (instantiate horizontal-panel% ()
(parent dialog)
(stretchable-height #f)
(alignment '(right center))))
(define file-text-field (instantiate text-field% ()
(parent file-panel)
(callback void)
(min-width 300)
(stretchable-width #t)
(label (string-constant install-plt-filename))))
(define file-button (instantiate button% ()
(parent file-panel)
(label (string-constant browse...))
(callback (λ (x y) (browse)))))
(define url-text-field (instantiate text-field% ()
(parent url-panel)
(label (string-constant install-plt-url))
(min-width 300)
(stretchable-width #t)
(callback void)))
(new tab-panel% [parent dialog]
[callback (λ (x y) (update-panels))]
[choices (list (string-constant install-plt-web-tab)
(string-constant install-plt-file-tab))]))
(define outer-swapping-panel
(new horizontal-panel% [parent tab-panel]
[stretchable-height #f]))
(define spacing-panel
(new horizontal-panel% [parent outer-swapping-panel]
[stretchable-width #f]
[min-width 20]))
(define swapping-panel
(new panel:single% [parent outer-swapping-panel]
[alignment '(left center)]
[stretchable-width #t] [stretchable-height #f]))
(define file-panel
(new horizontal-panel% [parent swapping-panel]
[stretchable-width #t] [stretchable-height #f]))
(define url-panel
(new horizontal-panel% [parent swapping-panel]
[stretchable-height #f]))
(define button-panel
(new horizontal-panel% [parent dialog]
[stretchable-height #f] [alignment '(right center)]))
(define file-text-field
(new text-field% [parent file-panel]
[callback void] [min-width 300] [stretchable-width #t]
[init-value (caddr pref)]
[label (string-constant install-plt-filename)]))
(define file-button
(new button% [parent file-panel]
[callback (λ (x y) (browse))]
[label (string-constant browse...)]))
(define url-text-field
(new text-field% [parent url-panel]
[min-width 300] [stretchable-width #t] [callback void]
[init-value (cadr pref)]
[label (string-constant install-plt-url)]))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons
button-panel
(λ (x y)
(set! cancel? #f)
(send dialog show #f))
(λ (x y)
(send dialog show #f))))
(λ (x y) (set! cancel? #f) (send dialog show #f))
(λ (x y) (send dialog show #f))))
;; browse : -> void
;; gets the name of a file from the user and
;; updates file-text-field
;; gets the name of a file from the user and updates file-text-field
(define (browse)
(let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename
(send file-text-field set-value (path->string filename)))))
;; from-web? : -> boolean
;; returns #t if the user has selected a web address
(define (from-web?)
(zero? (send tab-panel get-selection)))
(define cancel? #t)
(define (update-panels)
(send swapping-panel active-child
(if (from-web?)
url-panel
file-panel)))
(define w? (from-web?))
(define t (if w? url-text-field file-text-field))
(send swapping-panel active-child (if w? url-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)
(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
[cancel? (void)]
[(from-web?)
(install-plt-from-url (trim-whitespace (send url-text-field get-value)) parent)]
[else
(parameterize ([error-display-handler drscheme:init:original-error-display-handler])
(run-installer (string->path (send file-text-field get-value))))]))
;; trim-whitespace: string -> string
;; Trims the whitespace surrounding a string.
(define (trim-whitespace a-str)
(cond
[(regexp-match #px"^\\s*(.*[^\\s])\\s*$"
a-str)
=> second]
[else
a-str]))
(install-plt-from-url
(let* ([url (send url-text-field get-value)]
;; trim whitespaces
[url (regexp-replace #rx"^ +" url "")]
[url (regexp-replace #rx" +$" url "")])
(if (regexp-match? #rx"^(?:[^/:]*://|$)" url)
url
(string-append "http://" url)))
parent)]
[else (parameterize ([error-display-handler
drscheme:init:original-error-display-handler])
(run-installer
(string->path (send file-text-field get-value))))]))
;; install-plt-from-url : string (union #f dialog%) -> void
;; 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 (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@)
(define-unit language-configuration@
@ -28,7 +33,8 @@
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^]
[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^)
;; settings-preferences-symbol : symbol
@ -341,9 +347,11 @@
cached-fringe)
(define/override (on-select i)
(if (and i (is-a? i hieritem-language<%>))
(something-selected i)
(nothing-selected)))
(cond
[(and i (is-a? i hieritem-language<%>))
(something-selected i)]
[else
(non-language-selected)]))
;; this is used only because we set `on-click-always'
(define/override (on-click i)
(when (and i (is-a? i hierarchical-list-compound-item<%>))
@ -353,12 +361,55 @@
(when (and i (is-a? i hieritem-language<%>))
(something-selected i)
(ok-handler 'execute)))
(super-instantiate (parent))
(super-new [parent parent])
;; do this so we can expand/collapse languages on a single click
(send this on-click-always #t)))
(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/manual-parent-panel (make-object vertical-panel% details-outer-panel))
(define details-panel (make-object panel:single% details/manual-parent-panel))
@ -395,19 +446,39 @@
(init-rest args)
(public selected)
(define (selected)
(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))
(update-gui-based-on-selected-language language get-language-details-panel get/set-settings))
(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
;; for when no language is selected.
(define (nothing-selected)
;; for when some non-language is selected in the hierlist
(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 details-panel active-child no-details-panel)
(send one-line-summary-message set-label "")
@ -418,6 +489,8 @@
;; something-selected : item -> void
(define (something-selected item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(ok-handler 'enable)
(send details-button enable #t)
(send item selected))
@ -449,7 +522,7 @@
positions numbers))
(when (null? (cdr positions))
(unless (equal? positions (list "Module"))
(unless (equal? positions (list drscheme:module-language:module-language-name))
(error 'drscheme:language
"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/set-settings (lambda x (apply real-get/set-settings x))]
[position (car positions)]
[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)])
[number (car numbers)])
(set! construct-details
(let ([old construct-details])
@ -529,24 +592,40 @@
[else
(get/set-settings (send language default-settings))])))))
(send item set-number number)
(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))])))]
(cond
[(equal? positions (list drscheme:module-language:module-language-name))
(set! module-language*language language)
(set! module-language*get-language-details-panel get-language-details-panel)
(set! module-language*get/set-settings get/set-settings)]
[else
(let* ([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)])
(send item set-number number)
(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)]
[number (car numbers)]
[sub-ht/sub-hier-list
@ -662,32 +741,38 @@
;; and selects the current language
(define (open-current-language)
(when (and language-to-show settings-to-show)
(let ([language-position (send language-to-show get-language-position)])
(cond
[(null? (cdr language-position))
;; nothing to open here
;; this should only be the module language
(send (car (send languages-hier-list get-items)) select #t)
(void)]
[else
(let loop ([hi languages-hier-list]
(cond
[(equal? language-to-show
module-language*language)
(module-language-selected)]
[else
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(let ([language-position (send language-to-show get-language-position)])
(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
[first-pos (cadr language-position)]
[position (cddr language-position)])
(let ([child
;; know that this `car' is okay by construction of the dialog
(car
(filter (λ (x)
(equal? (send (send x get-editor) get-text)
first-pos))
(send hi get-items)))])
(cond
[(null? position)
(send child select #t)]
[else
(send child open)
(loop child (car position) (cdr position))])))]))))
;; skip the first position, since it is flattened into the dialog
[first-pos (cadr language-position)]
[position (cddr language-position)])
(let ([child
;; know that this `car' is okay by construction of the dialog
(car
(filter (λ (x)
(equal? (send (send x get-editor) get-text)
first-pos))
(send hi get-items)))])
(cond
[(null? position)
(send child select #t)]
[else
(send child open)
(loop child (car position) (cdr position))])))]))])))
;; docs-callback : -> void
(define (docs-callback)
@ -826,6 +911,44 @@
(and 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%
(class editor-canvas%
(inherit get-dc get-client-size)

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

@ -152,6 +152,11 @@
(λ (x) (and (list? x)
(andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? 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
'drscheme:user-defined-keybindings

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

@ -29,7 +29,7 @@
(define module-language<%>
(interface ()
))
get-users-language-name))
;; add-module-language : -> void
;; adds the special module-only language to drscheme
@ -53,10 +53,24 @@
(define default-full-trace? #t)
(define default-auto-text "#lang scheme\n")
(define module-language-name "Determine langauge from source")
;; module-mixin : (implements drscheme:language:language<%>)
;; -> (implements drscheme:language:language<%>)
(define (module-mixin %)
(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/augment (capability-value key)
@ -328,7 +342,7 @@
(super-new
[module #f]
[language-position (list "Module")]
[language-position (list module-language-name)]
[language-numbers (list -32768)])))
;; 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:help-desk: drscheme:help-desk^)
(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^
[-text% text%]
[-text<%> text<%>]))
@ -402,9 +403,15 @@ TODO
default-settings?
(drscheme:language-configuration:language-settings-settings language-settings)))
(define (extract-language-name language-settings)
(send (drscheme:language-configuration:language-settings-language language-settings)
get-language-name))
(define (extract-language-name language-settings defs-text)
(cond
[(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)
(send (drscheme:language-configuration:language-settings-language language-settings)
get-style-delta))
@ -1587,7 +1594,7 @@ TODO
(let-values (((before after)
(insert/delta
this
(extract-language-name user-language-settings)
(extract-language-name user-language-settings definitions-text)
dark-green-delta
(extract-language-style-delta user-language-settings)))
((url) (extract-language-url user-language-settings)))
@ -1618,6 +1625,7 @@ TODO
(reset-regions (list (list (last-position) (last-position))))
(set-unread-start-point (last-position))
(set-insertion-point (last-position))
(set! indenting-limit (last-position))
(set-allow-edits #f)
(set! repl-header-end #f)
(end-edit-sequence))
@ -1653,6 +1661,12 @@ TODO
(end-edit-sequence)
(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.
(define repl-header-end #f)
(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
(mixin ((class->interface text%)) (clever-file-format<%>)
(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)
(let loop ([s (find-first-snip)])
(cond
@ -1765,6 +1768,7 @@ WARNING: printf is rebound in the body of the unit to always
[(is-a? s string-snip%)
(loop (send s next))]
[else #f])))
(define/augment (on-save-file name format)
(let ([all-strings? (all-string-snips)])
(cond

18
collects/framework/splash.ss
View File

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

5
collects/honu/main.ss
View File

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

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

@ -6,6 +6,7 @@
syntax/name
syntax/define
syntax/parse
syntax/parse/experimental
scheme/splicing
"contexts.ss"
"util.ss"
@ -22,17 +23,18 @@
;; macro for defining literal tokens that can be used in macros
(define-syntax-rule (define-literal name ...)
(begin
(define-syntax name (lambda (stx)
(raise-syntax-error 'name
"this is a literal and cannot be used outside a macro")))
...))
(define-syntax name (lambda (stx)
(raise-syntax-error 'name
"this is a literal and cannot be used outside a macro")))
...))
(define-literal honu-return)
(define-literal semicolon)
(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-comma)
;; (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!)
(make-struct-type 'honu-trans #f 1 0 #f
(list (list prop:honu-transformer #t))
(current-inspector) 0))
(make-struct-type 'honu-trans #f 1 0 #f
(list (list prop:honu-transformer #t))
(current-inspector) 0))
(define (make-honu-transformer proc)
(unless (and (procedure? proc)
@ -66,6 +68,7 @@
(and (positive? (string-length str))
(memq (string-ref str 0) sym-chars)))))))
;; returns a transformer or #f
(define (get-transformer stx)
;; if its an identifier and bound to a transformer return it
(define (bound-transformer stx)
@ -355,6 +358,7 @@
x(2)
|#
(define (parse-block-one/2 stx context)
(define (parse-one stx context)
(define-syntax-class block
@ -364,28 +368,63 @@ x(2)
[pattern (type:id name:id (#%parens args ...) body:block . rest)
#:with result #'(define (name args ...)
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
[pattern (~seq e:expr (#%parens arg:expression-1))
#:with call #'(e arg.result)])
#:literals (honu-comma)
[pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...))
#:with call #'(e.result arg.result ...)])
(define-splicing-syntax-class expression-last
[pattern (~seq call:call) #:with result #'call.call]
[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-splicing-syntax-class name
#:literals (operator ...)
[pattern (~seq (~var left next) operator (~var right name))
#:with result (reducer #'left.result #'right.result)]
...
[pattern (~seq (~var exp next))
#:with result #'exp.result]
))
(begin
(define-syntax-class operator-class
#:literals (operator ...)
(pattern operator #:attr func reducer)
...)
(define-splicing-syntax-class name
(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-* ...]
;; [honu-- ...])
;; ([honu-+ ...]
@ -414,23 +453,6 @@ x(2)
#'(begin
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
;; things defined lower in the table have a higher precedence.
;; 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) #'(/ 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))
(syntax-parse stx
[function:function (values #'function.result #'function.rest)]
[expr:expression-top (values #'expr.result #'expr.rest)]
#;
[(x:number . rest) (values #'x #'rest)]
))
(cond
@ -519,7 +556,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(lambda (stx ctx)
(define (parse-complete-block 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 ...))
#;
(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)
;; (printf "used if with else\n")
(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)
;; (printf "used if with no else\n")
(let ([result #'(when condition.expr on-true.line)])
@ -643,11 +680,16 @@ if (foo){
(define-syntax (honu-top stx)
(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)
;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx ()
[(_) #'(begin (void))]
[(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
the-expression-context
#;
the-top-block-context)])
;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code]

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

@ -25,7 +25,7 @@
(define (expand/show-predicate stx show?)
(let-values ([(result deriv) (trace/result stx)])
(when (exn? result) (raise result))
(let-values ([(_steps _uses stx exn2)
(let-values ([(_steps _defs _uses stx exn2)
(parameterize ((macro-policy show?))
(reductions+ deriv))])
(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)]
[else
(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)
(pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list)
@ -107,7 +100,7 @@
(parameterize
([pretty-print-size-hook pp-size-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)))
(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")
(doc: "doc-license.txt") ; needed (when docs are included)
(doc+src: "reference/" "guide/" "quick/" "more/"
"foreign/" "inside/" "futures/"
"foreign/" "inside/" "futures/" "places/"
"honu/")
(doc: "*.{html|css|js|sxref}")
(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)))
(raise-type-error (who->name who)
(if false-ok?
"non-negative exact integeror #f"
"non-negative exact integer or #f"
"non-negative exact integer" )
i))))

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

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

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

@ -621,7 +621,7 @@
(define/public (s-set-as-basic slist)
(set! style-list slist)
(set! name "basic")
(set! name "Basic")
(set! base-style #f)
(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)
mzlib/etc)
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png))
(define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png))
(define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png))
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask))
(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/mask))
(provide hierlist@)
(define-unit hierlist@
@ -93,7 +93,10 @@
(send dc draw-bitmap-section bitmap
(+ x (max 0 (- (/ size 2) (/ bw 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))]
[on-event
(lambda (dc x y mediax mediay event)
@ -340,7 +343,8 @@
[parent-snip parent-snp]
[children null]
[new-children null]
[no-sublists? #f])
[no-sublists? #f]
[transparent? #f])
(private
[append-children! (lambda ()
(unless (null? new-children)
@ -350,17 +354,19 @@
[insert-item
(lambda (mixin snip% whitespace?)
(let ([s (make-object snip% this top top-select (add1 depth) mixin)])
(send s use-style-background transparent?)
(begin-edit-sequence)
(unless (and (null? children)
(null? new-children))
(insert #\newline (last-position)))
(when whitespace?
(insert (make-whitespace) (last-position)))
(insert (make-whitespace) (last-position)))
(insert s (last-position))
(end-edit-sequence)
(set! new-children (cons s new-children))
(send s get-item)))])
(public
[set-transparent (λ (t?) (set! transparent? (and t? #t)))]
[get-parent-snip (lambda () parent-snip)]
[deselect-all
(lambda ()
@ -479,7 +485,7 @@
;; Snip for a compound list item
(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
[parent prnt]
[top tp])
@ -583,11 +589,19 @@
[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)))]
[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
[get-arrow-snip (lambda () arrow)])
(sequence
(inherit style-background-used?)
(sequence
(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)
(when title (send title-buffer insert title))
(when content (send content-buffer insert content))
@ -637,7 +651,7 @@
(send list-keymap map-function "return" "toggle-open/closed")
(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)
(rename [super-on-char on-char]
[super-on-focus on-focus])
@ -702,8 +716,14 @@
(send (car l) scroll-to)]
[else (loop (cdr l))])))]
[select (lambda (i)
(send i select #t)
(send i scroll-to))]
(cond
[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)
(send i click-select #t)
(send i scroll-to))]
@ -854,6 +874,7 @@
[selected #f]
[selected-item #f])
(sequence
(send top-buffer set-transparent (member 'transparent style))
(super-init parent top-buffer style)
(allow-tab-exit #t)
(send top-buffer set-cursor arrow-cursor)

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

@ -1,5 +1,4 @@
#lang scheme/base
#|
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)
;; a normalized-shape (subtype of shape) is either
;; - (make-overlay normalized-shape cropped-simple-shape)
;; - cropped-simple-shape
;; - (make-overlay normalized-shape cn-or-simple-shape)
;; - cn-or-simple-shape
;; a cropped-simple-shape is either
;; - (make-crop (listof points) cropped-simple-shape)
;; an cn-or-simple-shape is either:
;; - simple-shape
;; - (make-crop (listof points) normalized-shape)
;; a simple-shape (subtype of shape) is
;; - (make-translate dx dy np-atomic-shape))
@ -378,16 +377,10 @@ has been moved out).
[dy 0]
[x-scale 1]
[y-scale 1]
[crops '()] ;; (listof (listof point))
[bottom #f])
(define (scale-point p)
(make-point (+ dx (* x-scale (point-x 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
[(translate? shape)
(loop (translate-shape shape)
@ -395,7 +388,6 @@ has been moved out).
(+ dy (* y-scale (translate-dy shape)))
x-scale
y-scale
crops
bottom)]
[(scale? shape)
(loop (scale-shape shape)
@ -403,34 +395,36 @@ has been moved out).
dy
(* x-scale (scale-x shape))
(* y-scale (scale-y shape))
crops
bottom)]
[(overlay? shape)
(loop (overlay-bottom shape)
dx dy x-scale y-scale crops
dx dy x-scale y-scale
(loop (overlay-top shape)
dx dy x-scale y-scale crops
dx dy x-scale y-scale
bottom))]
[(crop? shape)
(loop (crop-shape shape)
dx dy x-scale y-scale
(cons (map scale-point (crop-points shape)) crops)
bottom)]
(let* ([inside (loop (crop-shape shape)
dx dy x-scale y-scale
#f)]
[this-one
(make-crop (map scale-point (crop-points shape))
inside)])
(if bottom
(make-overlay bottom this-one)
this-one))]
[(polygon? shape)
(let* ([this-one
(add-crops
(make-polygon (map scale-point (polygon-points shape))
(polygon-mode shape)
(scale-color (polygon-color shape) x-scale y-scale)))])
(make-polygon (map scale-point (polygon-points shape))
(polygon-mode shape)
(scale-color (polygon-color shape) x-scale y-scale))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
[(line-segment? shape)
(let ([this-one
(add-crops
(make-line-segment (scale-point (line-segment-start shape))
(scale-point (line-segment-end shape))
(scale-color (line-segment-color shape) x-scale y-scale)))])
(make-line-segment (scale-point (line-segment-start shape))
(scale-point (line-segment-end shape))
(scale-color (line-segment-color shape) x-scale y-scale))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
@ -439,27 +433,40 @@ has been moved out).
;; between the two points when it is drawn,
;; so we don't need to scale it here
(let ([this-one
(add-crops
(make-curve-segment (scale-point (curve-segment-start shape))
(curve-segment-s-angle shape)
(curve-segment-s-pull shape)
(scale-point (curve-segment-end shape))
(curve-segment-e-angle shape)
(curve-segment-e-pull shape)
(scale-color (curve-segment-color shape) x-scale y-scale)))])
(make-curve-segment (scale-point (curve-segment-start shape))
(curve-segment-s-angle shape)
(curve-segment-s-pull shape)
(scale-point (curve-segment-end shape))
(curve-segment-e-angle shape)
(curve-segment-e-pull shape)
(scale-color (curve-segment-color shape) x-scale y-scale))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one)))]
[(np-atomic-shape? shape)
(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
(make-overlay bottom (f this-one))
(f this-one)))]
[else
(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)
(or (and (translate? shape)
(np-atomic-shape? (translate-shape shape)))
@ -555,22 +562,30 @@ has been moved out).
(define (render-normalized-shape shape dc dx dy)
(cond
[(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)]
[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
[(crop? shape)
(let ([old-region (send dc get-clipping-region)]
[new-region (new region% [dc dc])]
[path (polygon-points->path (crop-points shape))])
(send new-region set-path path dx dy)
(when old-region (send new-region intersect old-region))
(send dc set-clipping-region new-region)
(render-cropped-simple-shape (crop-shape shape) dc dx dy)
(send dc set-clipping-region old-region))]
(let ([points (crop-points shape)])
(cond
[(equal? points (last-cropped-points))
(render-normalized-shape (crop-shape shape) dc dx dy)]
[else
(let ([old-region (send dc get-clipping-region)]
[new-region (new region% [dc dc])]
[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
(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
(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))
'(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<%>)

4
collects/r5rs/main.ss
View File

@ -209,7 +209,9 @@
form)]
[((unquote-splicing e) . rest)
(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
#,(loop #'(e) (sub1 depth)))
#,(loop #'rest depth)))]

1
collects/redex/pict.ss
View File

@ -59,6 +59,7 @@
[default-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-superscript-style (parameter/c text-style/c)]
[linebreaks (parameter/c (or/c false/c (listof boolean?)))]
[curly-quotes-for-strings (parameter/c boolean?)]
[white-bracket-sizing (parameter/c

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

@ -7,6 +7,7 @@
texpict/utils
texpict/mrpict
scheme/match
scheme/gui/base
scheme/class)
@ -21,6 +22,7 @@
label-style
non-terminal-style
non-terminal-subscript-style
non-terminal-superscript-style
label-font-size
default-font-size
metafunction-font-size
@ -688,18 +690,15 @@
'modern
(default-font-size)))))]
[(and (symbol? atom)
(regexp-match #rx"^([^_]*)_(.*)$" (symbol->string atom)))
(regexp-match #rx"^([^_^]*)_([^^]*)\\^?(.*)$" (symbol->string atom)))
=>
(λ (m)
(let* ([first-part (cadr m)]
[second-part (caddr m)]
[first-span (- span (string-length first-part))])
(list
(non-terminal->token col first-span first-part)
(make-string-token (+ col first-span)
(- span first-span)
second-part
(non-terminal-subscript-style)))))]
(match-lambda
[(list _ nt sub sup)
(let* ([sub-pict (basic-text sub (non-terminal-subscript-style))]
[sup-pict (basic-text sup (non-terminal-superscript-style))]
[sub+sup (lbl-superimpose sub-pict sup-pict)])
(list (non-terminal->token col span nt)
(make-pict-token (+ col span) 0 sub+sup)))])]
[(or (memq atom all-nts)
(memq atom '(number variable variable-except variable-not-otherwise-mentioned)))
(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 non-terminal-style (make-parameter '(italic . roman)))
(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 metafunction-style (make-parameter 'swiss))
(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 (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)
@ -57,27 +54,8 @@
(define (pick-string lang-lits attempt [random random])
(random-string lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt name cross? lang attempt pref-prods
[random random]
[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-nts name cross? lang attempt)
(nt-rhs (nt-by-name lang name cross?)))
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
@ -118,9 +96,6 @@
(define proportion-at-size 1/10)
(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
(define (expected-value->p E)
;; E = 0 => p = 1, which breaks random-natural
@ -177,11 +152,11 @@
who what attempts (if (= attempts 1) "" "s"))])
(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@
(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)
(let*-values
([(term _)
@ -193,10 +168,10 @@
(min-prods (nt-by-name lang name cross?)
((if cross? base-cases-cross base-cases-non-cross)
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))))
(λ (_ env) (mismatches-satisfied? env))
size attempt)])
size attempt retries)])
term))
(define (generate-sequence ellipsis generate env length)
@ -222,18 +197,18 @@
(values (cons term terms) (cons env 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
(ceiling
(/ (- retry-threshold init-att)
(* proportion-before-threshold retries)))]
(* proportion-before-threshold (add1 retries))))]
[incr-size?
(λ (remain)
(zero?
(modulo (sub1 remain)
(ceiling (* proportion-at-size
retries)))))])
(let retry ([remaining retries]
(let retry ([remaining (add1 retries)]
[size init-sz]
[attempt init-att])
(if (zero? remaining)
@ -279,120 +254,109 @@
(cons (make-bind (binder-name key) val) bindings)
bindings))))
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt))
(define (generate-pat lang sexp retries size attempt env in-hole pat)
(define recur (curry generate-pat lang sexp retries size attempt))
(define recur/pat (recur env in-hole))
(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 gen-nt
(generate-nt
clang
(rg-lang-base-cases lang)
(curry generate-pat lang sexp pref-prods user-gen user-acc)
pref-prods))
(curry generate-pat lang sexp retries)
retries))
(define (default-gen user-acc)
(match pat
[`number (values ((next-number-decision) attempt) env)]
[`natural (values ((next-natural-decision) attempt) env)]
[`integer (values ((next-integer-decision) attempt) env)]
[`real (values ((next-real-decision) attempt) env)]
[`(variable-except ,vars ...)
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var vars)))
size attempt)]
[`variable
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
env)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var (compiled-lang-literals clang))))
size attempt)]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(let-values ([(term env) (recur/pat 'variable)])
(values (symbol-append prefix term) env))]
[`string
(values ((next-string-decision) (rg-lang-lits lang) attempt)
env)]
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(recur/pat/size-attempt pat)
(λ (_ env) (condition (bindings env)))
size attempt)]
[`(name ,(? symbol? id) ,p)
(let-values ([(term env) (recur/pat p)])
(values term (hash-set env (make-binder id) term)))]
[`hole (values in-hole env)]
[`(in-hole ,context ,contractum)
(let-values ([(term env) (recur/pat contractum)])
(recur env term context))]
[`(hide-hole ,pattern) (recur env the-hole pattern)]
[`any
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
; Don't use preferred productions for the sexp language.
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
[(term _) (generate-pat new-lang
sexp
pref-prods
user-gen
user-acc
size
attempt
empty-env
the-hole
nt)])
(values term env))]
[(? (is-nt? clang))
(values (gen-nt pat #f size attempt in-hole env) env)]
[(struct binder ((or (? (is-nt? clang) nt)
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
(generate/prior pat env (λ () (recur/pat nt)))]
[(struct binder ((or (? built-in? b)
(app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat env (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? (is-nt? clang) nt)))))
(let-values ([(term _) (recur/pat nt)])
(values term (hash-set env pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? built-in? b)))))
(let-values ([(term _) (recur/pat b)])
(values term (hash-set env pat term)))]
[`(cross ,(? symbol? cross-nt))
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
(if prior prior ((next-sequence-decision) attempt)))]
[(seq env) (generate-sequence ellipsis recur env length)]
[(rest env) (recur (hash-set (hash-set env class length) name length)
in-hole rest)])
(values (append seq rest) env))]
[(list-rest pat rest)
(let*-values
([(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))
(match pat
[`number (values ((next-number-decision) attempt) env)]
[`natural (values ((next-natural-decision) attempt) env)]
[`integer (values ((next-integer-decision) attempt) env)]
[`real (values ((next-real-decision) attempt) env)]
[`(variable-except ,vars ...)
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var vars)))
size attempt retries)]
[`variable
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
env)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var (compiled-lang-literals clang))))
size attempt retries)]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(let-values ([(term env) (recur/pat 'variable)])
(values (symbol-append prefix term) env))]
[`string
(values ((next-string-decision) (rg-lang-lits lang) attempt)
env)]
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(recur/pat/size-attempt pat)
(λ (_ env) (condition (bindings env)))
size attempt retries)]
[`(name ,(? symbol? id) ,p)
(let-values ([(term env) (recur/pat p)])
(values term (hash-set env (make-binder id) term)))]
[`hole (values in-hole env)]
[`(in-hole ,context ,contractum)
(let-values ([(term env) (recur/pat contractum)])
(recur env term context))]
[`(hide-hole ,pattern) (recur env the-hole pattern)]
[`any
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
[(term _) (generate-pat new-lang
sexp
retries
size
attempt
empty-env
the-hole
nt)])
(values term env))]
[(? (is-nt? clang))
(values (gen-nt pat #f size attempt in-hole env) env)]
[(struct binder ((or (? (is-nt? clang) nt)
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
(generate/prior pat env (λ () (recur/pat nt)))]
[(struct binder ((or (? built-in? b)
(app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat env (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? (is-nt? clang) nt)))))
(let-values ([(term _) (recur/pat nt)])
(values term (hash-set env pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? built-in? b)))))
(let-values ([(term _) (recur/pat b)])
(values term (hash-set env pat term)))]
[`(cross ,(? symbol? cross-nt))
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
(if prior prior ((next-sequence-decision) attempt)))]
[(seq env) (generate-sequence ellipsis recur env length)]
[(rest env) (recur (hash-set (hash-set env class length) name length)
in-hole rest)])
(values (append seq rest) env))]
[(list-rest pat rest)
(let*-values
([(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)]))
(let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)])
(λ (pat)
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
(λ (size attempt)
(λ (size attempt retries)
(let-values ([(term env)
(generate/pred
pat
@ -400,16 +364,14 @@
(generate-pat
rg-lang
rg-sexp
((next-pref-prods-decision) (rg-lang-clang rg-lang))
user-gen
#f
retries
size
attempt
empty-env
the-hole
parsed))
(λ (_ env) (mismatches-satisfied? env))
size attempt)])
size attempt retries)])
(values term (bindings env))))))))
(define-struct base-cases (cross non-cross))
@ -681,36 +643,35 @@
x
(raise-type-error 'redex-check "reduction-relation" x)))
(define (defer-all pat size in-hole acc env att recur defer)
(defer acc))
(define-for-syntax (term-generator lang pat decisions@ custom retries what)
(define-for-syntax (term-generator lang pat decisions@ what)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts lang what)
what #t pat)])
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern)))
#`((generate #,lang #,decisions@ '#,what) `pattern)))
(define-syntax (generate-term stx)
(syntax-case stx ()
[(_ lang pat size . kw-args)
(with-syntax ([(attempt retries custom)
(parse-kw-args `((#:attempt . 1)
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
[(name lang pat size . kw-args)
(with-syntax ([(attempt retries)
(parse-kw-args `((#:attempt-num . 1)
(#:retries . ,#'default-retries))
(syntax kw-args)
stx)])
(with-syntax ([generate (term-generator #'lang
#'pat
#'(generation-decisions)
#'custom
#'retries
'generate-term)])
(syntax/loc stx
(let-values ([(term _) (generate size attempt)])
term))))]
[(_ lang pat size)
(syntax/loc stx (generate-term lang pat size #:attempt 1))]))
(syntax/loc stx
((generate-term lang pat) size #:attempt-num attempt #:retries retries)))]
[(name lang pat)
(with-syntax ([make-gen (term-generator #'lang
#'pat
#'(generation-decisions)
(syntax-e #'name))])
(syntax/loc stx
(let ([generate make-gen])
(λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
(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)
(syntax-case stx ()
@ -734,12 +695,12 @@
(let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)]
[(attempts-stx source-stx retries-stx custom-stx)
[(attempts-stx source-stx retries-stx print?-stx)
(apply values
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:source . #f)
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
(#:print? . #t))
(syntax kw-args)
stx))])
(with-syntax ([(name ...) names]
@ -752,17 +713,7 @@
(quasisyntax/loc stx
(let ([att (assert-nat 'redex-check #,attempts-stx)]
[ret (assert-nat 'redex-check #,retries-stx)]
[custom (contract
(-> 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 '+ '-)])
[print? #,print?-stx])
(unsyntax
(if source-stx
#`(let-values ([(metafunc/red-rel num-cases)
@ -776,27 +727,32 @@
metafunc/red-rel
property
random-decisions@
custom
(max 1 (floor (/ att num-cases)))
ret
'redex-check
show
(and print? show)
(test-match lang pat)
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
#`(check-prop
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check)
property att show)))
(void))))))]))
#,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
property att ret (and print? show)))))))))]))
(define (format-attempts a)
(format "~a attempt~a" a (if (= 1 a) "" "s")))
(define (check-prop generator property attempts show)
(when (check generator property attempts show)
(show (format "no counterexamples in ~a\n"
(format-attempts attempts)))))
(define (check-prop generator property attempts retries show)
(let ([c (check generator property attempts retries show)])
(if (counterexample? c)
(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]
#:match [match #f]
#:match-fail [match-fail #f])
@ -804,14 +760,21 @@
(if (zero? remaining)
#t
(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)
(with-handlers
([exn:fail?
(λ (exn)
(show
(format "checking ~s raises an exception\n" term))
(raise exn))])
(when show
(show (format "checking ~s raises an exception\n" term)))
(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)))
(cond [(and match match-fail (match term))
=> (curry map (compose make-bindings match-bindings))]
@ -819,22 +782,22 @@
[else (list bindings)]))
(loop (sub1 remaining))
(begin
(show
(format "counterexample found after ~a~a:\n"
(format-attempts attempt)
(if source (format " with ~a" source) "")))
(pretty-print term (current-output-port))
#f)))))))
(when show
(show
(format "counterexample found after ~a~a:\n"
(format-attempts attempt)
(if source (format " with ~a" source) "")))
(pretty-print term (current-output-port)))
(make-counterexample term))))))))
(define-syntax (check-metafunction-contract stx)
(syntax-case stx ()
[(_ name . kw-args)
(identifier? #'name)
(with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom)
[(attempts retries)
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
(#:retries . ,#'default-retries))
(syntax kw-args)
stx)]
[show (show-message stx)])
@ -844,18 +807,19 @@
[decisions@ (generation-decisions)]
[att (assert-nat 'check-metafunction-contract attempts)])
(check-prop
((generate lang decisions@ custom retries 'check-metafunction-contract)
((generate lang decisions@ 'check-metafunction-contract)
(if dom dom '(any (... ...))))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
att
retries
show))))]))
(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show
[match #f]
[match-fail #f])
(let ([lang-gen (generate lang decisions@ custom retries what)])
(define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show
[match #f]
[match-fail #f])
(let ([lang-gen (generate lang decisions@ what)])
(let-values ([(pats srcs)
(cond [(metafunc-proc? mf/rr)
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
@ -863,47 +827,53 @@
[(reduction-relation? mf/rr)
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
(reduction-relation-srcs mf/rr))])])
(when (for/and ([pat pats] [src srcs])
(with-handlers ([exn:fail:redex:generation-failure?
; Produce an error message that blames the LHS as a whole.
(λ (_)
(raise-gen-fail what (format "LHS of ~a" src) retries))])
(check
(lang-gen pat)
prop
attempts
show
#:source src
#:match match
#:match-fail match-fail)))
(show
(format "no counterexamples in ~a (with each clause)\n"
(format-attempts attempts)))))))
(let loop ([pats pats] [srcs srcs])
(if (and (null? pats) (null? srcs))
(if show
(show
(format "no counterexamples in ~a (with each clause)\n"
(format-attempts attempts)))
#t)
(let ([c (with-handlers ([exn:fail:redex:generation-failure?
; Produce an error message that blames the LHS as a whole.
(λ (_)
(raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))])
(check
(lang-gen (car pats))
prop
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)
(syntax-case stx ()
[(_ name property . kw-args)
(with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries custom)
[(attempts retries print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries)
(#:custm . ,#'defer-all))
(#:print? . #t))
(syntax kw-args)
stx)]
[show (show-message stx)])
(syntax/loc stx
(let ([att (assert-nat 'check-metafunction attempts)]
[ret (assert-nat 'check-metafunction retries)])
(check-lhs-pats
(metafunc-proc-lang m)
m
(λ (term _) (property term))
(generation-decisions)
custom
att
ret
'check-metafunction
show))))]))
stx)])
(with-syntax ([show (show-message stx)])
(syntax/loc stx
(let ([att (assert-nat 'check-metafunction attempts)]
[ret (assert-nat 'check-metafunction retries)])
(check-lhs-pats
(metafunc-proc-lang m)
m
(λ (term _) (property term))
(generation-decisions)
att
ret
'check-metafunction
(and print? show))))))]))
(define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc)
@ -917,11 +887,11 @@
(define-syntax (check-reduction-relation stx)
(syntax-case stx ()
[(_ relation property . kw-args)
(with-syntax ([(attempts retries decisions@ custom)
(with-syntax ([(attempts retries decisions@ print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries)
(#:decisions . ,#'random-decisions@)
(#:custom . ,#'defer-all))
(#:print? . #t))
(syntax kw-args)
stx)]
[show (show-message stx)])
@ -934,11 +904,10 @@
rel
(λ (term _) (property term))
decisions@
custom
attempts
retries
'check-reduction-relation
show))))]))
(and print? show)))))]))
(define-signature decisions^
(next-variable-decision
@ -949,8 +918,7 @@
next-non-terminal-decision
next-sequence-decision
next-any-decision
next-string-decision
next-pref-prods-decision))
next-string-decision))
(define random-decisions@
(unit (import) (export decisions^)
@ -959,11 +927,10 @@
(define (next-natural-decision) pick-natural)
(define (next-integer-decision) pick-integer)
(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-any-decision) pick-any)
(define (next-string-decision) pick-string)
(define (next-pref-prods-decision) pick-preferred-productions)))
(define (next-string-decision) pick-string)))
(define generation-decisions (make-parameter random-decisions@))
@ -979,18 +946,17 @@
(struct-out class)
(struct-out binder)
(struct-out base-cases)
(struct-out pref-prods))
(struct-out counterexample)
(struct-out exn:fail:redex:test))
(provide pick-from-list pick-sequence-length
pick-char pick-var pick-string
pick-nt pick-any pick-preferred-productions
(provide pick-from-list pick-sequence-length pick-nts
pick-char pick-var pick-string pick-any
pick-number pick-natural pick-integer pick-real
parse-pattern unparse-pattern
parse-language prepare-lang
class-reassignments reassign-classes
default-retries proportion-at-size
preferred-production-threshold retry-threshold
proportion-before-threshold post-threshold-incr
retry-threshold proportion-before-threshold post-threshold-incr
is-nt? nt-by-name min-prods
generation-decisions decisions^
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)
(covered-cases plus-coverage))))]
@defform/subs[(generate-term language @#,ttpattern size-exp kw-args ...)
([kw-args (code:line #:attempts attempts-expr)
@defform*/subs[[(generate-term language @#,ttpattern size-expr kw-args ...)
(generate-term language @#,ttpattern)]
([kw-args (code:line #:attempt-num attempts-expr)
(code:line #:retries retries-expr)])
#:contracts ([size-expr natural-number/c]
[attempt-num-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
(measured as the height of the derivation tree used to produce
the term).
(measured as the height of its parse tree).
The optional keyword argument @scheme[attempt-num-expr]
(default @scheme[1]) provides coarse grained control over the random
decisions made during generation. For example, the expected length of
@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr].
decisions made during generation; increasing @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
imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s when
constructing a term; instead, it tests the satisfaction of
such constraints after it freely generates the relevant portion of the
sub-term---regenerating the sub-term if necessary. The optional keyword
argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times that
@scheme[generate-term] retries the generation of any sub-term. If
imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s; instead,
it uses a ``guess and check'' strategy in which it freely generates
candidate terms then tests whether they happen to satisfy the constraints,
repeating as necessary. The optional keyword argument @scheme[retries-expr]
(default @scheme[100]) bounds the number of times that
@scheme[generate-term] retries the generation of any pattern. If
@scheme[generate-term] is unable to produce a satisfying term after
@scheme[retries-expr] attempts, it raises an exception recognized by
@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)
(code:line #:source metafunction)
(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]
[attempts-expr natural-number/c]
[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
as a predicate universally quantified over the pattern variables
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].
@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
gradually increases with each failed attempt.
random terms in its search. The size and complexity of these terms increase with
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]
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
#: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 ...)
([kw-arg (code:line #:attempts attempts-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[non-terminal-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]{}]]{
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
information, too.)
The label-style is used for the reduction rule label
names. The literal-style is used for names that aren't
The @scheme[label-style] is used for the reduction rule label
names. The @scheme[literal-style] is used for names that aren't
non-terminals that appear in patterns. The
metafunction-style is used for the names of
metafunctions. The non-terminal-style is for non-terminals
and non-terminal-subscript-style is used for the portion
@scheme[metafunction-style] is used for the names of
metafunctions.
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.
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
"where" and "fresh" in side-conditions, and other places
where the other parameters aren't used.

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

@ -50,7 +50,9 @@
check-metafunction
check-metafunction-contract
check-reduction-relation
exn:fail:redex:generation-failure?)
exn:fail:redex:generation-failure?
(struct-out exn:fail:redex:test)
(struct-out counterexample))
(provide/contract
[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/proc
#,(syntax-line stx)
test-exp
(λ () test-exp)
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))
(let* ([bitmap-filename
(let* ([pict (set-fonts/call pict-thunk)]
[bitmap-filename
(build-path (format "bmps-~a" (system-type))
(case (system-type)
[(unix) (string-append "unix-" raw-bitmap-filename)]
[else raw-bitmap-filename]))]
raw-bitmap-filename)]
[old-bitmap (if (file-exists? bitmap-filename)
(make-object bitmap% bitmap-filename)
(let* ([bm (make-object bitmap% 100 20)]
@ -39,8 +38,8 @@
(send bdc set-bitmap #f)
bm))]
[new-bitmap (make-object bitmap%
(inexact->exact (pict-width pict))
(inexact->exact (pict-height pict)))]
(ceiling (inexact->exact (pict-width pict)))
(ceiling (inexact->exact (pict-height pict))))]
[bdc (make-object bitmap-dc% new-bitmap)])
(send bdc clear)
(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)])
(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)
(let* ([w (max (send old-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
(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: ")
(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
(require "core-layout.ss"
"loc-wrapper.ss"
(require "../private/core-layout.ss"
"../private/loc-wrapper.ss"
"lw-test-util.ss"
"test-util.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
(require "keyword-macros.ss"
(require "../private/keyword-macros.ss"
"test-util.ss")
(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
(require "loc-wrapper.ss")
(require "../private/loc-wrapper.ss")
(provide normalize-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
(require "test-util.ss"
"loc-wrapper.ss"
"../private/loc-wrapper.ss"
"lw-test-util.ss")
(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
(require "matcher.ss"
(require "../private/matcher.ss"
(only "test-util.ss" equal/bindings?)
(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
(require "test-util.ss"
"reduction-semantics.ss"
"matcher.ss"
"term.ss"
"rg.ss"
"keyword-macros.ss"
"error.ss")
"../private/reduction-semantics.ss"
"../private/matcher.ss"
"../private/term.ss"
"../private/rg.ss"
"../private/keyword-macros.ss"
"../private/error.ss")
(define-namespace-anchor nsa)
(define ns (namespace-anchor->namespace nsa))
(reset-count)
@ -111,23 +114,6 @@
(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))
(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
(syntax-rules ()
[(_ expr) (raised-exn-msg exn:fail? expr)]
@ -141,7 +127,7 @@
(define (patterns . selectors)
(map (λ (selector)
(λ (name cross? lang size pref-prods)
(λ (name cross? lang sizes)
(list (selector (nt-rhs (nt-by-name lang name cross?))))))
selectors))
@ -158,15 +144,14 @@
(test (raised-exn-msg (iter)) #rx"empty"))
(define (decisions #:var [var pick-var]
#:nt [nt pick-nt]
#:nt [nt pick-nts]
#:str [str pick-string]
#:num [num pick-number]
#:nat [nat pick-natural]
#:int [int pick-integer]
#:real [real pick-real]
#:any [any pick-any]
#:seq [seq pick-sequence-length]
#:pref [pref pick-preferred-productions])
#:seq [seq pick-sequence-length])
(define-syntax decision
(syntax-rules ()
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
@ -179,14 +164,13 @@
(define next-real-decision (decision real))
(define next-string-decision (decision str))
(define next-any-decision (decision any))
(define next-sequence-decision (decision seq))
(define next-pref-prods-decision (decision pref))))
(define next-sequence-decision (decision seq))))
(define-syntax generate-term/decisions
(syntax-rules ()
[(_ lang pat size attempt decisions)
(parameterize ([generation-decisions decisions])
(generate-term lang pat size #:attempt attempt))]))
(generate-term lang pat size #:attempt-num attempt))]))
(let ()
(define-language lc
@ -216,6 +200,17 @@
#:var (list (λ _ '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
(let ()
(define-language var
@ -231,17 +226,17 @@
(n natural)
(i integer)
(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)
(exact? n)
(not (negative? n))))
#t)
(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)))
#t)
(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))
(let ()
@ -539,77 +534,23 @@
(get-output-string 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
(let ()
(define-language lang
(d 5)
(e e 4)
(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)))
#rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n")
(test (output (λ () (redex-check lang d #t)))
@ -644,17 +585,28 @@
(--> 0 dontcare z)))))
#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
(λ ()
(redex-check lang n (set! generated (cons (term n) generated))
#:attempts 5
#:source (reduction-relation
lang
(--> 1 dontcare)
(--> 2 dontcare)))))
#:source R)))
#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 ()
(define-metafunction lang
@ -665,7 +617,16 @@
(redex-check lang (n) (eq? 42 (term n))
#:attempts 1
#: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 ()
(define-metafunction lang
@ -790,6 +751,14 @@
(E* hole E*)
(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]
[R (reduction-relation
L
@ -857,6 +826,11 @@
(define-metafunction empty
[(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])
(test (begin
(output
@ -890,89 +864,6 @@
(check-metafunction n (λ (_) #t) #:retries 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
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
(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"
"test-util.ss")
(set-show-bitmaps? #t)
(set-show-bitmaps? #f)
(define test-files
'("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
(require "term.ss"
"matcher.ss"
(require "../private/term.ss"
"../private/matcher.ss"
"test-util.ss")
(reset-count)

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

@ -1,6 +1,6 @@
#lang scheme
(require "matcher.ss"
(require "../private/matcher.ss"
errortrace/errortrace-lib
errortrace/errortrace-key)
(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
(require "../reduction-semantics.ss"
"test-util.ss"
(only-in "matcher.ss" make-bindings make-bind)
(only-in "../private/matcher.ss" make-bindings make-bind)
scheme/match
"struct.ss")
"../private/struct.ss")
(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
(require scheme/port
scheme/path
scheme/list
scheme/string
syntax/moddep
@ -444,7 +445,7 @@
(cond [(and p (null? (cdr inps)))
(port-count-lines! 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
(unless (eq? p (car inps)) (close-input-port p))))]
[p (error 'input->code "ambiguous inputs: ~e" inps)]
@ -550,11 +551,17 @@
(module->namespace `(quote ,(syntax-e mod)))))]
[_else #f])])
;; the actual evaluation happens under the specified limits
((limit-thunk (lambda ()
(if (and (pair? program) (eq? 'begin (car program)))
(eval* (cdr program))
(eval program))
(when ns (set! ns (ns))))))
(parameterize ([current-load-relative-directory
(let* ([d (and (syntax? program) (syntax-source program))]
[d (and (path-string? d) (path-only d))])
(if (and d (directory-exists? d))
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!
(let ([get (let ([ns (current-namespace)])
(lambda () (eval '(get-uncovered-expressions) ns)))])

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

@ -40,7 +40,6 @@
(dynamic-require 'scribble/run #f)
(cond
[(equal? label "HTML")
(system (format "firefox ~a" (path-replace-suffix name suffix)))
(send-url/file (path-replace-suffix fn suffix))]
[else (system (format "open ~a" (path-replace-suffix name suffix)))]))
(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.})
(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)
(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.
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}

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
'deleted))
'(vertical)]
[selection exact-nonnegative-integer? 0]
[selection (or/c exact-nonnegative-integer? #f) 0]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[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}
By default, the first radio button is initially selected. If
@scheme[selection] is positive, it is passed to @method[radio-box%
set-selection] to set the initial radio button selection.
@scheme[selection] is positive or @scheme[#f], it is passed to
@method[radio-box% set-selection] to set the initial radio button
selection.
@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)
exact-nonnegative-integer?]{
(or/c exact-nonnegative-integer? #f)]{
Gets the position of the selected radio button. Radio buttons are
numbered from @scheme[0].
Gets the position of the selected radio button, returning @scheme[#f]
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?]{
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
@scheme[0]. If @scheme[n] is equal to or larger than the number of
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