changed the internal representation of normalized images so that crop structs do no have to be duplicated, improved test suites

svn: r17808
This commit is contained in:
Robby Findler 2010-01-24 20:22:58 +00:00
parent bef818b2be
commit cf4294a280
4 changed files with 1093 additions and 77 deletions

View File

@ -2,6 +2,7 @@
(require "../../mrlib/image-core.ss"
"img-err.ss"
scheme/match
scheme/contract
scheme/class
scheme/gui/base
@ -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-cropped-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)))]
[else
(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 (cropped-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

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)))

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,65 @@
#rx"^polygon: expected <image-color>")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; random testing of normalization
;; make sure normalization actually normalizes
;; and that normalization doesn't introduce new structs
;;
(define (random-image size)
(let loop ([size size])
(let ([val (random (if (zero? size) 4 8))])
(case val
[(0) (rectangle (random-size) (random-size) (random-mode) (random-color))]
[(1) (circle (random-size) (random-mode) (random-color))]
[(2) (line (random-coord) (random-coord) (random-color))]
[(3) (add-curve
(rectangle (random-size) (random-size) (random-mode) (random-color))
(random-coord) (random-coord) (random-pull) (random-angle)
(random-coord) (random-coord) (random-pull) (random-angle)
(random-color))]
[(4) (overlay (loop (floor (/ size 2)))
(loop (ceiling (/ size 2))))]
[(5) (crop (random-coord) (random-coord) (random-size) (random-size)
(loop (- size 1)))]
[(6) (scale/xy (random-size)
(random-size)
(loop (- size 1)))]
[(7) (rotate (random-angle) (loop (- size 1)))]))))
(define (random-pull) (/ (random 20) (+ 1 (random 10))))
(define (random-angle) (random 360))
(define (random-coord) (- (random 200) 100))
(define (random-size) (random 100))
(define (random-mode) (if (zero? (random 2)) 'outline 'solid))
(define (random-color) (pick-from-list '("red" red "blue" "orange" "green" "black")))
(define (pick-from-list l) (list-ref l (random (length l))))
(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))))))
(time
(let ([seed (+ 1 (modulo (current-seconds) (- (expt 2 31) 1)))])
(random-seed seed)
(for ((i (in-range 0 20000)))
(let* ([img (random-image 10)]
[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 (seed ~a) after normalization ~s:"
seed
img))
(unless (equal? norm-size raw-size)
(error 'test-image.ss "found differing sizes (seed ~a):\n ~s\n ~s"
seed
raw-size norm-size))))))

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,25 +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]
[(null? (cdr crops))
(make-crop (car crops) shape)]
[else
(let ([fst (car crops)]
[snd (cadr crops)])
(cond
[(equal? fst snd)
(loop (cdr crops))]
[else
(make-crop (car crops) (loop (cdr crops)))]))])))
(cond
[(translate? shape)
(loop (translate-shape shape)
@ -404,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)
@ -412,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)))]
@ -448,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)))
@ -564,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)]))
@ -941,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?)