From cf4294a28033788548f0057410b373f5f72b7c36 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 24 Jan 2010 20:22:58 +0000 Subject: [PATCH] changed the internal representation of normalized images so that crop structs do no have to be duplicated, improved test suites svn: r17808 --- collects/2htdp/private/image-more.ss | 43 +- .../2htdp/tests/image-equality-performance.ss | 908 ++++++++++++++++++ collects/2htdp/tests/test-image.ss | 97 +- collects/mrlib/image-core.ss | 122 +-- 4 files changed, 1093 insertions(+), 77 deletions(-) create mode 100644 collects/2htdp/tests/image-equality-performance.ss diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index d97cd4c798..5068aa47e4 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -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 diff --git a/collects/2htdp/tests/image-equality-performance.ss b/collects/2htdp/tests/image-equality-performance.ss new file mode 100644 index 0000000000..79960d210e --- /dev/null +++ b/collects/2htdp/tests/image-equality-performance.ss @@ -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))) diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss index ca20179c10..0c645617c7 100644 --- a/collects/2htdp/tests/test-image.ss +++ b/collects/2htdp/tests/test-image.ss @@ -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 ") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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)))))) diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index 96f65a87f0..51444167b6 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -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?)