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
parent
bef818b2be
commit
cf4294a280
|
|
@ -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
|
||||
|
|
|
|||
908
collects/2htdp/tests/image-equality-performance.ss
Normal file
908
collects/2htdp/tests/image-equality-performance.ss
Normal 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)))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user