a bunch of little fixes to the 2htdp/image library (and related) for sfp submission:
- added in the htdp/image version of the performance test case - made gui-eval work with things other than slideshow - extended render-image so that it works on bitmaps and image-snips
This commit is contained in:
Robby Findler
parent
0e664e7c0b
commit
22bc8f6d87
900
collects/2htdp/tests/image-equality-performance-htdp.rkt
Normal file
900
collects/2htdp/tests/image-equality-performance-htdp.rkt
Normal file
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
#'(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,6 +65,7 @@
|
|||
(if mred?
|
||||
(let ([eh (scribble-eval-handler)]
|
||||
[log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
|
||||
(λ (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)
|
||||
|
|
@ -60,8 +74,11 @@
|
|||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(make-gui-exn (exn-message exn)))])
|
||||
(eh ev catching-exns? expr))])
|
||||
(let ([result (fixup-picts result)])
|
||||
;; 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,6 +91,7 @@
|
|||
(lambda (exn)
|
||||
(open-input-string ""))])
|
||||
(open-input-file exprs-dat-file))])
|
||||
(λ (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?
|
||||
|
|
@ -98,16 +116,17 @@
|
|||
(error 'mreval
|
||||
"expression does not match log file: ~e versus: ~e"
|
||||
expr
|
||||
v))))))))))
|
||||
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)
|
||||
(define (fixup-picts predicate? render get-width get-height v)
|
||||
(let loop ([v v])
|
||||
(cond
|
||||
[((gui-eval 'pict?) v)
|
||||
[(predicate? v)
|
||||
(let ([fn (build-string-path img-dir
|
||||
(format "img~a.png" image-counter))])
|
||||
(set! image-counter (add1 image-counter))
|
||||
|
|
@ -118,17 +137,17 @@
|
|||
(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)
|
||||
(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 ((gui-eval 'pict-width) v)))
|
||||
(inexact->exact (ceiling ((gui-eval 'pict-height) v))))]
|
||||
(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)
|
||||
(((gui-eval 'make-pict-drawer) v) dc 0 0)
|
||||
(render v dc 0 0)
|
||||
(send bm save-file fn 'png)
|
||||
(make-image-element
|
||||
#f
|
||||
|
|
@ -138,7 +157,7 @@
|
|||
(path->string (path-replace-suffix fn #""))
|
||||
'(".pdf" ".png")
|
||||
1.0)))]
|
||||
[(pair? v) (cons (fixup-picts (car v))
|
||||
(fixup-picts (cdr v)))]
|
||||
[(pair? v) (cons (loop (car v))
|
||||
(loop (cdr v)))]
|
||||
[(serializable? v) v]
|
||||
[else (make-element #f (list (format "~s" v)))]))
|
||||
[else (make-element #f (list (format "~s" v)))])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user