From 4bce35f0a437ec75c4dcff4203e38a8c42decf57 Mon Sep 17 00:00:00 2001 From: Stephen Bloch Date: Thu, 30 Dec 2010 06:55:08 -0500 Subject: [PATCH] Changes to documentation and require/provide lines to get "raco setup" to work smoothly. Deleted compiled code and backup files, as well as tests that were just copied from universe. --- collects/picturing-programs/book-pictures.rkt | 4 +- collects/picturing-programs/doc.html | 56 - collects/picturing-programs/doc.scrbl | 211 ++- collects/picturing-programs/info.rkt | 3 +- collects/picturing-programs/io-stuff.rkt | 2 +- collects/picturing-programs/main.rkt | 28 +- collects/picturing-programs/map-image.rkt | 122 +- .../picturing-programs/scribble-common.js | 153 -- .../picturing-programs/scribble-style.css | 0 collects/picturing-programs/scribble.css | 429 ----- collects/picturing-programs/tests/README | 11 - collects/picturing-programs/tests/bad-draw.ss | 12 - collects/picturing-programs/tests/balls.ss | 87 - collects/picturing-programs/tests/design.txt | 34 - .../tests/full-scene-visible.ss | 15 - .../tests/image-equality-performance.ss | 908 ---------- .../tests/install-teachpack.ss | 2 - .../tests/map-image-bsl-tests.rkt | 23 +- .../picturing-programs/tests/perform-robby.ss | 21 - collects/picturing-programs/tests/player | 15 - .../picturing-programs/tests/profile-robby.ss | 18 - .../tests/robby-optimization-gone.ss | 20 - .../tests/rotating-triangle.ss | 24 - collects/picturing-programs/tests/sam.ss | 7 - collects/picturing-programs/tests/shared.ss | 74 - collects/picturing-programs/tests/stop.ss | 21 - collects/picturing-programs/tests/stripes.rkt | 99 -- .../picturing-programs/tests/test-image.ss | 1561 ----------------- .../picturing-programs/tests/ufo-rename.ss | 15 - .../picturing-programs/tests/world0-stops.ss | 13 - collects/picturing-programs/tests/xrun | 3 - 31 files changed, 173 insertions(+), 3818 deletions(-) delete mode 100644 collects/picturing-programs/doc.html delete mode 100644 collects/picturing-programs/scribble-common.js delete mode 100644 collects/picturing-programs/scribble-style.css delete mode 100644 collects/picturing-programs/scribble.css delete mode 100644 collects/picturing-programs/tests/README delete mode 100644 collects/picturing-programs/tests/bad-draw.ss delete mode 100644 collects/picturing-programs/tests/balls.ss delete mode 100644 collects/picturing-programs/tests/design.txt delete mode 100644 collects/picturing-programs/tests/full-scene-visible.ss delete mode 100644 collects/picturing-programs/tests/image-equality-performance.ss delete mode 100644 collects/picturing-programs/tests/install-teachpack.ss delete mode 100644 collects/picturing-programs/tests/perform-robby.ss delete mode 100644 collects/picturing-programs/tests/player delete mode 100644 collects/picturing-programs/tests/profile-robby.ss delete mode 100644 collects/picturing-programs/tests/robby-optimization-gone.ss delete mode 100644 collects/picturing-programs/tests/rotating-triangle.ss delete mode 100644 collects/picturing-programs/tests/sam.ss delete mode 100644 collects/picturing-programs/tests/shared.ss delete mode 100644 collects/picturing-programs/tests/stop.ss delete mode 100644 collects/picturing-programs/tests/stripes.rkt delete mode 100644 collects/picturing-programs/tests/test-image.ss delete mode 100644 collects/picturing-programs/tests/ufo-rename.ss delete mode 100644 collects/picturing-programs/tests/world0-stops.ss delete mode 100644 collects/picturing-programs/tests/xrun diff --git a/collects/picturing-programs/book-pictures.rkt b/collects/picturing-programs/book-pictures.rkt index a9f98657d3..ca257bf2dd 100644 --- a/collects/picturing-programs/book-pictures.rkt +++ b/collects/picturing-programs/book-pictures.rkt @@ -1,9 +1,9 @@ -#lang racket +#lang racket/base ; Initial version, Dec. 13, 2010. ; Doesn't work with a literal image, but it works to use a "bitmap" ; reference to a file that's included with the teachpacks. Dec. 21, 2010. -(require 2htdp/image) +(require (only-in 2htdp/image bitmap)) (provide (all-defined-out)) diff --git a/collects/picturing-programs/doc.html b/collects/picturing-programs/doc.html deleted file mode 100644 index d4c2de466a..0000000000 --- a/collects/picturing-programs/doc.html +++ /dev/null @@ -1,56 +0,0 @@ - -Picturing Programs Teachpack
►Picturing Programs Teachpack
1 About This Teachpack
2 Installation
3 Functions from image.rkt and universe.rkt
4 New image functions
rotate-cw
rotate-ccw
rotate-180
crop-top
crop-bottom
crop-left
crop-right
show-it
reflect-vert
reflect-horiz
5 Pixel functions
5.1 Colors and pixels
name->color
get-pixel-color
5.2 Specifying the color of each pixel of an image
map-image
build-image
change-to-color
real->int
5.3 Transparency
pixel-visible?
maybe-color?
map-masked-image
build-masked-image
6 Input and Output
with-input-from-string
with-output-to-string
with-input-from-file
with-output-to-file
with-input-from-url
with-io-strings
Version: 5.0.0.6

Picturing Programs Teachpack

Stephen Bloch

 (require (planet sbloch/picturing-programs))

1 About This Teachpack

Provides a variety of functions for combining and manipulating images -and running interactive animations. -It’s intended to be used with the textbook -Picturing Programs.

2 Installation

If you’re reading this, you’ve probably already installed the teachpack successfully, -but if you need to install it on a different machine, ... -

  1. start DrScheme

  2. switch languages to “Use the language declared in the -source” and click “Run”

  3. in the Interactions pane, type -
      (require (planet sbloch/picturing-programs:2))

  4. after a few seconds, you should see the message

    Wrote file “picturing-programs.rkt” to installed-teachpacks directory.

  5. switch languages back to one of the HtDP languages, like Beginning Student

  6. either -

    • in the Definitions pane, type -
        (require installed-teachpacks/picturing-programs)
      or

    • from the Language menu, choose "Add -Teachpack..." and select "picturing-programs.rkt"

  7. click "Run"

3 Functions from image.rkt and universe.rkt

This package includes all of -the image teachpack and -and -the universe teachpack, -so if you’re using this teachpack, don’t also load either of those. -See the above links for how to use those teachpacks.

It also supersedes the older tiles and sb-world teachpacks, -so if you have those, don’t load them either; use this instead.

This package also provides the following additional functions:

4 New image functions

(rotate-cw img) → image?
  img : image?
Rotates an image 90 degrees clockwise.

(rotate-ccw img) → image?
  img : image?
Rotates an image 90 degrees counterclockwise.

(rotate-180 img) → image?
  img : image?
Rotates an image 180 degrees around its center.

(crop-top img pixels) → image?
  img : image?
  pixels : natural-number/c
Chops off the specified number of pixels from the top of the image.

(crop-bottom img pixels) → image?
  img : image?
  pixels : natural-number/c
Chops off the specified number of pixels from the bottom of the image.

(crop-left img pixels) → image?
  img : image?
  pixels : natural-number/c
Chops off the specified number of pixels from the left side of the image.

(crop-right img pixels) → image?
  img : image?
  pixels : natural-number/c
Chops off the specified number of pixels from the right side of the image.

(show-it img) → image?
  img : image?
Returns the given image unaltered. Useful as a draw handler for animations whose model is an image.

(reflect-vert img) → image?
  img : image?
The same as flip-vertical; retained for compatibility.

(reflect-horiz img) → image?
  img : image?
The same as flip-horizontal; retained for compatibility.

5 Pixel functions

The above functions allow you to operate on a picture as a whole, but sometimes -you want to manipulate a picture pixel-by-pixel.

5.1 Colors and pixels

(name->color name) → (or/c color? false/c)
  name : string?
Given a color name like "red", "turquoise", "forest green", etc., returns the corresponding -color struct, showing the red, green, and blue components. If the name isn’t -recognized, returns false.

(get-pixel-color x y pic) → color?
  x : natural-number/c
  y : natural-number/c
  pic : image?
Gets the color of a specified pixel in the given image. If x and/or y are outside the -bounds of the image, returns black.

5.2 Specifying the color of each pixel of an image

(map-image f img) → image?
  f : (-> natural-number/c natural-number/c color? color?)
  img : image?
Applies the given function to each pixel in a given image, producing a new image the same -size and shape. For example, -
  (define (lose-red x y old-color)
    (make-color 0 (color-green old-color) (color-blue old-color)))
  
  (map-image lose-red my-picture)
produces a copy of my-picture with all the red leached out, -leaving only the blue and green components.

  (define (apply-gradient x y old-color)
    (make-color (min (* 3 x) 255) 0 (min (* 3 y) 255)))
  
  (map-image apply-gradient my-picture)
produces a picture the same size and shape as my-picture, -but with a smooth color gradient with red increasing from left to -right and blue increasing from top to bottom.

(build-image width height f) → image?
  width : natural-number/c
  height : natural-number/c
  f : (-> natural-number/c natural-number/c color?)
Builds an image of the specified size and shape by calling the specified function -on the coordinates of each pixel. For example, -
  (define (fuzz pic)
    (local [(define (near-pixel x y)
              (get-pixel-color (+ x -3 (random 7))
                               (+ y -3 (random 7))
                               pic))]
      (build-image (image-width pic)
                   (image-height pic)
                   near-pixel)))
produces a fuzzy version of the given picture by replacing each pixel with a -randomly chosen pixel near it.

(change-to-color new-color)
 → (->* (natural-number/c natural-number/c) (color?) color?)
  new-color : (or/c string? color?)
Returns a constant-valued function suitable for use in map-image or build-image. -The input to change-to-color may be either a color struct or a color name from -the standard color-name database. For example, -
  (map-image (change-to-color "turquoise") my-picture)
returns a picture with the same size, shape, and mask as my-picture, but all turquoise, while -
  (build-image 50 30 (change-to-color (make-color 0 100 200)))
is equivalent to (rectangle 50 30 "solid" (make-color 0 100 200))

(real->int num) → integer?
  num : real?
Not specific to colors, but useful if you’re building colors by arithmetic. -For example, -
  (define (bad-gradient x y)
    (make-color (* 2.5 x) (* 1.6 y) 0))
  (build-image 50 30 bad-gradient)
  (define (good-gradient x y)
    (make-color (real->int (* 2.5 x)) (real->int (* 1.6 y)) 0))
  (build-image 50 30 good-gradient)
The version using bad-gradient crashes because color components must be exact integers. -The version using good-gradient works.

5.3 Transparency

Some image formats support transparency, meaning that part of the image is -ignored when layering it with other images.

(pixel-visible? x y pic) → boolean?
  x : natural-number/c
  y : natural-number/c
  pic : image?
Checks transparency: returns false if the specified pixel in the image is transparent, -true if not.

A maybe-color is either a color or false, which is treated as transparent.

(maybe-color? thing) → boolean?
  thing : any/c
Tests whether the argument is a maybe-color.

(map-masked-image f pic) → image?
  f : (-> natural-number/c natural-number/c maybe-color? maybe-color?)
  pic : image?
Like map-image, but the function will receive false for any transparent pixel, and -any place that it returns false will be treated as a transparent pixel.

(build-masked-image width height f) → image?
  width : natural-number/c
  height : natural-number/c
  f : (-> natural-number/c natural-number/c maybe-color?)
Like build-image, but any place that the function returns false will be treated -as a transparent pixel.

6 Input and Output

This teachpack also provides several functions to help in testing -I/O functions (in Advanced Student language; ignore this section if -you’re in a Beginner or Intermediate language):

(with-input-from-string input thunk) → any/c
  input : string?
  thunk : (-> any/c)
