diff --git a/collects/2htdp/tests/image-equality-performance-htdp.rkt b/collects/2htdp/tests/image-equality-performance-htdp.rkt new file mode 100644 index 0000000000..547c0c9286 --- /dev/null +++ b/collects/2htdp/tests/image-equality-performance-htdp.rkt @@ -0,0 +1,900 @@ +#lang racket + +#| + +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 racket +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 htdp/image) + +(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-syntax-rule (underlay/xy a x y b) (overlay/xy b (- x) (- y) a)) + +;;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 for htdp/image") +(time (run-tests)) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 860d891472..3d9a13f262 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -552,7 +552,13 @@ has been moved out). [font (send dc get-font)] [fg (send dc get-text-foreground)] [smoothing (send dc get-smoothing)]) - (render-normalized-shape (send image get-normalized-shape) dc dx dy) + (cond + [(is-a? image bitmap%) + (send dc draw-bitmap image dx dy)] + [(is-a? image image-snip%) + (send dc draw-bitmap (send image get-bitmap) dx dy)] + [else + (render-normalized-shape (send image get-normalized-shape) dc dx dy)]) (send dc set-pen pen) (send dc set-brush brush) (send dc set-font font) diff --git a/collects/scriblib/gui-eval.rkt b/collects/scriblib/gui-eval.rkt index 49d988c4b3..e6e93f93a3 100644 --- a/collects/scriblib/gui-eval.rkt +++ b/collects/scriblib/gui-eval.rkt @@ -8,21 +8,40 @@ racket/runtime-path racket/serialize "private/gui-eval-exn.ss" - racket/system) + racket/system + (for-syntax racket/base)) (define-syntax define-mr (syntax-rules () [(_ mr orig) (begin (provide mr) - (define-syntax mr - (syntax-rules () + (define-syntax (mr stx) + (syntax-case stx () + [(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...)) + #'(let ([the-eval-x the-eval]) + (parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x + get-predicate? + get-render + get-get-width + get-get-height)]) + (orig #:eval the-eval-x x (... ...))))] [(_ x (... ...)) - (parameterize ([scribble-eval-handler gui-eval-handler]) - (orig #:eval gui-eval x (... ...)))])))])) + #'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval + (λ () (gui-eval 'pict?)) + (λ () (gui-eval 'draw-pict)) + (λ () (gui-eval 'pict-width)) + (λ () (gui-eval 'pict-height)))]) + (orig #:eval gui-eval x (... ...)))])))])) (define gui-eval (make-base-eval)) +(define mred? (getenv "MREVAL")) + +(when mred? + (gui-eval '(require racket/gui/base)) + (gui-eval '(require slideshow))) + (define-mr gui-interaction interaction) (define-mr gui-interaction-eval interaction-eval) (define-mr gui-interaction-eval-show interaction-eval-show) @@ -34,12 +53,6 @@ (provide (rename-out [gui-racketmod+eval gui-schememod+eval] [gui-racketblock+eval gui-schemeblock+eval])) -(define mred? (getenv "MREVAL")) - -(when mred? - (gui-eval '(require racket/gui/base)) - (gui-eval '(require slideshow))) - ;; This one needs to be relative, because it ends up in the ;; exprs.dat file: (define img-dir "images") ; relative to src dir @@ -52,16 +65,20 @@ (if mred? (let ([eh (scribble-eval-handler)] [log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)]) - (lambda (ev catching-exns? expr) - (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file) - (newline log-file) - (flush-output log-file) - (let ([result - (with-handlers ([exn:fail? - (lambda (exn) - (make-gui-exn (exn-message exn)))]) - (eh ev catching-exns? expr))]) - (let ([result (fixup-picts result)]) + (λ (gui-eval get-predicate? get-render get-get-width get-get-height) + (lambda (ev catching-exns? expr) + (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file) + (newline log-file) + (flush-output log-file) + (let ([result + (with-handlers ([exn:fail? + (lambda (exn) + (make-gui-exn (exn-message exn)))]) + ;; put the call to fixup-picts in the handlers + ;; so that errors in the user-supplied predicates & + ;; conversion functions show up in the rendered output + (fixup-picts (get-predicate?) (get-render) (get-get-width) (get-get-height) + (eh ev catching-exns? expr)))]) (write (serialize result) log-file) (newline log-file) (flush-output log-file) @@ -74,71 +91,73 @@ (lambda (exn) (open-input-string ""))]) (open-input-file exprs-dat-file))]) - (lambda (ev catching-exns? expr) - (with-handlers ([exn:fail? (lambda (exn) - (if catching-exns? - (raise exn) - (void)))]) - (let ([v (read log-file)]) - (if (eof-object? v) - (error "expression not in log file") - (let ([v (deserialize v)]) - (if (equal? v (if (syntax? expr) - (syntax->datum expr) - expr)) - (let ([v (read log-file)]) - (if (eof-object? v) - (error "expression result missing in log file") - (let ([v (deserialize v)]) - (if (gui-exn? v) - (raise (make-exn:fail - (gui-exn-message v) - (current-continuation-marks))) - v)))) - (error 'mreval - "expression does not match log file: ~e versus: ~e" - expr - v)))))))))) + (λ (gui-eval get-predicate? get-render get-get-width get-get-height) + (lambda (ev catching-exns? expr) + (with-handlers ([exn:fail? (lambda (exn) + (if catching-exns? + (raise exn) + (void)))]) + (let ([v (read log-file)]) + (if (eof-object? v) + (error "expression not in log file") + (let ([v (deserialize v)]) + (if (equal? v (if (syntax? expr) + (syntax->datum expr) + expr)) + (let ([v (read log-file)]) + (if (eof-object? v) + (error "expression result missing in log file") + (let ([v (deserialize v)]) + (if (gui-exn? v) + (raise (make-exn:fail + (gui-exn-message v) + (current-continuation-marks))) + v)))) + (error 'mreval + "expression does not match log file: ~e versus: ~e" + expr + v))))))))))) (define image-counter 0) ;; This path will be marshaled for use on multiple platforms (define (build-string-path a b) (string-append a "/" b)) -(define (fixup-picts v) - (cond - [((gui-eval 'pict?) v) - (let ([fn (build-string-path img-dir - (format "img~a.png" image-counter))]) - (set! image-counter (add1 image-counter)) - (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))]) - (send pss set-mode 'file) - (send pss set-file (path-replace-suffix fn #".ps")) - (parameterize ([(gui-eval 'current-ps-setup) pss]) - (make-object (gui-eval 'post-script-dc%) #f)))]) - (send dc start-doc "Image") - (send dc start-page) - (((gui-eval 'make-pict-drawer) v) dc 0 0) - (send dc end-page) - (send dc end-doc) - (system (format "epstopdf ~a" (path-replace-suffix fn #".ps")))) - (let* ([bm (make-object (gui-eval 'bitmap%) - (inexact->exact (ceiling ((gui-eval 'pict-width) v))) - (inexact->exact (ceiling ((gui-eval 'pict-height) v))))] - [dc (make-object (gui-eval 'bitmap-dc%) bm)]) - (send dc set-smoothing 'aligned) - (send dc clear) - (((gui-eval 'make-pict-drawer) v) dc 0 0) - (send bm save-file fn 'png) - (make-image-element - #f - (list "[image]") - ;; Be sure to use a string rather than a path, because - ;; it gets recorded in "exprs.dat". - (path->string (path-replace-suffix fn #"")) - '(".pdf" ".png") - 1.0)))] - [(pair? v) (cons (fixup-picts (car v)) - (fixup-picts (cdr v)))] - [(serializable? v) v] - [else (make-element #f (list (format "~s" v)))])) +(define (fixup-picts predicate? render get-width get-height v) + (let loop ([v v]) + (cond + [(predicate? v) + (let ([fn (build-string-path img-dir + (format "img~a.png" image-counter))]) + (set! image-counter (add1 image-counter)) + (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))]) + (send pss set-mode 'file) + (send pss set-file (path-replace-suffix fn #".ps")) + (parameterize ([(gui-eval 'current-ps-setup) pss]) + (make-object (gui-eval 'post-script-dc%) #f)))]) + (send dc start-doc "Image") + (send dc start-page) + (render v dc 0 0) + (send dc end-page) + (send dc end-doc) + (system (format "epstopdf ~a" (path-replace-suffix fn #".ps")))) + (let* ([bm (make-object (gui-eval 'bitmap%) + (inexact->exact (ceiling (get-width v))) + (inexact->exact (ceiling (get-height v))))] + [dc (make-object (gui-eval 'bitmap-dc%) bm)]) + (send dc set-smoothing 'aligned) + (send dc clear) + (render v dc 0 0) + (send bm save-file fn 'png) + (make-image-element + #f + (list "[image]") + ;; Be sure to use a string rather than a path, because + ;; it gets recorded in "exprs.dat". + (path->string (path-replace-suffix fn #"")) + '(".pdf" ".png") + 1.0)))] + [(pair? v) (cons (loop (car v)) + (loop (cdr v)))] + [(serializable? v) v] + [else (make-element #f (list (format "~s" v)))])))