Calls thunk, which presumably uses read, -in such a way that read reads from input rather than from -the keyboard.

(with-output-to-string thunk) → string?
  thunk : (-> any/c)
Calls thunk, which presumably uses display, print, -write, and/or printf, in such a way that its output is -accumlated into a string, which is then returned.

(with-input-from-file filename thunk) → any/c
  filename : string?
  thunk : (-> any/c)
Calls thunk, which presumably uses read, -in such a way that read reads from the specified file -rather than from the keyboard.

(with-output-to-file filename thunk) → any/c
  filename : string?
  thunk : (-> any/c)
Calls thunk, which presumably uses display, print, -write, and/or printf, in such a way that its output is -redirected into the specified file.

(with-input-from-url url thunk) → any/c
  url : string?
  thunk : (-> any/c)
Calls thunk, which presumably uses read, -in such a way that read reads from the HTML source of the -Web page at the specified URL rather than from the keyboard.

(with-io-strings input thunk) → string?
  input : string?
  thunk : (-> any/c)
Combines with-input-from-string and with-output-to-string: -calls thunk with its input coming from input and accumulates -its output into a string, which is returned. Especially useful for testing: -
  (define (ask question)
    (begin (display question)
           (read)))
  (define (greet)
    (local [(define name (ask "What is your name?"))]
      (printf "Hello, ~a!" name)))
  (check-expect
   (with-io-strings "Steve" greet)
   "What is your name?Hello, Steve!")

 
\ No newline at end of file diff --git a/collects/picturing-programs/doc.scrbl b/collects/picturing-programs/doc.scrbl index 505eff0870..5ff204293d 100644 --- a/collects/picturing-programs/doc.scrbl +++ b/collects/picturing-programs/doc.scrbl @@ -1,11 +1,12 @@ -#lang scribble/manual +#lang scribble/doc @(require + scribble/manual (for-label racket - "main.rkt" - "io-stuff.rkt" - ; "sb-universe.rkt" - "tiles.rkt" - "map-image.rkt" + picturing-programs/main + ;picturing-programs/io-stuff + ;picturing-programs/tiles + ;picturing-programs/dummy + ; picturing-programs/map-image 2htdp/image teachpack/2htdp/universe (only-in lang/htdp-beginner check-expect) @@ -16,19 +17,20 @@ @author{Stephen Bloch} @; defmodule[installed-teachpack/picturing-programs] -@defmodule[(planet sbloch/picturing-programs)] +@defmodule[picturing-programs] @section{About This Teachpack} @;Testing, testing: @racket[(list 'testing 1 2 3)]. @; -@;This is a reference to the @racket[list] function. -@;Now a reference to @racket[triangle], -@;and @racket[big-bang], -@;and @racket[show-it], -@;and @racket[crop-top], -@;and @racket[map-image], -@;and @racket[with-input-from-url], +@;This is a reference to the @racket[list] function (which is a nice link). +@;Now a reference to @racket[triangle] (good link), +@;and @racket[big-bang] (good link), +@;and @racket[show-it] (good link), +@;and @racket[crop-top] (underlined in red, not a link), +@;and @racket[map-image] (underlined in red, not a link), +@;and @racket[dummyvar] (how does this look?), +@;and @racket[with-input-from-url] (underlined in red, not a link), @;which are defined in several different places. Provides a variety of functions for combining and manipulating images @@ -46,7 +48,7 @@ This package includes all of @racketmodlink[2htdp/image]{the image teachpack} and and @racketmodlink[2htdp/universe]{the universe teachpack}, -so if you're using this teachpack, @emph{don't} also load either of those. +so if you're using this teachpack, @italic{don't} also load either of those. See the above links for how to use those teachpacks. It also supersedes the older @racket[tiles] and @racket[sb-world] teachpacks, @@ -114,18 +116,46 @@ you want to manipulate a picture pixel-by-pixel. @subsection{Colors and pixels} -@defproc[(name->color [name string?]) - (or/c color? false/c)]{ +Each pixel of a bitmap image has a @racket[color], a built-in structure with +four components -- red, green, blue, and alpha -- each represented by an +integer from 0 to 255. Larger alpha values are "more opaque": an image with +alpha=255 is completely opaque, and one with alpha=0 is completely +transparent. -Given a color name like "red", "turquoise", "forest green", @italic{etc.}, returns the corresponding -color struct, showing the red, green, and blue components. If the name isn't +Even if you're not trying to get transparency effects, alpha is also used +for dithering to smooth out jagged edges. In +@racket[(circle 50 "solid" "red")], the pixels inside the circle are pure +red, with alpha=255; the pixels outside the circle are transparent (alpha=0); +and the pixels on the boundary are red with various alpha values (for example, +if one quarter of a pixel's area is inside +the mathematical boundary of the circle, that pixel's alpha value will be +63). + +@defproc[(name->color [name (or/c string? symbol?)]) + (or/c color? false/c)]{ +Given a color name like "red", 'turquoise, "forest green", @italic{etc.}, returns the corresponding +color struct, showing the red, green, blue, and alpha components. If the name isn't recognized, returns @racket[false].} +@defproc[(colorize [thing (or/c color? string? symbol? false/c)]) + (or/c color? false/c)]{ +Similar to @racket[name->color], but accepts colors and @racket[false] as +well: colors produce themselves, while @racket[false] produces a transparent +color.} + +@defproc[(color=? [c1 (or/c color? string? symbol? false/c)] + [c2 (or/c color? string? symbol? false/c)]) + boolean?]{ +Compares two colors for equality. As with @racket[colorize], treats +@racket[false] as a transparent color (i.e. with an alpha-component of 0). +All colors with alpha=0 are considered equal to one another, even if they have +different red, green, or blue components.} + @defproc[(get-pixel-color [x natural-number/c] [y natural-number/c] [pic image?]) color?]{ -Gets the color of a specified pixel in the given image. If x and/or y are outside the -bounds of the image, returns black.} +Gets the color of a specified pixel in the given image. If x and/or y are outside +the bounds of the image, returns a transparent color.} @subsection{Specifying the color of each pixel of an image} @defproc[(build-image [width natural-number/c] @@ -148,14 +178,24 @@ on the coordinates of each pixel. For example, produces a fuzzy version of the given picture by replacing each pixel with a randomly chosen pixel near it.} +@defproc[(build4-image [width natural-number/c] [height natural-number/c] + [red-function (-> natural-number/c natural-number/c natural-number/c)] + [green-function (-> natural-number/c natural-number/c natural-number/c)] + [blue-function (-> natural-number/c natural-number/c natural-number/c)] + [alpha-function (-> natural-number/c natural-number/c +natural-number/c)]) + image?]{ +A version of @racket[build-image] for students who don't know about structs yet. +Each of the four functions takes in the x and y coordinates of a pixel, and +should return an integer from 0 through 255 to determine that color component.} + @defproc[(build3-image [width natural-number/c] [height natural-number/c] [red-function (-> natural-number/c natural-number/c natural-number/c)] [green-function (-> natural-number/c natural-number/c natural-number/c)] [blue-function (-> natural-number/c natural-number/c natural-number/c)]) image?]{ -A version of @racket[build-image] for students who don't know about structs yet. -Each of the three functions takes in the x and y coordinates of a pixel, and -should return an integer from 0 through 255 to determine that color component.} +Just like @racket[build4-image], but without specifying the alpha component +(which defaults to 255, fully opaque).} @defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?]) image?]{ @@ -170,49 +210,97 @@ size and shape. For example, produces a copy of @racket[my-picture] with all the red leached out, leaving only the blue and green components. +Since @racket[make-color] with three arguments defaults alpha to 255, +this function discards any alpha information (including edge-dithering) +that was in the original image. To preserve this information, one could write +@racketblock[ +(define (lose-red-but-not-alpha x y old-color) + (make-color 0 (color-green old-color) (color-blue old-color) (color-alpha +old-color)))] + +Another example: @racketblock[ (define (apply-gradient x y old-color) - (make-color (min (* 3 x) 255) 0 (min (* 3 y) 255))) + (make-color (min (* 3 x) 255) + 0 + (min (* 3 y) 255))) (map-image apply-gradient my-picture)] -produces a picture the same size and shape as @racket[my-picture], -but with a smooth color gradient with red increasing from left to +produces a picture the size of @racket[my-picture]'s bounding rectangle, +with a smooth color gradient with red increasing from left to right and blue increasing from top to bottom.} -@defproc[(map3-image +@defproc[(map4-image +[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] +[green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] +[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] +[alpha-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] +[img image?]) +image?]{ + +A version of map-image for students who don't know about structs yet. Each of the +four given functions is assumed to have the contract +@racketblock[num(x) num(y) num(r) num(g) num(b) num(alpha) -> num] +For each pixel in the original picture, applies the four +functions to the x coordinate, y coordinate, red, green, blue, and alpha +components of the pixel. +The results of the four functions are used as the red, green, blue, and alpha +components in the corresponding pixel of the resulting picture. + +For example, +@racketblock[ +(define (zero x y r g b a) 0) +(define (same-g x y r g b a) g) +(define (same-b x y r g b a) b) +(define (same-alpha x y r g b a) a) +(map4-image zero same-g same-b same-alpha my-picture)] +produces a copy of @racket[my-picture] with all the red leached out, +leaving only the blue, green, and alpha components. + +@racketblock[ +(define (3x x y r g b a) (min (* 3 x) 255)) +(define (3y x y r g b a) (min (* 3 y) 255)) +(define (return-255 x y r g b a) 255) +(map4-image 3x zero 3y return-255 my-picture)] +produces an opaque picture the size of @racket[my-picture]'s bounding rectangle, +with a smooth color gradient with red increasing from left to +right and blue increasing from top to bottom. +} + +@defproc[(map3-image [red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] [green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] [blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] [img image?]) image?]{ +Like @racket[map4-image], but not specifying the alpha component. Note that +the red, green, and blue functions also @italic{don't take in} alpha values. +Each of the three given functions is assumed to have the contract +@racketblock[num(x) num(y) num(r) num(g) num(b) -> num] +For each pixel in the original picture, applies the three functions to the x +coordinate, y coordinate, red, green, and blue components of the pixel. +The results are used as a the red, green, and blue components in the +corresponding pixel of the resulting picture. -A version of map-image for students who don't know about structs yet. Each of the three given functions is assumed -to have the contract @racketblock[num(x) num(y) num(r) num(g) num(b) -> num ] -For each pixel in the original picture, applies the three -functions to the x coordinate, y coordinate, red, green, and blue components of the picture. -The result of the first function is used as the red component, the second as green, and the third as blue -in the corresponding pixel of the resulting picture. - -For example, +The alpha component in the resulting picture is copied from the source +picture. For example, @racketblock[ (define (zero x y r g b) 0) (define (same-g x y r g b) g) (define (same-b x y r g b) b) (map3-image zero same-g same-b my-picture)] -produces a copy of @racket[my-picture] with all the red leached out, -leaving only the blue and green components. - +produces a copy of @racket[my-picture] with all the red leached out; parts of +the picture that were transparent are still transparent, and parts that were +dithered are still dithered. @racketblock[ -(define (3x x y r g b) (min (* 3 x) 255)) -(define (3y x y r g b) (min (* 3 y) 255)) -(map3-image 3x zero 3y my-picture)] -produces a picture the same size and shape as @racket[my-picture], -but with a smooth color gradient with red increasing from left to -right and blue increasing from top to bottom.} +(define (3x x y r g b a) (min (* 3 x) 255)) +(define (3y x y r g b a) (min (* 3 y) 255)) +(map3-image zero 3x 3y my-picture)] +produces a @racket[my-picture]-shaped "window" on a color-gradient. +} @defproc[(real->int [num real?]) integer?]{ - Not specific to colors, but useful if you're building colors by arithmetic. For example, @racketblock[ @@ -227,37 +315,6 @@ The version using @racket[bad-gradient] crashes because color components must be The version using @racket[good-gradient] works.} -@subsection{Transparency} -Some image formats support @italic{transparency}, meaning that part of the image is -ignored when layering it with other images. - -@defproc[(pixel-visible? [x natural-number/c] [y natural-number/c] [pic image?]) - boolean?]{ - -Checks transparency: returns @racket[false] if the specified pixel in the image is transparent, -@racket[true] if not.} - -A @deftech{maybe-color} is either a color or @racket[false], which is treated as transparent. - -@defproc[(maybe-color? [thing any/c]) - boolean?]{ - -Tests whether the argument is a @tech{maybe-color}.} - -@defproc[(map-masked-image [f (-> natural-number/c natural-number/c maybe-color? maybe-color?)] [pic image?]) - image?]{ - -Like @racket[map-image], but the function will receive @racket[false] for any transparent pixel, and -any place that it returns @racket[false] will be treated as a transparent pixel.} - -@defproc[(build-masked-image [width natural-number/c] - [height natural-number/c] - [f (-> natural-number/c natural-number/c maybe-color?)]) - image?]{ - -Like @racket[build-image], but any place that the function returns @racket[false] will be treated -as a transparent pixel.} - @section{Input and Output} This teachpack also provides several functions to help in testing I/O functions (in Advanced Student language; ignore this section if diff --git a/collects/picturing-programs/info.rkt b/collects/picturing-programs/info.rkt index 3d1da14c09..5444c77a3b 100644 --- a/collects/picturing-programs/info.rkt +++ b/collects/picturing-programs/info.rkt @@ -10,7 +10,8 @@ `("The picturing-programs collection supersedes the tiles and sb-world collections. It provides functions to rotate, etc. images, as well as a slightly modified version of the universe teachpack.")) (define release-notes '( (p "Version 2.5: Re-enabled diagonal reflection. Moved into the bundle -(so it doesn't require a PLaneT install). Added some picture variables.") +(so it doesn't require a PLaneT install). Added some picture variables. +Rewrote a bunch of things for compatibility with 5.1.") (p "Version 2.4: Added change-to-color and map3-image. Cleaned up documentation.") (p "Version 2.3: Renamed files from .ss to .rkt, so they work better with Racket. Added map-image, build-image, name->color, and friends; re-fixed bug in rotate-cw and rotate-ccw.") (p "Version 2.2: Fixed bug in rotate-cw and rotate-ccw; restored reflect-vert and reflect-horiz; added with-input-from-url.") diff --git a/collects/picturing-programs/io-stuff.rkt b/collects/picturing-programs/io-stuff.rkt index f5141e6064..5996b855a7 100644 --- a/collects/picturing-programs/io-stuff.rkt +++ b/collects/picturing-programs/io-stuff.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require racket/port lang/error net/url) (provide with-input-from-string with-output-to-string diff --git a/collects/picturing-programs/main.rkt b/collects/picturing-programs/main.rkt index 6422d398c9..5565cc45a3 100644 --- a/collects/picturing-programs/main.rkt +++ b/collects/picturing-programs/main.rkt @@ -1,18 +1,18 @@ -#lang racket +#lang racket/base (require 2htdp/universe - htdp/error ; check-arg - "tiles.rkt" - "io-stuff.rkt" - "map-image.rkt" - "book-pictures.rkt") -(provide (all-from-out "tiles.rkt") ; includes all-from-out 2htdp/image, plus a few simple add-ons - (all-from-out "io-stuff.rkt") ; includes with-{input-from,output-to}-{string,file}, with-io-strings - (all-from-out "map-image.rkt") ; includes (map,build)-[masked-]image, real->int, maybe-color?, name->color, - ; get-pixel-color, pixel-visible? - (prefix-out pic: (all-from-out "book-pictures.rkt")) ; pic:calendar, pp:hacker, etc. - ) -(provide show-it) -(provide (all-from-out 2htdp/universe)) + (only-in htdp/error check-arg) + picturing-programs/tiles + picturing-programs/io-stuff + picturing-programs/map-image + picturing-programs/book-pictures) + +(provide (all-from-out picturing-programs/tiles) ; includes all-from-out 2htdp/image, plus a few simple add-ons + (all-from-out picturing-programs/io-stuff) ; includes with-{input-from,output-to}-{string,file}, with-io-strings + (all-from-out picturing-programs/map-image) + ; includes (map,build)(3,4,)-image, real->int, name->color, colorize, get-pixel-color + (prefix-out pic: (all-from-out picturing-programs/book-pictures)) ; pic:calendar, pp:hacker, etc. + (all-from-out 2htdp/universe) + show-it) (define (show-it img) diff --git a/collects/picturing-programs/map-image.rkt b/collects/picturing-programs/map-image.rkt index 3cbc391b25..3e78913bc1 100644 --- a/collects/picturing-programs/map-image.rkt +++ b/collects/picturing-programs/map-image.rkt @@ -14,8 +14,9 @@ racket/snip racket/class 2htdp/image + (only-in htdp/error natural?) (only-in mrlib/image-core render-image)) -(require picturing-programs/book-pictures) +;(require picturing-programs/book-pictures) ;(require mrlib/image-core) ;(require 2htdp/private/image-more) @@ -94,10 +95,10 @@ (compose colorize f)) -; natural? : anything -> boolean -(define (natural? it) - (and (integer? it) - (>= it 0))) +;; natural? : anything -> boolean +;(define (natural? it) +; (and (integer? it) +; (>= it 0))) ; color=? : broad-color broad-color -> boolean (define (color=? c1 c2) @@ -111,95 +112,6 @@ (= (color-green rc1) (color-green rc2)) (= (color-blue rc1) (color-blue rc2))))))) -;; build-image-internal : nat(width) nat(height) (nat nat -> color) bitmap% -> image -;(define (build-image-internal width height f mask-bm) -;; (unless (and (natural? width) (natural? height)) -;; (error 'build-image "Expected natural numbers as first two arguments")) -;; (unless (procedure-arity-includes? f 2) -;; (error 'build-image "Expected function with contract number number -> color as third argument")) -; (let* [[bm (make-bitmap width height)] -; [bmdc (make-object bitmap-dc% bm)] -; ] -; (for* ((y (in-range height)) -; (x (in-range width))) -; (send bmdc set-pixel x y (color->color% (f x y))) -; )) -; (send bmdc set-bitmap #f) -; (make-image -; (make-translate (quotient width 2) (quotient height 2) -; (make-bitmap bm mask-bm 0 1 1 #f #f)) -; (make-bb width height height) -; #f ; not normalized -; ) -; ) - -;; build-image : natural(width) natural(height) (nat nat -> color) -> image -;(define (build-image width height f) -; (unless (and (natural? width) (natural? height)) -; (error 'build-image "Expected natural numbers as first two arguments")) -; (unless (procedure-arity-includes? f 2) -; (error 'build-image "Expected function with contract number number -> color as third argument")) -; (if (or (zero? width) (zero? height)) ; bitmap% doesn't like zero-sized images -; (rectangle width height "solid" "white") -; (let* [[mask-bm (make-object bitmap% width height #t)] ; monochrome -; [mask-bmdc (make-object bitmap-dc% mask-bm)] -; [black (make-object color% 0 0 0)]] -; (send mask-bmdc set-background black) -; (send mask-bmdc clear) -; ; (for ((y (in-range height))) -; ; (for ((x (in-range width))) -; ; (send mask-bmdc set-pixel x y black))) -; ; can we replace this with (send mask-bmdc clear)? -; (send mask-bmdc set-bitmap #f) -; (build-image-internal width height f mask-bm) -; ) -; ) -; ) -; -;; build3-image: nat(width) nat(height) (nat nat -> nat) (nat nat -> nat) (nat nat -> nat) -> image -;(define (build3-image width height rfunc gfunc bfunc) -; (unless (and (natural? width) (natural? height)) -; (error 'build3-image "Expected natural numbers as first two arguments")) -; (unless (procedure-arity-includes? rfunc 2) -; (error 'build3-image "Expected function with contract number number -> number as third argument")) -; (unless (procedure-arity-includes? gfunc 2) -; (error 'build3-image "Expected function with contract number number -> number as fourth argument")) -; (unless (procedure-arity-includes? bfunc 2) -; (error 'build3-image "Expected function with contract number number -> number as fifth argument")) -; (build-image width height -; (lambda (x y) (make-color (rfunc x y) (gfunc x y) (bfunc x y))))) -; -;; build-masked-image : nat(width) nat(height) (nat nat -> maybe-color) -> image -;(define (build-masked-image width height f) -; (unless (and (natural? width) (natural? height)) -; (error 'build-masked-image "Expected natural numbers as first two arguments")) -; (unless (procedure-arity-includes? f 2) -; (error 'build-masked-image "Expected function with contract number number -> maybe-color as third argument")) -; (if (or (zero? width) (zero? height)) ; bitmap% doesn't like zero-sized images -; (rectangle width height "solid" "white") -; (let* [[bm (make-object bitmap% width height)] -; [bmdc (make-object bitmap-dc% bm)] -; [mask-bm (make-object bitmap% width height #t)] ; monochrome -; [mask-bmdc (make-object bitmap-dc% mask-bm)] -; [visible (make-object color% 0 0 0)] -; [transparent (make-object color% 255 255 255)]] -; (for ((y (in-range height))) -; (for ((x (in-range width))) -; (let* [[mc (f x y)] -; [color (if mc (color->color% mc) transparent)] -; [mask (if mc visible transparent)]] -; (send bmdc set-pixel x y color) -; (send mask-bmdc set-pixel x y mask) -; ))) -; (send bmdc set-bitmap #f) -; (send mask-bmdc set-bitmap #f) -; (make-image -; (make-translate (quotient width 2) (quotient height 2) -; (make-bitmap bm mask-bm 0 1 1 #f #f)) -; (make-bb width height height) -; #f ; not normalized -; ) -; ))) @@ -401,25 +313,3 @@ (bfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c)) (afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c)))) pic)) - - -;; map-masked-image : (int int maybe-color -> maybe-color) image -> image -;(define (map-masked-image f pic) -; (unless (procedure-arity-includes? f 3) -; (error 'map-masked-image "Expected function with contract number number maybe-color -> maybe-color as first argument")) -; (unless (image? pic) -; (error 'map-masked-image "Expected image as second argument")) -; (let* [[width (image-width pic)] -; [height (image-height pic)] -; [bm (make-object bitmap% width height)] -; [bmdc (make-object bitmap-dc% bm)] -; [mask (get-mask pic)] -; ] -; (render-image pic bmdc 0 0) -; (build-masked-image -; width height -; (lambda (x y) -; (f x y -; (if (pixel-visible? x y pic) -; (get-pixel-color x y pic) -; #f)))))) diff --git a/collects/picturing-programs/scribble-common.js b/collects/picturing-programs/scribble-common.js deleted file mode 100644 index 09c3390902..0000000000 --- a/collects/picturing-programs/scribble-common.js +++ /dev/null @@ -1,153 +0,0 @@ -// Common functionality for PLT documentation pages - -// Page Parameters ------------------------------------------------------------ - -var page_query_string = - (location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1; - -var page_args = - ((function(){ - if (!page_query_string) return []; - var args = page_query_string.split(/[&;]/); - for (var i=0; i= 0) args[i] = [a.substring(0,p), a.substring(p+1)]; - else args[i] = [a, false]; - } - return args; - })()); - -function GetPageArg(key, def) { - for (var i=0; i= 0 && cur.substring(0,eql) == key) - return unescape(cur.substring(eql+1)); - } - return def; -} - -function SetCookie(key, val) { - var d = new Date(); - d.setTime(d.getTime()+(365*24*60*60*1000)); - try { - document.cookie = - key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/"; - } catch (e) {} -} - -// note that this always stores a directory name, ending with a "/" -function SetPLTRoot(ver, relative) { - var root = location.protocol + "//" + location.host - + NormalizePath(location.pathname.replace(/[^\/]*$/, relative)); - SetCookie("PLT_Root."+ver, root); -} - -// adding index.html works because of the above -function GotoPLTRoot(ver, relative) { - var u = GetCookie("PLT_Root."+ver, null); - if (u == null) return true; // no cookie: use plain up link - // the relative path is optional, default goes to the toplevel start page - if (!relative) relative = "index.html"; - location = u + relative; - return false; -} - -// Utilities ------------------------------------------------------------------ - -normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/]; -function NormalizePath(path) { - var tmp, i; - for (i = 0; i < normalize_rxs.length; i++) - while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp; - return path; -} - -// `noscript' is problematic in some browsers (always renders as a -// block), use this hack instead (does not always work!) -// document.write(""); - -// Interactions --------------------------------------------------------------- - -function DoSearchKey(event, field, ver, top_path) { - var val = field.value; - if (event && event.keyCode == 13) { - var u = GetCookie("PLT_Root."+ver, null); - if (u == null) u = top_path; // default: go to the top path - u += "search/index.html?q=" + escape(val); - if (page_query_string) u += "&" + page_query_string; - location = u; - return false; - } - return true; -} - -function TocviewToggle(glyph, id) { - var s = document.getElementById(id).style; - var expand = s.display == "none"; - s.display = expand ? "block" : "none"; - glyph.innerHTML = expand ? "▼" : "►"; -} - -// Page Init ------------------------------------------------------------------ - -// Note: could make a function that inspects and uses window.onload to chain to -// a previous one, but this file needs to be required first anyway, since it -// contains utilities for all other files. -var on_load_funcs = []; -function AddOnLoad(fun) { on_load_funcs.push(fun); } -window.onload = function() { - for (var i=0; i - .techinside doesn't work with IE, so use both (and IE doesn't - work with inherit in the second one, so use blue directly) */ -.techinside { color: black; } -.techinside:hover { color: blue; } -.techoutside:hover>.techinside { color: inherit; } - -.SCentered { - text-align: center; -} - -.imageleft { - float: left; - margin-right: 0.3em; -} - -.Smaller{ - font-size: 82%; -} - -.Larger{ - font-size: 122%; -} - -/* A hack, inserted to break some Scheme ids: */ -.mywbr { - width: 0; - font-size: 1px; -} - -.compact li p { - margin: 0em; - padding: 0em; -} - -.noborder img { - border: 0; -} - -.SAuthorListBox { - position: relative; - float: right; - left: 2em; - top: -2.5em; - height: 0em; - width: 13em; - margin: 0em -13em 0em 0em; -} -.SAuthorList { - font-size: 82%; -} -.SAuthorList:before { - content: "by "; -} -.author { - display: inline; - white-space: nowrap; -} diff --git a/collects/picturing-programs/tests/README b/collects/picturing-programs/tests/README deleted file mode 100644 index 186b0113a4..0000000000 --- a/collects/picturing-programs/tests/README +++ /dev/null @@ -1,11 +0,0 @@ - -to test: $ ./xrun -to add a player: $ ./player Foo - -shared.ss : player infrastructure -carl.ss : one specific player derived from shared.ss -sam.ss : another one - -- add more with player plus string - -balls.ss : the server - diff --git a/collects/picturing-programs/tests/bad-draw.ss b/collects/picturing-programs/tests/bad-draw.ss deleted file mode 100644 index 6a9edb64b6..0000000000 --- a/collects/picturing-programs/tests/bad-draw.ss +++ /dev/null @@ -1,12 +0,0 @@ -#lang scheme - -(require picturing-programs) - -(define s "") -(define x 0) - -(with-handlers ((exn? void)) - (big-bang 0 - (on-tick (lambda (w) (begin (set! x (+ x 1)) w))) - (on-draw (lambda (w) (set! s (number->string w)))))) - diff --git a/collects/picturing-programs/tests/balls.ss b/collects/picturing-programs/tests/balls.ss deleted file mode 100644 index ea26770659..0000000000 --- a/collects/picturing-programs/tests/balls.ss +++ /dev/null @@ -1,87 +0,0 @@ -#lang scheme - -(require picturing-programs htdp/testing) - -;; rotate through a bunch of players with the ball until nobody is left - -;; ----------------------------------------------------------------------------- -;; Universe = [Listof IWorld] -;; BallMail = (make-mail IWorld 'go) -;; Result = (make-bundle [Listof IWorld] [Listof BallMail] '()) - -(define Result0 (make-bundle '() '() '())) - -;; ----------------------------------------------------------------------------- -;; [Listof IWorld] -> Result -;; create bundle with a singleton list of mails to the first world on the list -(define (mail2 lw) - (make-bundle lw (list (make-mail (first lw) 'go)) '())) - -;; ----------------------------------------------------------------------------- -;; Universe IWorld -> Result -;; add w to the list of worlds; get the first one to play - -(check-expect (add-world '() iworld1) (mail2 (list iworld1))) - -(define (add-world univ wrld) - (mail2 (append univ (list wrld)))) - -;; ----------------------------------------------------------------------------- -;; Universe IWorld Sexp -> Result -;; w sent message m in universe u - -(check-expect - (switch (list iworld1 iworld2) iworld1 'go) (mail2 (list iworld2 iworld1))) - -(check-error - (switch (list iworld1 iworld2) iworld2 'go) "switch: wrong world sent message") - -(check-error - (switch (list iworld2 iworld1) iworld2 'stop) "switch: bad message: stop") - -(define (switch u w m) - (local ((define fst (first u)) - (define nxt (append (rest u) (list fst)))) - (cond - [(and (iworld=? fst w) (symbol=? m 'go)) (mail2 nxt)] - [(iworld=? fst w) (error 'switch "bad message: ~s" m)] - [else (error 'switch "wrong world sent message")]))) - -;; ----------------------------------------------------------------------------- -;; [Listof IWorld] Universe IWorld -> Result -;; w disconnected from the universe - -(check-expect (disconnect (list iworld1 iworld2 iworld3) iworld2) - (mail2 (list iworld1 iworld3))) -(check-expect (disconnect '() iworld2) Result0) - -(define (disconnect u w) - (local ((define nxt (remq w u))) - (if (empty? nxt) Result0 (mail2 nxt)))) - -;; IWorld [Listof IWorld] -> [Listof IWorld] -;; remove w from low - -(check-expect (remq 'a '(a b c)) '(b c)) -(check-expect (remq 'a '(a b a c)) '(b c)) -(check-expect (remq 'b '(a b a c)) '(a a c)) - -(define (remq w low) - (cond - [(empty? low) '()] - [else (local ((define fst (first low)) - (define rst (remq w (rest low)))) - (if (eq? fst w) rst (cons fst rst)))])) - -;; -- run program run - -(test) - -(define (run _) - (universe '() - (on-new add-world) - (check-with list?) - (on-msg switch) - (on-disconnect disconnect))) - -(run 'go) diff --git a/collects/picturing-programs/tests/design.txt b/collects/picturing-programs/tests/design.txt deleted file mode 100644 index b163e5fb71..0000000000 --- a/collects/picturing-programs/tests/design.txt +++ /dev/null @@ -1,34 +0,0 @@ - - Two collaboration worlds display a moving ball, one of them should rest. - -Pass Through (Distributed) Version ----------------------------------- - - Two screens pop up and a ball moves from the bottom to the top, on each of - them. When one reaches the top, it rests and sends a signal to the other - to 'go. This means only one of the worlds will have a moving ball, the - other one rests. - - use ../pass-through.ss - - World and Messages: - ;; World = Number | 'resting - ;; Message = 'go - -Arbitrated Version ----------------------------------- - - Two screen pop up. The server sends one of them a go signal and the other - one a rest signal. Until then both move so I can use the same shared - code. - - use ball-universe.ss - - World and Messages: - ;; World = Number | 'resting - ;; ReceivedMessage = 'go - ;; SendMessages = ... any token will do ... - - Server: - ;; ReceivedMessages = ... any token will do ... - ;; SendMessages = 'go diff --git a/collects/picturing-programs/tests/full-scene-visible.ss b/collects/picturing-programs/tests/full-scene-visible.ss deleted file mode 100644 index b8bf9dc167..0000000000 --- a/collects/picturing-programs/tests/full-scene-visible.ss +++ /dev/null @@ -1,15 +0,0 @@ -#lang scheme/base - -(require picturing-programs - (prefix-in 2: 2htdp/image) - (prefix-in 1: htdp/image)) - -(define (see-full-rectangle x f) - (big-bang x - (on-tick sub1) - (stop-when zero?) - (on-draw (λ (x) (f 100 100 'outline 'black))))) - -(see-full-rectangle 3 2:rectangle) - -(see-full-rectangle 3 1:rectangle) diff --git a/collects/picturing-programs/tests/image-equality-performance.ss b/collects/picturing-programs/tests/image-equality-performance.ss deleted file mode 100644 index f398705024..0000000000 --- a/collects/picturing-programs/tests/image-equality-performance.ss +++ /dev/null @@ -1,908 +0,0 @@ -#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 picturing-programs - (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/picturing-programs/tests/install-teachpack.ss b/collects/picturing-programs/tests/install-teachpack.ss deleted file mode 100644 index faff902bb4..0000000000 --- a/collects/picturing-programs/tests/install-teachpack.ss +++ /dev/null @@ -1,2 +0,0 @@ -#lang scheme/base -(require (planet sbloch/picturing-programs:2)) \ No newline at end of file diff --git a/collects/picturing-programs/tests/map-image-bsl-tests.rkt b/collects/picturing-programs/tests/map-image-bsl-tests.rkt index b5911e43f2..1b65f2a3a3 100755 --- a/collects/picturing-programs/tests/map-image-bsl-tests.rkt +++ b/collects/picturing-programs/tests/map-image-bsl-tests.rkt @@ -1,7 +1,7 @@ ;; The first three lines of this file were inserted by DrRacket. They record metadata ;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) -(require picturing-programs) +#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ((lib "picturing-programs.rkt" "installed-teachpacks"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "picturing-programs.rkt" "installed-teachpacks"))))) + ; Test cases for primitives: (check-expect (real->int 3.2) 3) @@ -132,13 +132,13 @@ "tri:" tri "(map-image color-id tri):" (define ex1 (map-image color-id tri)) ex1 -"(map-image kill-red tri):" +"(map-image kill-red tri): should be green, on an opaque background with no red" (define ex2 (map-image kill-red tri)) ex2 "(map-image kill-red-preserving-alpha tri):" (define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime "(map-image make-gradient tri):" (define ex3 (map-image make-gradient tri)) ex3 -"(map-image kill-red hieroglyphics):" +"(map-image kill-red hieroglyphics): should be on an opaque background with no red" (define ex4 (map-image kill-red hieroglyphics)) ex4 "(map-image kill-red scheme-logo):" (define ex5 (map-image kill-red scheme-logo)) ex5 @@ -259,15 +259,20 @@ fuzzy-tri (make-gray (quotient (+ (color-red c) (color-green c) (color-blue c)) - 3))) + 3) + (color-alpha c))) -; make-gray : natural -> color -(define (make-gray n) - (make-color n n n)) +; make-gray : natural(value) natural(alpha) -> color +(define (make-gray value alpha) + (make-color value value value alpha)) ; color->gray : image -> image (define (color->gray pic) (map-image pixel->gray pic)) +"(color->gray bloch):" (color->gray bloch) -(color->gray hieroglyphics) +"(overlay (color->gray hieroglyphics) bluebox):" +(overlay (color->gray hieroglyphics) bluebox) +"(overlay (color->gray (white->trans hieroglyphics)) bluebox):" +(overlay (color->gray (white->trans hieroglyphics)) bluebox) \ No newline at end of file diff --git a/collects/picturing-programs/tests/perform-robby.ss b/collects/picturing-programs/tests/perform-robby.ss deleted file mode 100644 index 15f9503631..0000000000 --- a/collects/picturing-programs/tests/perform-robby.ss +++ /dev/null @@ -1,21 +0,0 @@ -#lang scheme -(require 2htdp/universe 2htdp/image) - -(define (slow) - (let sloop ([n (expt 2 22)]) - (unless (zero? n) - (sloop (- n 1))))) - -(define (update-world w) - (slow) - (- w 1)) - -(define (render w) - (circle 30 'solid (if (odd? w) 'red 'green))) - -(big-bang 10 - (on-tick update-world) - (on-draw render) - (stop-when zero?)) - -(printf "done\n") diff --git a/collects/picturing-programs/tests/player b/collects/picturing-programs/tests/player deleted file mode 100644 index 38d9e9e9e9..0000000000 --- a/collects/picturing-programs/tests/player +++ /dev/null @@ -1,15 +0,0 @@ -#! /bin/sh -#| -*- scheme -*- -exec mred -qu "$0" ${1+"$@"} -|# - -#lang scheme - -(require "shared.ss") - -(define argv (current-command-line-arguments)) - -(unless (= (vector-length argv) 1) - (error 'player "name of one player expected: $ ./player name")) - -(make-player 200 (vector-ref argv 0)) diff --git a/collects/picturing-programs/tests/profile-robby.ss b/collects/picturing-programs/tests/profile-robby.ss deleted file mode 100644 index ce1da9d02c..0000000000 --- a/collects/picturing-programs/tests/profile-robby.ss +++ /dev/null @@ -1,18 +0,0 @@ -#lang scheme/gui -(require profile - scheme/runtime-path) - -(define-runtime-path perform-robby "perform-robby.ss") - -(profile-thunk - (λ () - (parameterize ([current-eventspace (make-eventspace)]) - (let ([s (make-semaphore 0)]) - (queue-callback - (λ () - (dynamic-require perform-robby #f) - (semaphore-post s))) - (semaphore-wait s)))) - #:threads #t) - - diff --git a/collects/picturing-programs/tests/robby-optimization-gone.ss b/collects/picturing-programs/tests/robby-optimization-gone.ss deleted file mode 100644 index 528df04b92..0000000000 --- a/collects/picturing-programs/tests/robby-optimization-gone.ss +++ /dev/null @@ -1,20 +0,0 @@ -#lang scheme/gui - -(require 2htdp/universe) -(require 2htdp/image) - -(define s "") -(define x 1) - -(big-bang 1 - (on-tick (lambda (w) - (begin - (set! x (+ x 1)) - (if (= x 3) 0 1)))) - (stop-when zero?) - (on-draw (lambda (w) - (begin - (set! s (string-append "-" s)) - (rectangle 1 1 'solid 'green))))) - -(unless (string=? s "---") (error 'world-update-test "failed! ~s" s)) diff --git a/collects/picturing-programs/tests/rotating-triangle.ss b/collects/picturing-programs/tests/rotating-triangle.ss deleted file mode 100644 index 344c6f1fd3..0000000000 --- a/collects/picturing-programs/tests/rotating-triangle.ss +++ /dev/null @@ -1,24 +0,0 @@ -;; The first three lines of this file were inserted by DrRacket. They record metadata -;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-beginner-reader.ss" "lang")((modname rotating-triangle) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) -(require picturing-programs) - -(define R 60) -(define SIDE (* R (sqrt 3))) -(define TRI (triangle SIDE "solid" "blue")) -(define CIRC (circle R "solid" "white")) -(define tricirc (overlay/xy TRI - (- (/ SIDE 2) R) 0 - CIRC)) -(define badtricirc - (overlay/align "middle" "middle" - TRI - CIRC)) - -(define (rotate-1 pic) - (rotate 1 pic)) - -(big-bang badtricirc - (on-tick rotate-1 .05) - (check-with image?) - (on-draw show-it)) diff --git a/collects/picturing-programs/tests/sam.ss b/collects/picturing-programs/tests/sam.ss deleted file mode 100644 index 6ed9176f14..0000000000 --- a/collects/picturing-programs/tests/sam.ss +++ /dev/null @@ -1,7 +0,0 @@ -;; The first three lines of this file were inserted by DrScheme. They record metadata -;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname sam) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) -(require "shared.ss") -(require picturing-programs) - -(launch-many-worlds (make-player 200 "sam") (make-player 100 "carl")) diff --git a/collects/picturing-programs/tests/shared.ss b/collects/picturing-programs/tests/shared.ss deleted file mode 100644 index fff1a9093d..0000000000 --- a/collects/picturing-programs/tests/shared.ss +++ /dev/null @@ -1,74 +0,0 @@ -#lang scheme - -(require picturing-programs htdp/testing) -;(require "../2htdp/universe.ss" htdp/testing) - -;; World = Number | 'resting -(define WORLD0 'resting) - -;; constants -(define HEIGHT 100) -(define DefWidth 50) - -;; visual constants -(define BALL (circle 3 'solid 'red)) - -(define mt (nw:rectangle DefWidth HEIGHT 'solid 'gray)) - -;; ----------------------------------------------------------------------------- -;; Number (U String Symbol) -> true -;; create and hook up a player with the localhost server -(define (make-player width t) - (local ((define mt (place-image (text (format "~a" t) 11 'black) - 5 85 - (empty-scene width HEIGHT))) - - ;; ---------------------------------------------------------------- - ;; World Number -> Message - ;; on receiving a message from server, place the ball at lower end or stop - #| - (check-expect (receive 'resting 'go) HEIGHT) - (check-expect (receive HEIGHT 'go) HEIGHT) - (check-expect (receive (- HEIGHT 1) 'go) (- HEIGHT 1)) - (check-expect (receive 0 'go) 0) - |# - (define (receive w n) - (cond - [(number? w) w] - [else HEIGHT])) - ;; World -> World - #| - (check-expect (move 'resting) 'resting) - (check-expect (move HEIGHT) (- HEIGHT 1)) - (check-expect (move 0) (make-package 'resting 'go)) - |# - (define (move x) - (cond - [(symbol? x) x] - [(number? x) (if (<= x 0) (make-package 'resting 'go) (sub1 x))])) - - ;; World -> Scene - ;; render the world - - ; (check-expect (draw 100) (place-image BALL 50 100 mt)) - - (define (draw w) - (cond - [(symbol? w) (place-image (text "resting" 11 'red) 10 10 mt)] - [(number? w) (place-image BALL 50 w mt)]))) - (big-bang WORLD0 - (on-draw draw) - (on-receive receive) - (on-tick move .01) - (name t) - (check-with (lambda (w) (or (symbol? w) (number? w)))) - (register LOCALHOST)))) - -; (generate-report) - -;; --- - -(require scheme/contract) - -(provide/contract - [make-player (-> (and/c number? (>=/c 100)) (or/c string? symbol?) any/c)]) diff --git a/collects/picturing-programs/tests/stop.ss b/collects/picturing-programs/tests/stop.ss deleted file mode 100644 index ad0b47216c..0000000000 --- a/collects/picturing-programs/tests/stop.ss +++ /dev/null @@ -1,21 +0,0 @@ -;; The first three lines of this file were inserted by DrScheme. They record metadata -;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname stop) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) -(require picturing-programs) - -;; on RETURN stop - -(define (main debug?) - (big-bang "" - (on-key (lambda (w ke) - (cond - [(key=? ke "\r") (stop-with w)] - [(= (string-length ke) 1) - (string-append w ke)] - [else w]))) - (state debug?) - (on-draw (lambda (w) - (place-image - (text w 22 'black) - 3 3 - (empty-scene 100 100)))))) diff --git a/collects/picturing-programs/tests/stripes.rkt b/collects/picturing-programs/tests/stripes.rkt deleted file mode 100644 index 2d7daab906..0000000000 --- a/collects/picturing-programs/tests/stripes.rkt +++ /dev/null @@ -1,99 +0,0 @@ -;; The first three lines of this file were inserted by DrRacket. They record metadata -;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname stripes) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) - -(require "../package/picturing-programs.rkt") - -; choose-color : num(x) num(y) -> color -(check-expect (choose-color 57 0) (name->color "red")) -(check-expect (choose-color 57 1) (name->color "blue")) -(check-expect (choose-color 72 2) (name->color "red")) -(check-expect (choose-color 14 9) (name->color "blue")) -(define (choose-color x y) - ; x number - ; y number - (cond [(even? y) (name->color "red")] - [(odd? y) (name->color "blue")])) - -; red-blue-stripes : num(width) num(height) -> image -(check-expect (red-blue-stripes 10 0) - (rectangle 10 0 "solid" "purple")) -(check-expect (red-blue-stripes 10 1) - (rectangle 10 1 "solid" "red")) ; fails -(check-expect (red-blue-stripes 10 2) - (above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue"))) -(check-expect (red-blue-stripes 10 3) - (above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red"))) ; fails -(check-expect (red-blue-stripes 10 4) - (above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue"))) -(check-expect (red-blue-stripes 10 5) - (above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red"))) ; fails -(define (red-blue-stripes width height) - ; width number - ; height number - (build-image width height choose-color) - ) - -(red-blue-stripes 10 3) -"should be" -(above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red")) - -(red-blue-stripes 10 5) -"should be" -(above (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red") - (rectangle 10 1 "solid" "blue") - (rectangle 10 1 "solid" "red")) - -(define s0 (red-blue-stripes 10 0)) -(define s1 (red-blue-stripes 10 1)) -(define s2 (red-blue-stripes 10 2)) -(define s3 (red-blue-stripes 10 3)) -(define s4 (red-blue-stripes 10 4)) -(define s5 (red-blue-stripes 10 5)) - -(define grad (build-image 10 10 - (lambda (x y) (make-color (* 25 x) (* 25 y) 0)))) - -(define (dump img) - (map (lambda (y) - (map (lambda (x) - (get-pixel-color x y img)) - (list 0 1 2 (- (image-width img) 2) (- (image-width img) 1))) - ) - (list 0 1 2 (- (image-height img) 2) (- (image-height img) 1)))) - - -(define (red-purple-helper x y c) - (cond [(color=? c (name->color "red")) - (name->color "purple")] - [else c])) - -(define (red->purple pic) - (map red-purple-helper pic)) - -(check-expect (red->purple (rectangle 50 30 "solid" "blue")) - (rectangle 50 30 "solid" "blue")) ; does nothing -(check-expect (red->purple (rectangle 50 30 "solid" "red")) - (rectangle 50 30 "solid" "purple")) ; replaces everything -(check-expect (red->purple (overlay (triangle 30 "solid" "red") - (rectangle 60 60 "solid" "green"))) - (overlay (triangle 30 "solid" "purple") - (rectangle 60 60 "solid" "green"))) -(check-expect (red->purple (overlay (text "hello" 18 "red") - (ellipse 100 50 "solid" "yellow"))) - (overlay (text "hello" 18 "purple") - (ellipse 100 50 "solid" "yellow"))) diff --git a/collects/picturing-programs/tests/test-image.ss b/collects/picturing-programs/tests/test-image.ss deleted file mode 100644 index 2372d1a0ec..0000000000 --- a/collects/picturing-programs/tests/test-image.ss +++ /dev/null @@ -1,1561 +0,0 @@ -#lang scheme/base -#| -;; snippet of code for experimentation -#lang scheme/gui -(require 2htdp/image - lang/posn - (only-in lang/htdp-advanced equal~?)) - -(define images - (list (rhombus 10 90 'solid 'black) - (rotate 45 (square 10 'solid 'black)))) - -(define t (new text%)) -(define f (new frame% [label ""] [width 600] [height 400])) -(define ec (new editor-canvas% [parent f] [editor t])) -(for ((i (in-list images))) (send t insert i) (send t insert " ")) -(send f show #t) -|# - -(require "../image.ss" - (only-in "../../mrlib/image-core.ss" - image% - make-image - image-shape - image-bb - image-normalized? - skip-image-equality-fast-path - make-overlay - make-translate - make-bb - normalize-shape - make-ellipse - make-polygon - make-point - make-crop - crop? - normalized-shape?) - (only-in "../private/image-more.ss" - bring-between - swizzle) - "../private/img-err.ss" - "../../mrlib/private/image-core-bitmap.ss" - lang/posn - scheme/math - scheme/class - scheme/gui/base - schemeunit - (only-in lang/htdp-advanced equal~?)) - -(require (for-syntax scheme/base)) -(define-syntax (test stx) - (syntax-case stx () - [(test a => b) - (with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)]) - #`(begin - ;(printf "running line ~a\n" #,(syntax-line stx)) - #,(quasisyntax/loc stx (check-equal? a b)) - (parameterize ([skip-image-equality-fast-path #t]) - #,(quasisyntax/loc stx (check-equal? a b)))))])) - -(define-syntax (test/exn stx) - (syntax-case stx () - [(test/exn a => b) - (with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)]) - #`(let ([reg b]) - (unless (regexp? reg) - (error 'test/exn "expected a regular expression, got ~e" reg)) - ;(printf "running line ~a\n" #,(syntax-line stx)) - #,(quasisyntax/loc stx (check-regexp-match - reg - (with-handlers ((exn:fail? exn-message)) a "NO EXN!")))))])) - -;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab") - -;(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple)))) - -(define-simple-check (check-close a b) - (and (number? a) - (number? b) - (< (abs (- a b)) 0.001))) - -(define-syntax-rule - (round-numbers e) - (call-with-values (λ () e) round-numbers/values)) - -(define (round-numbers/values . args) (apply values (round-numbers/proc args))) - -(define (round-numbers/proc x) - (let loop ([x x]) - (cond - [(number? x) (let ([n (exact->inexact (/ (round (* 100. x)) 100))]) - (if (equal? n -0.0) - 0.0 - n))] - [(pair? x) (cons (loop (car x)) (loop (cdr x)))] - [(vector? x) (apply vector (map loop (vector->list x)))] - [(is-a? x image%) - (make-image - (loop (image-shape x)) - (loop (image-bb x)) - (loop (image-normalized? x)))] - [(object? x) - ;; add a random number here to hack around the way Eli's tester treats two errors as a passing test - (error 'round-numbers/proc "cannot handle objects ~a" (random))] - [(let-values ([(a b) (struct-info x)]) a) - => - (λ (struct-type) - (apply - (struct-type-make-constructor struct-type) - (map loop (cdr (vector->list (struct->vector x))))))] - [else x]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; circle vs ellipse -;; - -(test (ellipse 40 40 'outline 'black) - => - (circle 20 'outline 'black)) -(test (ellipse 60 60 'solid 'red) - => - (circle 30 'solid 'red)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; width and height -;; - -(test (image-width (rectangle 10 20 'solid 'blue)) - => - 10) -(test (image-height (rectangle 10 20 'solid 'blue)) - => - 20) -(test (image-width (rectangle 0 100 'solid 'blue)) - => - 0) -(test (image-height (rectangle 0 100 'solid 'blue)) - => - 100) -(test (image-width (rectangle 100 0 'solid 'blue)) - => - 100) -(test (image-height (rectangle 100 0 'solid 'blue)) - => - 0) - -(check-close (image-width (rotate 45 (rectangle 100 0 'solid 'blue))) - (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) -(check-close (image-height (rotate 45 (rectangle 100 0 'solid 'blue))) - (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) -(check-close (image-width (rotate 45 (rectangle 0 100 'solid 'blue))) - (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) -(check-close (image-height (rotate 45 (rectangle 0 100 'solid 'blue))) - (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) - -(test (image-width (scale 4 (rectangle 10 10 'outline 'black))) - => - 40) -(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'outline 'black)))) - => - 40) - -(test (image-width (scale 4 (rectangle 10 10 'solid 'black))) - => - 40) -(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'solid 'black)))) - => - 40) - - -(test (image-width (ellipse 10 20 'solid 'blue)) - => - 10) -(test (image-height (ellipse 10 20 'solid 'blue)) - => - 20) -(test (image-width (ellipse 0 100 'solid 'blue)) - => - 0) -(test (image-height (ellipse 0 100 'solid 'blue)) - => - 100) -(test (image-width (ellipse 100 0 'solid 'blue)) - => - 100) -(test (image-height (ellipse 100 0 'solid 'blue)) - => - 0) - -(test (image-width (rotate 30 (ellipse 100 0 'solid 'blue))) - => - (inexact->exact (ceiling (* (cos (* pi 1/6)) 100)))) -(test (image-height (rotate 30 (ellipse 100 0 'solid 'blue))) - => - (inexact->exact (ceiling (* (sin (* pi 1/6)) 100)))) -(check-close (image-width (rotate 30 (ellipse 0 100 'solid 'blue))) - (* (sin (* pi 1/6)) 100)) -(check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue))) - (ceiling (* (cos (* pi 1/6)) 100))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; polygon equality -;; - -(test (polygon (list (make-posn 0 0) - (make-posn 10 10) - (make-posn 10 0)) - "solid" "plum") - => - (polygon (list (make-posn 10 10) - (make-posn 10 0) - (make-posn 0 0)) - "solid" "plum")) - -(test (polygon (list (make-posn 0 0) - (make-posn 0 10) - (make-posn 10 10) - (make-posn 10 0)) - "solid" "plum") - => - (rectangle 10 10 "solid" "plum")) - -(test (polygon (list (make-posn 0 0) - (make-posn 0 10) - (make-posn 10 10) - (make-posn 10 0)) - "solid" "plum") - => - (polygon (list (make-posn 0 0) - (make-posn 0 10) - (make-posn 10 10) - (make-posn 10 0) - (make-posn 0 0)) - "solid" "plum")) - -(test (polygon (list (make-posn 0 0) - (make-posn 0 10) - (make-posn 10 10) - (make-posn 10 0)) - "outline" - (make-pen "plum" 8 "solid" "round" "round")) - => - (polygon (list (make-posn 0 0) - (make-posn 0 10) - (make-posn 10 10) - (make-posn 10 0) - (make-posn 0 0)) - "outline" - (make-pen "plum" 8 "solid" "round" "round"))) - -;; make sure equality isn't equating everything -(test (equal? (rectangle 10 10 'solid 'blue) - (rectangle 10 10 'solid 'red)) - => - #f) - -;; make sure 'white and black match up with color structs -(test (rectangle 10 10 'solid (make-color 255 255 255)) - => - (rectangle 10 10 'solid 'white)) -(test (rectangle 10 10 'solid (make-color 0 0 0)) - => - (rectangle 10 10 'solid 'black)) - -;; test zero sized image equalities - -(test (rectangle 0 100 'solid 'white) - => - (rectangle 0 100 'solid 'white)) - -(test (rectangle 0 100 'solid 'white) - => - (rectangle 0 100 'solid 'black)) - -(test (rectangle 100 0 'solid 'white) - => - (rectangle 100 0 'solid 'black)) - -(test (rectangle 0 0 'solid 'black) - => - (rectangle 0 0 'solid 'orange)) - -(test (equal~? (rectangle 0 100 'solid 'white) - (rotate 90 (rectangle 100 0 'solid 'black)) - .1) - => - #t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; testing overlays -;; - -(test (overlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 10 10 (image-shape (ellipse 100 100 'solid 'blue))) - (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))) - (make-bb 120 - 120 - 120) - #f)) - -(test (overlay/xy (ellipse 100 100 'solid 'blue) - -10 -10 - (ellipse 120 120 'solid 'red)) - => - (overlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red))) - - -(test (overlay/xy (ellipse 50 100 'solid 'red) - -25 25 - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate - 25 0 - (image-shape (ellipse 50 100 'solid 'red))) - (make-translate - 0 25 - (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 - 100 - 100) - #f)) - -(test (overlay/xy (ellipse 100 50 'solid 'green) - 10 10 - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 - 110 - 110) - #f)) - -(test (overlay (ellipse 100 50 'solid 'green) - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 - 100 - 100) - #f)) - -(test (overlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red) - (ellipse 140 140 'solid 'green)) - => - (make-image - (make-overlay - (make-translate - 10 10 - (make-overlay - (make-translate 10 10 (image-shape (ellipse 100 100 'solid 'blue))) - (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red))))) - (make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green)))) - (make-bb 140 140 140) - #f)) - -(test (overlay/align 'middle - 'middle - (ellipse 100 50 'solid 'green) - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 100 100) - #f)) - -(test (overlay/align 'middle - 'middle - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 100 100) - #f)) - - -(test (overlay/align 'right - 'bottom - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 100 100) - #f)) - -(test (overlay/align 'right - 'baseline - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 100 100) - #f)) - -(test (beside/align 'top - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 50 0 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 150 100 100) - #f)) - -(test (beside/align 'center - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 50 25 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 150 100 100) - #f)) - -(test (beside/align 'baseline - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 50 50 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 150 100 100) - #f)) - -(test (beside (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - => - (beside/align 'center - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue))) - -(test (above/align 'left - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 100 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 100 150 150) - #f)) - -(test (above/align 'center - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 100 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 100 150 150) - #f)) - -(test (above/align 'right - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - - => - (make-image - (make-overlay - (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 100 (image-shape (ellipse 100 50 'solid 'blue)))) - (make-bb 100 150 150) - #f)) - -(test (above (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) - => - (above/align 'center - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue))) - - - -(test (underlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red))) - (make-translate 10 10 (image-shape (ellipse 100 100 'solid 'blue)))) - (make-bb 120 - 120 - 120) - #f)) - -(test (underlay/xy (ellipse 100 100 'solid 'blue) - -10 -10 - (ellipse 120 120 'solid 'red)) - => - (underlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red))) - - -(test (underlay/xy (ellipse 50 100 'solid 'red) - -25 25 - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 - 100 - 100) - #f)) - -(test (underlay/xy (ellipse 100 50 'solid 'green) - 10 10 - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 - 110 - 110) - #f)) - -(test (underlay (ellipse 100 50 'solid 'green) - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 - 100 - 100) - #f)) - -(test (underlay (ellipse 100 100 'solid 'blue) - (ellipse 120 120 'solid 'red) - (ellipse 140 140 'solid 'green)) - => - (make-image - (make-overlay - (make-translate - 0 0 - (make-overlay - (make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green))) - (make-translate 10 10 (image-shape (ellipse 120 120 'solid 'red))))) - (make-translate 10 10 (image-shape (ellipse 100 100 'solid 'blue)))) - (make-bb 140 140 140) - #f)) - -(test (underlay/align 'middle - 'middle - (ellipse 100 50 'solid 'green) - (ellipse 50 100 'solid 'red)) - => - (make-image - (make-overlay - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))) - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))) - (make-bb 100 100 100) - #f)) - -(test (underlay/align 'middle - 'middle - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 100 100) - #f)) - -(test (underlay/align 'right - 'bottom - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 100 100) - #f)) - -(test (underlay/align "right" - "baseline" - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) - => - (make-image - (make-overlay - (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green))) - (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red)))) - (make-bb 100 100 100) - #f)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; testing normalization -;; - -(test (normalize-shape (image-shape (ellipse 50 100 'solid 'red)) - values) - => - (make-translate 25 50 (make-ellipse 50 100 0 'solid "red"))) - -(test (normalize-shape (make-overlay (image-shape (ellipse 50 100 'solid 'red)) - (image-shape (ellipse 50 100 'solid 'blue))) - values) - => - (make-overlay (image-shape (ellipse 50 100 'solid 'red)) - (image-shape (ellipse 50 100 'solid 'blue)))) - -(test (normalize-shape (make-overlay - (make-overlay (image-shape (ellipse 50 100 'solid 'red)) - (image-shape (ellipse 50 100 'solid 'blue))) - (image-shape (ellipse 50 100 'solid 'green))) - values) - => - (make-overlay - (make-overlay (make-translate 25 50 (make-ellipse 50 100 0 'solid "red")) - (make-translate 25 50 (make-ellipse 50 100 0 'solid "blue"))) - (make-translate 25 50 (make-ellipse 50 100 0 'solid "green")))) - -(test (normalize-shape (make-overlay - (image-shape (ellipse 50 100 'solid 'green)) - (make-overlay (image-shape (ellipse 50 100 'solid 'red)) - (image-shape (ellipse 50 100 'solid 'blue)))) - values) - => - (make-overlay - (make-overlay (make-translate 25 50 (make-ellipse 50 100 0 'solid "green")) - (make-translate 25 50 (make-ellipse 50 100 0 'solid "red"))) - (make-translate 25 50 (make-ellipse 50 100 0 'solid "blue")))) - -(test (normalize-shape (make-translate 100 100 (image-shape (ellipse 50 100 'solid 'blue))) - values) - => - (make-translate 125 150 (make-ellipse 50 100 0 'solid "blue"))) - -(test (normalize-shape (make-translate 10 20 (make-translate 100 100 (image-shape (ellipse 50 100 'solid 'blue)))) - values) - => - (make-translate 135 170 (make-ellipse 50 100 0 'solid "blue"))) - -(test (normalize-shape (image-shape - (beside/align 'top - (rectangle 10 10 'solid 'black) - (crop 0 0 5 5 (rectangle 10 10 'solid 'green))))) - => - (make-overlay - (make-polygon - (list (make-point 0 0) - (make-point 10 0) - (make-point 10 10) - (make-point 0 10)) - 'solid - "black") - (make-crop - (list (make-point 10 0) - (make-point 15 0) - (make-point 15 5) - (make-point 10 5)) - (make-polygon - (list (make-point 10 0) - (make-point 20 0) - (make-point 20 10) - (make-point 10 10)) - 'solid - "green")))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; testing rotating -;; - -(test (bring-between 123 360) => 123) -(test (bring-between 365 360) => 5) -(test (bring-between -5 360) => 355) -(test (bring-between 720 360) => 0) -(test (bring-between 720.5 360) => .5) - -(test (equal~? (rotate 90 (rectangle 100 100 'solid 'blue)) - (rectangle 100 100 'solid 'blue) - .1) - => - #t) - -(test (round-numbers - (normalize-shape (image-shape (rotate 90 (rotate 90 (rectangle 50 100 'solid 'purple)))) - values)) - => - (round-numbers - (normalize-shape (image-shape (rotate 180 (rectangle 50 100 'solid 'purple))) - values))) - -(test (round-numbers (normalize-shape (image-shape (rotate 90 (ellipse 10 10 'solid 'red))))) - => - (round-numbers (normalize-shape (image-shape (ellipse 10 10 'solid 'red))))) - -(test (round-numbers (normalize-shape (image-shape (rotate 90 (ellipse 10 12 'solid 'red))))) - => - (round-numbers (normalize-shape (image-shape (ellipse 12 10 'solid 'red))))) - -(test (round-numbers (normalize-shape (image-shape (rotate 135 (ellipse 10 12 'solid 'red))))) - => - (round-numbers (normalize-shape (image-shape (rotate 45 (ellipse 12 10 'solid 'red)))))) - -(test (round-numbers (rotate -90 (ellipse 200 400 'solid 'purple))) - => - (round-numbers (rotate 90 (ellipse 200 400 'solid 'purple)))) - -(test (equal~? (rectangle 100 10 'solid 'red) - (rotate 90 (rectangle 10 100 'solid 'red)) - 0.1) - => - #t) - -(test (equal~? (rectangle 100 10 'solid 'red) - (rotate 90 (rectangle 10.001 100.0001 'solid 'red)) - 0.1) - => - #t) - -(test (equal~? (rotate - 90 - (overlay/xy (rectangle 20 100 'solid 'purple) - 20 0 - (ellipse 40 40 'solid 'orange))) - (overlay/xy (rectangle 100 20 'solid 'purple) - 0 -40 - (ellipse 40 40 'solid 'orange)) - .1) - => - #t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; scaling tests -;; - -(test (scale 2 (rectangle 100 10 'solid 'blue)) - => - (rectangle 200 20 'solid 'blue)) - -(test (scale 3 - (overlay/xy (rectangle 100 10 'solid 'blue) - 0 - 20 - (rectangle 100 10 'solid 'red))) - => - (overlay/xy (rectangle 300 30 'solid 'blue) - 0 - 60 - (rectangle 300 30 'solid 'red))) - -(test (scale 3 - (overlay/xy (rectangle 100 10 'solid 'blue) - 0 - 20 - (overlay/xy (rectangle 100 10 'solid 'blue) - 0 - 20 - (rectangle 100 10 'solid 'purple)))) - => - (overlay/xy (rectangle 300 30 'solid 'blue) - 0 - 60 - (overlay/xy (rectangle 300 30 'solid 'blue) - 0 - 60 - (rectangle 300 30 'solid 'purple)))) - -(test (scale/xy 3 4 (ellipse 30 60 'outline 'purple)) - => - (ellipse (* 30 3) (* 60 4) 'outline 'purple)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; misc tests -;; - -(test (rectangle 100 10 'solid 'blue) - => - (rectangle 100 10 "solid" "blue")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; regular polygon -;; - -;; note: the regular-polygon and the rectangle generate the points in reverse directions. -(test (round-numbers (regular-polygon 100 4 'outline 'green)) - => - (round-numbers (rectangle 100 100 'outline 'green))) - -(test (swizzle (list 0 1 2 3 4) 2) - => - (list 0 2 4 1 3)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; text -;; - -(test (beside/align "baseline" - (text "a" 18 "black") - (text "b" 18 "black")) - => - (text "ab" 18 "black")) - -(test (round-numbers - (image-width (rotate 45 (text "One" 18 'black)))) - => - (round-numbers - (let ([t (text "One" 18 'black)]) - (image-width (rotate 45 (rectangle (image-width t) - (image-height t) - 'solid 'black)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; triangle -;; - -(test (round-numbers (rotate 180 (isosceles-triangle 60 330 "solid" "lightseagreen"))) - => - (round-numbers (isosceles-triangle 60 30 "solid" "lightseagreen"))) - -(test (triangle 40 'outline 'black) - => - (regular-polygon 40 3 'outline 'black)) - -(test (equal~? (rotate (+ 180 45) (right-triangle 50 50 'solid 'black)) - (isosceles-triangle 50 90 'solid 'black) - 0.001) - => - #t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; square -;; - -(test (square 10 'solid 'black) - => - (rectangle 10 10 'solid 'black)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; rhombus -;; - -(test (equal~? (rhombus 10 90 'solid 'black) - (rotate 45 (square 10 'solid 'black)) - 0.01) - => - #t) - -(test (equal~? (rhombus 50 150 'solid 'black) - (rotate 90 (rhombus 50 30 'solid 'black)) - 0.01) - => - #t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; lines -;; - -(test (image-width (line 10 20 'black)) - => - 11) -(test (image-height (line 10 20 'black)) - => - 21) - -(test (round-numbers (rotate 90 (line 10 20 'black))) - => - (round-numbers (line 20 -10 'black))) - -(test (round-numbers (line 20 30 "red")) - => - (round-numbers (rotate 180 (line 20 30 "red")))) - -(test (round-numbers (line -30 20 "red")) - => - (round-numbers (line 30 -20 "red"))) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 10 10 90 190 "red")) - => - 100) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 10 10 90 190 "red")) - => - 200) -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 10 10 200 200 "red")) - => - 200) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 10 10 200 200 "red")) - => - 200) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 10 10 300 300 "red")) - => - 300) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 10 10 300 300 "red")) - => - 300) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - -10 10 100 200 "red")) - => - 110) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - -10 10 100 200 "red")) - => - 200) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 10 -10 100 200 "red")) - => - 100) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 10 -10 100 200 "red")) - => - 210) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 100 200 10 -10 "red")) - => - 100) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 100 200 10 -10 "red")) - => - 210) - -(test (image-width (add-line (rectangle 100 200 'solid 'black) - 100 200 -10 10 "red")) - => - 110) -(test (image-height (add-line (rectangle 100 200 'solid 'black) - 100 200 -10 10 "red")) - => - 200) - -(let* ([txt (text "H" 24 'black)] - [bl (image-baseline txt)]) - (test (image-baseline (add-line txt 0 0 100 100 'red)) - => - bl)) - -(let* ([txt (text "H" 24 'black)] - [bl (image-baseline txt)]) - (test (image-baseline (add-line txt 0 -10 100 100 'red)) - => - (+ bl 10))) - -(test (scene+line (rectangle 100 100 'solid 'black) - 10 10 - 90 50 - "red") - => - (add-line (rectangle 100 100 'solid 'black) - 10 10 - 90 50 - "red")) - -(test (image-width (scene+line (rectangle 100 100 'solid 'black) - -10 -20 - 110 120 - "green")) - => - 100) -(test (image-height (scene+line (rectangle 100 100 'solid 'black) - -10 -20 - 110 120 - 'purple)) - => - 100) -(test (image-baseline (scene+line (rectangle 100 100 'solid 'black) - -10 -20 - 110 120 - 'olive)) - => - 100) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; curves -;; - -;; make sure a curve stays roughly in the middle pixels by -;; covering up a white curve with a thin black bar -(test (overlay/align 'middle - 'middle - (rectangle 82 2 'solid 'black) - (add-curve (rectangle 100 20 'solid 'black) - 10 10 0 1/4 - 90 10 0 1/4 - 'white)) - - => - (rectangle 100 20 'solid 'black)) - -;; and then make sure the curve actually draws something ... -(test (not (equal? (add-curve (rectangle 100 20 'solid 'black) - 10 10 0 1/4 - 90 10 0 1/4 - 'white) - (rectangle 100 20 'solid 'black))) - => - #t) - -(test (scale 2 - (add-curve - (rectangle 100 100 'solid 'black) - 20 20 0 1/3 80 80 0 1/3 'white)) - => - (add-curve - (rectangle 200 200 'solid 'black) - 40 40 0 1/3 160 160 0 1/3 'white)) - -(test (rotate - 90 - (add-curve - (rectangle 100 100 'solid 'black) - 20 20 0 1/3 80 80 0 1/3 'white)) - => - (add-curve - (rectangle 100 100 'solid 'black) - 20 80 90 1/3 80 20 90 1/3 'white)) - -(test (add-curve (rectangle 100 100 'solid 'black) - 10 10 0 1/4 - 90 90 0 1/4 - 'white) - => - (scene+curve (rectangle 100 100 'solid 'black) - 10 10 0 1/4 - 90 90 0 1/4 - 'white)) -(test (scene+curve (rectangle 100 100 'solid 'black) - 10 10 0 1/4 - 110 110 0 1/4 - 'red) - - => - (crop 0 0 100 100 - (add-curve (rectangle 100 100 'solid 'black) - 10 10 0 1/4 - 110 110 0 1/4 - 'red))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; bitmap tests -;; - -(test (clamp-1 0 3 5) - => 3) -(test (clamp-1 0 0 5) - => 0) -(test (clamp-1 0 -2 5) - => 0) -(test (clamp-1 0 4 5) - => 4) -(test (clamp-1 0 7 5) - => 4) - -(test (build-bytes 5 sqr) - => (list->bytes '(0 1 4 9 16))) - - -(define onePixel (list->bytes '(255 0 0 255))) -;(call-with-values (λ () (scale onePixel 1 1 100)) show-bitmap) - -(define blue2x1 (list->bytes '(255 0 0 255 255 0 255 0))) -;(call-with-values (λ () (scale blue2x1 2 1 20)) show-bitmap) - -(define blue2x2 (list->bytes '(255 0 0 255 255 0 0 255 255 0 0 255 255 0 0 255))) -(define gray2x2 (list->bytes '(255 100 100 100 255 100 100 100 255 100 100 100 255 100 100 100))) -;; Some blue x green checkerboards: -(define checker2x2 (list->bytes '(255 0 0 255 255 0 255 0 - 255 0 255 0 255 0 0 255))) -(define checker3x3 (list->bytes '(255 0 0 255 255 0 255 0 255 0 0 255 - 255 0 255 0 255 0 0 255 255 0 255 0 - 255 0 0 255 255 0 255 0 255 0 0 255 ))) - - -(test (bmbytes-ref/safe checker3x3 3 3 0 0) => (list->bytes '(255 0 0 255))) -(test (bmbytes-ref/safe checker3x3 3 3 1 1) => (list->bytes '(255 0 0 255))) -(test (bmbytes-ref/safe checker3x3 3 3 2 2) => (list->bytes '(255 0 0 255))) -(test (bmbytes-ref/safe checker3x3 3 3 1 2) => (list->bytes '(255 0 255 0))) -(test (bmbytes-ref/safe checker3x3 3 3 0 3) => (list->bytes '( 0 0 0 255))) -(test (bmbytes-ref/safe checker3x3 3 3 -1 -1) => (list->bytes '( 0 0 0 255))) -(test (bmbytes-ref/safe checker3x3 3 3 -1 1) => (list->bytes '( 0 0 255 0))) -(test (bmbytes-ref/safe checker3x3 3 3 1 19) => (list->bytes '( 0 0 255 0))) - -#; -(test (bytes->list (interpolate checker2x2 2 2 1 0)) - => - '(255 0 255 0)) - -#; -(test (bytes->list (interpolate checker3x3 3 3 0 0)) - => - '(255 0 0 255)) - -#; -(test (bytes->list (interpolate checker3x3 3 3 0 1)) - => - '(255 0 255 0)) - -#; -(test (bytes->list (interpolate checker3x3 3 3 0 2)) - => - '(255 0 0 255)) - -#; -(test (bytes->list (interpolate checker3x3 3 3 0.5 0)) - => - '(255 0 128 128)) - -(test (image-width (bitmap icons/stop-16x16.png)) - => - 16) -(test (image-height (bitmap icons/stop-16x16.png)) - => - 16) - -(test (let () - (define bmp (make-object bitmap% 4 4)) - (define mask (make-object bitmap% 4 4)) - (define bdc (make-object bitmap-dc% bmp)) - (send bdc set-brush "black" 'solid) - (send bdc draw-rectangle 0 0 4 4) - (send bdc set-bitmap mask) - (send bdc set-brush "black" 'solid) - (send bdc clear) - (send bdc draw-rectangle 1 1 1 1) - (send bdc set-bitmap #f) - (let-values ([(bytes w h) (bitmap->bytes bmp mask)]) - bytes)) - => - (bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0")) - -;; ensure no error -(test (begin (scale 2 (make-object bitmap% 10 10)) - (void)) - => - (void)) - - -(define (fill-bitmap b color) - (let ([bdc (make-object bitmap-dc% b)]) - (send bdc set-brush color 'solid) - (send bdc set-pen color 1 'transparent) - (send bdc draw-rectangle 0 0 (send b get-width) (send b get-height)) - (send bdc set-bitmap #f))) - -(define blue-10x20-bitmap (make-object bitmap% 10 20)) -(fill-bitmap blue-10x20-bitmap "blue") -(define blue-20x10-bitmap (make-object bitmap% 20 10)) -(fill-bitmap blue-20x10-bitmap "blue") -(define blue-20x40-bitmap (make-object bitmap% 20 40)) -(fill-bitmap blue-20x40-bitmap "blue") - -(test (image-width (image-snip->image (make-object image-snip% blue-10x20-bitmap))) - => - 10) -(test (image-height (image-snip->image (make-object image-snip% blue-10x20-bitmap))) - => - 20) -(test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap))) - => - 20) -(test (scale 2 (make-object image-snip% blue-10x20-bitmap)) - => - (image-snip->image (make-object image-snip% blue-20x40-bitmap))) - -(test (rotate 90 (make-object image-snip% blue-10x20-bitmap)) - => - (image-snip->image (make-object image-snip% blue-20x10-bitmap))) - -;; there was a bug in the bounding box computation for scaled bitmaps that this test exposes -(test (image-width (frame (rotate 90 (scale 1/2 (bitmap icons/plt-logo-red-diffuse.png))))) - => - 128) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; cropping (and place-image) -;; - -(test (crop 0 0 10 10 (rectangle 20 20 'solid 'black)) - => - (rectangle 10 10 'solid 'black)) - -(test (equal~? (crop 0 0 40 40 (circle 40 'solid 'red)) - (rotate 180 (crop 40 40 40 40 (circle 40 'solid 'red))) - 0.1) - => - #t) - -(test (beside/align 'middle - (rectangle 10 10 'solid 'black) - (crop 0 0 10 10 (rectangle 10 10 'solid 'green))) - => - (beside/align 'middle - (rectangle 10 10 'solid 'black) - (rectangle 10 10 'solid 'green))) - -(test (place-image/align (circle 4 'solid 'black) - 10 10 - 'left 'top - (rectangle 40 40 'solid 'orange)) - => - (underlay/xy (rectangle 40 40 'solid 'orange) - 10 10 - (circle 4 'solid 'black))) - -(test (place-image/align (circle 4 'solid 'black) - 50 50 - 'left 'top - (rectangle 40 40 'solid 'orange)) - => - (rectangle 40 40 'solid 'orange)) - -(test (place-image/align (circle 4 'solid 'black) - 36 36 - 'left 'top - (rectangle 40 40 'solid 'orange)) - => - (underlay/xy (rectangle 40 40 'solid 'orange) - 36 36 - (crop 0 0 4 4 (circle 4 'solid 'black)))) - -(test (place-image/align (circle 8 'solid 'black) - -4 -4 - 'left 'top - (rectangle 40 40 'solid 'orange)) - => - (overlay/xy (crop 4 4 16 16 (circle 8 'solid 'black)) - 0 0 - (rectangle 40 40 'solid 'orange))) - -(test (place-image/align (circle 4 'solid 'black) - -4 0 - 'left 'top - (rectangle 40 40 'solid 'orange)) - => - (overlay/xy (crop 4 0 4 8 (circle 4 'solid 'black)) - 0 0 - (rectangle 40 40 'solid 'orange))) - -(test (place-image/align (circle 4 'solid 'black) - 5 10 'center 'center - (rectangle 40 40 'solid 'orange)) - => - (underlay/xy (rectangle 40 40 'solid 'orange) - 1 6 - (circle 4 'solid 'black))) - - -(test (place-image/align (circle 4 'solid 'black) - 10 15 'right 'bottom - (rectangle 40 40 'solid 'orange)) - => - (underlay/xy (rectangle 40 40 'solid 'orange) - 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))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; pen arguments -;; - -;; just make sure no errors. -(test (image? (polygon (list (make-posn 0 0) - (make-posn 100 100) - (make-posn 100 0) - (make-posn 0 100)) - "outline" - (make-pen "darkslategray" 6 "solid" "round" "round"))) - => - #t) - -(test (image? (line 10 - 10 - (make-pen "darkslategray" 6 "solid" "round" "round"))) - => - #t) - -(test (scale 2 - (polygon (list (make-posn 0 0) - (make-posn 100 0) - (make-posn 100 100)) - "outline" - (make-pen "black" 6 "solid" "round" "round"))) - => - (polygon (list (make-posn 0 0) - (make-posn 200 0) - (make-posn 200 200)) - "outline" - (make-pen "black" 12 "solid" "round" "round"))) - -(test (scale 2 - (ellipse 30 40 "outline" - (make-pen "black" 2 "solid" "round" "round"))) - => - (ellipse 60 80 "outline" - (make-pen "black" 4 "solid" "round" "round"))) - -(test (scale 2 - (polygon (list (make-posn 0 0) - (make-posn 100 0) - (make-posn 100 100)) - "outline" - (make-pen "black" 0 "solid" "round" "round"))) - => - (polygon (list (make-posn 0 0) - (make-posn 200 0) - (make-posn 200 200)) - "outline" - (make-pen "black" 0 "solid" "round" "round"))) - -(test (scale 2 - (add-line - (rectangle 100 100 'solid 'black) - 20 20 80 80 - (make-pen "black" 6 "solid" "round" "round"))) - => - (add-line - (rectangle 200 200 'solid 'black) - 40 40 160 160 - (make-pen "black" 12 "solid" "round" "round"))) - -(test (scale 2 - (add-curve - (rectangle 100 100 'solid 'black) - 20 20 0 1/2 - 80 80 0 1/2 - (make-pen "black" 6 "solid" "round" "round"))) - => - (add-curve - (rectangle 200 200 'solid 'black) - 40 40 0 1/2 - 160 160 0 1/2 - (make-pen "black" 12 "solid" "round" "round"))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; test that the extra mode check is there -;; - -(test/exn (rectangle 10 10 "solid" (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^rectangle: expected ") - -(test/exn (rectangle 10 10 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^rectangle: expected ") - -(test/exn (circle 10 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^circle: expected ") - -(test/exn (ellipse 10 10 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^ellipse: expected ") - -(test/exn (triangle 10 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^triangle: expected ") - -(test/exn (right-triangle 10 12 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^right-triangle: expected ") - -(test/exn (isosceles-triangle 10 120 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^isosceles-triangle: expected ") - -(test/exn (square 10 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^square: expected ") - -(test/exn (rhombus 40 45 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^rhombus: expected ") - -(test/exn (regular-polygon 40 6 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^regular-polygon: expected ") - -(test/exn (star 40 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^star: expected ") - -(test/exn (star-polygon 40 7 3 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^star-polygon: expected ") - -(test/exn (polygon (list (make-posn 0 0) (make-posn 100 0) (make-posn 100 100)) - 'solid (make-pen "black" 12 "solid" "round" "round")) - => - #rx"^polygon: expected ") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; random testing of normalization -;; make sure normalization actually normalizes -;; and that normalization doesn't introduce new structs -;; - -(require redex/reduction-semantics) - -(define-language 2htdp/image - (image (rectangle size size mode color) - (line coord coord color) - (add-curve (rectangle size size mode color) - coord coord pull angle - coord coord pull angle - color) - (overlay image image) - (overlay/xy image coord coord image) - (underlay image image) - (underlay/xy image coord coord image) - (crop coord coord size size image) - (scale/xy size size image) - (scale size image) - (rotate angle image)) - - (size big-nat) - (mode 'outline 'solid "outline" "solid") - (color "red" 'red "blue" "orange" "green" "black") - (coord big-int) - (pull 0 1/2 1/3 2 (/ big-nat (+ 1 big-nat))) - (angle 0 90 45 30 180 natural (* 4 natural)) - - ; Redex tends to choose small numbers. - (big-nat (+ (* 10 natural) natural)) - (big-int (+ (* 10 integer) integer))) - -(define-namespace-anchor anchor) - -(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)))))) - -(define (check-image-properties img-sexp img) - (let* ([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 after normalization:\n~s" - img-sexp)) - (unless (equal? norm-size raw-size) - (error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s" - img-sexp raw-size norm-size)))) - -(time - (redex-check - 2htdp/image - image - (check-image-properties - (term image) - (eval (term image) (namespace-anchor->namespace anchor))) - #:attempts 1000)) - diff --git a/collects/picturing-programs/tests/ufo-rename.ss b/collects/picturing-programs/tests/ufo-rename.ss deleted file mode 100644 index f9d074b4be..0000000000 --- a/collects/picturing-programs/tests/ufo-rename.ss +++ /dev/null @@ -1,15 +0,0 @@ -#lang scheme -(require (prefix-in uni: picturing-programs) - ) - -(define (create-UFO-scene height) - (uni:place-image UFO 50 height (uni:empty-scene 100 100))) - -(define UFO - (uni:overlay (uni:circle 10 'solid 'green) - (uni:rectangle 40 4 'solid 'green))) - -(uni:big-bang 0 - (uni:on-tick add1) - (uni:stop-when (lambda (y) (>= y 100))) - (uni:on-draw create-UFO-scene)) diff --git a/collects/picturing-programs/tests/world0-stops.ss b/collects/picturing-programs/tests/world0-stops.ss deleted file mode 100644 index 828a602cf5..0000000000 --- a/collects/picturing-programs/tests/world0-stops.ss +++ /dev/null @@ -1,13 +0,0 @@ -;; The first three lines of this file were inserted by DrScheme. They record metadata -;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) - -(require 2htdp/universe) - -"does big-bang stop when the initial world is already a final world?" -(big-bang 0 (stop-when zero?) (on-tick add1)) - -"does big bang stop when the initial world is a stop world?" -(big-bang (stop-with 0) (on-tick add1)) - -(define-struct stop (x)) diff --git a/collects/picturing-programs/tests/xrun b/collects/picturing-programs/tests/xrun deleted file mode 100644 index f72756086f..0000000000 --- a/collects/picturing-programs/tests/xrun +++ /dev/null @@ -1,3 +0,0 @@ -mred balls.ss & -./player carl & -./player sam &