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.
This commit is contained in:
Stephen Bloch
parent
73ef1d6c14
commit
4bce35f0a4
|
|
@ -1,9 +1,9 @@
|
||||||
#lang racket
|
#lang racket/base
|
||||||
; Initial version, Dec. 13, 2010.
|
; Initial version, Dec. 13, 2010.
|
||||||
; Doesn't work with a literal image, but it works to use a "bitmap"
|
; 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.
|
; 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))
|
(provide (all-defined-out))
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
|
|
@ -1,11 +1,12 @@
|
||||||
#lang scribble/manual
|
#lang scribble/doc
|
||||||
@(require
|
@(require
|
||||||
|
scribble/manual
|
||||||
(for-label racket
|
(for-label racket
|
||||||
"main.rkt"
|
picturing-programs/main
|
||||||
"io-stuff.rkt"
|
;picturing-programs/io-stuff
|
||||||
; "sb-universe.rkt"
|
;picturing-programs/tiles
|
||||||
"tiles.rkt"
|
;picturing-programs/dummy
|
||||||
"map-image.rkt"
|
; picturing-programs/map-image
|
||||||
2htdp/image
|
2htdp/image
|
||||||
teachpack/2htdp/universe
|
teachpack/2htdp/universe
|
||||||
(only-in lang/htdp-beginner check-expect)
|
(only-in lang/htdp-beginner check-expect)
|
||||||
|
|
@ -16,19 +17,20 @@
|
||||||
@author{Stephen Bloch}
|
@author{Stephen Bloch}
|
||||||
|
|
||||||
@; defmodule[installed-teachpack/picturing-programs]
|
@; defmodule[installed-teachpack/picturing-programs]
|
||||||
@defmodule[(planet sbloch/picturing-programs)]
|
@defmodule[picturing-programs]
|
||||||
|
|
||||||
@section{About This Teachpack}
|
@section{About This Teachpack}
|
||||||
|
|
||||||
@;Testing, testing: @racket[(list 'testing 1 2 3)].
|
@;Testing, testing: @racket[(list 'testing 1 2 3)].
|
||||||
@;
|
@;
|
||||||
@;This is a reference to the @racket[list] function.
|
@;This is a reference to the @racket[list] function (which is a nice link).
|
||||||
@;Now a reference to @racket[triangle],
|
@;Now a reference to @racket[triangle] (good link),
|
||||||
@;and @racket[big-bang],
|
@;and @racket[big-bang] (good link),
|
||||||
@;and @racket[show-it],
|
@;and @racket[show-it] (good link),
|
||||||
@;and @racket[crop-top],
|
@;and @racket[crop-top] (underlined in red, not a link),
|
||||||
@;and @racket[map-image],
|
@;and @racket[map-image] (underlined in red, not a link),
|
||||||
@;and @racket[with-input-from-url],
|
@;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.
|
@;which are defined in several different places.
|
||||||
|
|
||||||
Provides a variety of functions for combining and manipulating images
|
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
|
@racketmodlink[2htdp/image]{the image teachpack} and
|
||||||
and
|
and
|
||||||
@racketmodlink[2htdp/universe]{the universe teachpack},
|
@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.
|
See the above links for how to use those teachpacks.
|
||||||
|
|
||||||
It also supersedes the older @racket[tiles] and @racket[sb-world] 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}
|
@subsection{Colors and pixels}
|
||||||
|
|
||||||
@defproc[(name->color [name string?])
|
Each pixel of a bitmap image has a @racket[color], a built-in structure with
|
||||||
(or/c color? false/c)]{
|
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
|
Even if you're not trying to get transparency effects, alpha is also used
|
||||||
color struct, showing the red, green, and blue components. If the name isn't
|
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].}
|
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?])
|
@defproc[(get-pixel-color [x natural-number/c] [y natural-number/c] [pic image?])
|
||||||
color?]{
|
color?]{
|
||||||
|
|
||||||
Gets the color of a specified pixel in the given image. If x and/or y are outside the
|
Gets the color of a specified pixel in the given image. If x and/or y are outside
|
||||||
bounds of the image, returns black.}
|
the bounds of the image, returns a transparent color.}
|
||||||
|
|
||||||
@subsection{Specifying the color of each pixel of an image}
|
@subsection{Specifying the color of each pixel of an image}
|
||||||
@defproc[(build-image [width natural-number/c]
|
@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
|
produces a fuzzy version of the given picture by replacing each pixel with a
|
||||||
randomly chosen pixel near it.}
|
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]
|
@defproc[(build3-image [width natural-number/c] [height natural-number/c]
|
||||||
[red-function (-> natural-number/c natural-number/c 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)]
|
[green-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||||
[blue-function (-> natural-number/c natural-number/c natural-number/c)])
|
[blue-function (-> natural-number/c natural-number/c natural-number/c)])
|
||||||
image?]{
|
image?]{
|
||||||
A version of @racket[build-image] for students who don't know about structs yet.
|
Just like @racket[build4-image], but without specifying the alpha component
|
||||||
Each of the three functions takes in the x and y coordinates of a pixel, and
|
(which defaults to 255, fully opaque).}
|
||||||
should return an integer from 0 through 255 to determine that color component.}
|
|
||||||
|
|
||||||
@defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?])
|
@defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?])
|
||||||
image?]{
|
image?]{
|
||||||
|
|
@ -170,49 +210,97 @@ size and shape. For example,
|
||||||
produces a copy of @racket[my-picture] with all the red leached out,
|
produces a copy of @racket[my-picture] with all the red leached out,
|
||||||
leaving only the blue and green components.
|
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[
|
@racketblock[
|
||||||
(define (apply-gradient x y old-color)
|
(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)]
|
(map-image apply-gradient my-picture)]
|
||||||
produces a picture the same size and shape as @racket[my-picture],
|
produces a picture the size of @racket[my-picture]'s bounding rectangle,
|
||||||
but with a smooth color gradient with red increasing from left to
|
with a smooth color gradient with red increasing from left to
|
||||||
right and blue increasing from top to bottom.}
|
right and blue increasing from top to bottom.}
|
||||||
|
|
||||||
|
@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
|
@defproc[(map3-image
|
||||||
[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
[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)]
|
[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)]
|
[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||||
[img image?])
|
[img image?])
|
||||||
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
|
The alpha component in the resulting picture is copied from the source
|
||||||
to have the contract @racketblock[num(x) num(y) num(r) num(g) num(b) -> num ]
|
picture. For example,
|
||||||
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,
|
|
||||||
@racketblock[
|
@racketblock[
|
||||||
(define (zero x y r g b) 0)
|
(define (zero x y r g b) 0)
|
||||||
(define (same-g x y r g b) g)
|
(define (same-g x y r g b) g)
|
||||||
(define (same-b x y r g b) b)
|
(define (same-b x y r g b) b)
|
||||||
(map3-image zero same-g same-b my-picture)]
|
(map3-image zero same-g same-b my-picture)]
|
||||||
produces a copy of @racket[my-picture] with all the red leached out,
|
produces a copy of @racket[my-picture] with all the red leached out; parts of
|
||||||
leaving only the blue and green components.
|
the picture that were transparent are still transparent, and parts that were
|
||||||
|
dithered are still dithered.
|
||||||
@racketblock[
|
@racketblock[
|
||||||
(define (3x x y r g b) (min (* 3 x) 255))
|
(define (3x x y r g b a) (min (* 3 x) 255))
|
||||||
(define (3y x y r g b) (min (* 3 y) 255))
|
(define (3y x y r g b a) (min (* 3 y) 255))
|
||||||
(map3-image 3x zero 3y my-picture)]
|
(map3-image zero 3x 3y my-picture)]
|
||||||
produces a picture the same size and shape as @racket[my-picture],
|
produces a @racket[my-picture]-shaped "window" on a color-gradient.
|
||||||
but with a smooth color gradient with red increasing from left to
|
}
|
||||||
right and blue increasing from top to bottom.}
|
|
||||||
|
|
||||||
@defproc[(real->int [num real?])
|
@defproc[(real->int [num real?])
|
||||||
integer?]{
|
integer?]{
|
||||||
|
|
||||||
Not specific to colors, but useful if you're building colors by arithmetic.
|
Not specific to colors, but useful if you're building colors by arithmetic.
|
||||||
For example,
|
For example,
|
||||||
@racketblock[
|
@racketblock[
|
||||||
|
|
@ -227,37 +315,6 @@ The version using @racket[bad-gradient] crashes because color components must be
|
||||||
The version using @racket[good-gradient] works.}
|
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}
|
@section{Input and Output}
|
||||||
This teachpack also provides several functions to help in testing
|
This teachpack also provides several functions to help in testing
|
||||||
I/O functions (in Advanced Student language; ignore this section if
|
I/O functions (in Advanced Student language; ignore this section if
|
||||||
|
|
|
||||||
|
|
@ -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."))
|
`("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 '(
|
(define release-notes '(
|
||||||
(p "Version 2.5: Re-enabled diagonal reflection. Moved into the bundle
|
(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.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.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.")
|
(p "Version 2.2: Fixed bug in rotate-cw and rotate-ccw; restored reflect-vert and reflect-horiz; added with-input-from-url.")
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
||||||
#lang racket
|
#lang racket/base
|
||||||
(require racket/port lang/error net/url)
|
(require racket/port lang/error net/url)
|
||||||
(provide with-input-from-string
|
(provide with-input-from-string
|
||||||
with-output-to-string
|
with-output-to-string
|
||||||
|
|
|
||||||
|
|
@ -1,18 +1,18 @@
|
||||||
#lang racket
|
#lang racket/base
|
||||||
(require 2htdp/universe
|
(require 2htdp/universe
|
||||||
htdp/error ; check-arg
|
(only-in htdp/error check-arg)
|
||||||
"tiles.rkt"
|
picturing-programs/tiles
|
||||||
"io-stuff.rkt"
|
picturing-programs/io-stuff
|
||||||
"map-image.rkt"
|
picturing-programs/map-image
|
||||||
"book-pictures.rkt")
|
picturing-programs/book-pictures)
|
||||||
(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
|
(provide (all-from-out picturing-programs/tiles) ; includes all-from-out 2htdp/image, plus a few simple add-ons
|
||||||
(all-from-out "map-image.rkt") ; includes (map,build)-[masked-]image, real->int, maybe-color?, name->color,
|
(all-from-out picturing-programs/io-stuff) ; includes with-{input-from,output-to}-{string,file}, with-io-strings
|
||||||
; get-pixel-color, pixel-visible?
|
(all-from-out picturing-programs/map-image)
|
||||||
(prefix-out pic: (all-from-out "book-pictures.rkt")) ; pic:calendar, pp:hacker, etc.
|
; 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.
|
||||||
(provide show-it)
|
(all-from-out 2htdp/universe)
|
||||||
(provide (all-from-out 2htdp/universe))
|
show-it)
|
||||||
|
|
||||||
|
|
||||||
(define (show-it img)
|
(define (show-it img)
|
||||||
|
|
|
||||||
|
|
@ -14,8 +14,9 @@
|
||||||
racket/snip
|
racket/snip
|
||||||
racket/class
|
racket/class
|
||||||
2htdp/image
|
2htdp/image
|
||||||
|
(only-in htdp/error natural?)
|
||||||
(only-in mrlib/image-core render-image))
|
(only-in mrlib/image-core render-image))
|
||||||
(require picturing-programs/book-pictures)
|
;(require picturing-programs/book-pictures)
|
||||||
|
|
||||||
;(require mrlib/image-core)
|
;(require mrlib/image-core)
|
||||||
;(require 2htdp/private/image-more)
|
;(require 2htdp/private/image-more)
|
||||||
|
|
@ -94,10 +95,10 @@
|
||||||
(compose colorize f))
|
(compose colorize f))
|
||||||
|
|
||||||
|
|
||||||
; natural? : anything -> boolean
|
;; natural? : anything -> boolean
|
||||||
(define (natural? it)
|
;(define (natural? it)
|
||||||
(and (integer? it)
|
; (and (integer? it)
|
||||||
(>= it 0)))
|
; (>= it 0)))
|
||||||
|
|
||||||
; color=? : broad-color broad-color -> boolean
|
; color=? : broad-color broad-color -> boolean
|
||||||
(define (color=? c1 c2)
|
(define (color=? c1 c2)
|
||||||
|
|
@ -111,95 +112,6 @@
|
||||||
(= (color-green rc1) (color-green rc2))
|
(= (color-green rc1) (color-green rc2))
|
||||||
(= (color-blue rc1) (color-blue 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))
|
(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))))
|
(afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))))
|
||||||
pic))
|
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))))))
|
|
||||||
|
|
|
||||||
|
|
@ -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<args.length; i++) {
|
|
||||||
var a = args[i];
|
|
||||||
var p = a.indexOf('=');
|
|
||||||
if (p >= 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<page_args.length; i++)
|
|
||||||
if (page_args[i][0] == key) return unescape(page_args[i][1]);
|
|
||||||
return def;
|
|
||||||
}
|
|
||||||
|
|
||||||
function MergePageArgsIntoLink(a) {
|
|
||||||
if (page_args.length == 0 ||
|
|
||||||
(!a.attributes["pltdoc"]) || (a.attributes["pltdoc"].value == ""))
|
|
||||||
return;
|
|
||||||
a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
|
|
||||||
if (RegExp.$2.length == 0) {
|
|
||||||
a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
|
|
||||||
} else {
|
|
||||||
// need to merge here, precedence to arguments that exist in `a'
|
|
||||||
var i, j;
|
|
||||||
var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
|
|
||||||
var args = str.split(/[&;]/);
|
|
||||||
for (i=0; i<args.length; i++) {
|
|
||||||
j = args[i].indexOf('=');
|
|
||||||
if (j) args[i] = args[i].substring(0,j);
|
|
||||||
}
|
|
||||||
var additions = "";
|
|
||||||
for (i=0; i<page_args.length; i++) {
|
|
||||||
var exists = false;
|
|
||||||
for (j=0; j<args.length; j++)
|
|
||||||
if (args[j] == page_args[i][0]) { exists = true; break; }
|
|
||||||
if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
|
|
||||||
}
|
|
||||||
a.href = prefix + "?" + str + suffix;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// Cookies --------------------------------------------------------------------
|
|
||||||
|
|
||||||
function GetCookie(key, def) {
|
|
||||||
var i, cookiestrs;
|
|
||||||
try {
|
|
||||||
if (document.cookie.length <= 0) return def;
|
|
||||||
cookiestrs = document.cookie.split(/; */);
|
|
||||||
} catch (e) { return def; }
|
|
||||||
for (i = 0; i < cookiestrs.length; i++) {
|
|
||||||
var cur = cookiestrs[i];
|
|
||||||
var eql = cur.indexOf('=');
|
|
||||||
if (eql >= 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("<style>mynoscript { display:none; }</style>");
|
|
||||||
|
|
||||||
// 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<on_load_funcs.length; i++) on_load_funcs[i]();
|
|
||||||
};
|
|
||||||
|
|
||||||
AddOnLoad(function(){
|
|
||||||
var links = document.getElementsByTagName("a");
|
|
||||||
for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
|
|
||||||
var label = GetPageArg("ctxtname",false);
|
|
||||||
if (!label) return;
|
|
||||||
var indicator = document.getElementById("contextindicator");
|
|
||||||
if (!indicator) return;
|
|
||||||
indicator.innerHTML = label;
|
|
||||||
indicator.style.display = "block";
|
|
||||||
});
|
|
||||||
|
|
@ -1,429 +0,0 @@
|
||||||
|
|
||||||
/* CSS seems backward: List all the classes for which we want a
|
|
||||||
particular font, so that the font can be changed in one place. (It
|
|
||||||
would be nicer to reference a font definition from all the places
|
|
||||||
that we want it.)
|
|
||||||
|
|
||||||
As you read the rest of the file, remember to double-check here to
|
|
||||||
see if any font is set. */
|
|
||||||
|
|
||||||
/* Monospace: */
|
|
||||||
.maincolumn, .refpara, .tocset, .stt, .hspace {
|
|
||||||
font-family: monospace;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Serif: */
|
|
||||||
.main, .refcontent, .tocview, .tocsub, i {
|
|
||||||
font-family: serif;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Sans-serif: */
|
|
||||||
.version, .versionNoNav {
|
|
||||||
font-family: sans-serif;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
|
|
||||||
p, .SIntrapara {
|
|
||||||
display: block;
|
|
||||||
margin: 1em 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
h2 { /* per-page main title */
|
|
||||||
margin-top: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
h3, h4, h5, h6, h7, h8 {
|
|
||||||
margin-top: 1.75em;
|
|
||||||
margin-bottom: 0.5em;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Needed for browsers like Opera, and eventually for HTML 4 conformance.
|
|
||||||
This means that multiple paragraphs in a table element do not have a space
|
|
||||||
between them. */
|
|
||||||
table p {
|
|
||||||
margin-top: 0;
|
|
||||||
margin-bottom: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Main */
|
|
||||||
|
|
||||||
body {
|
|
||||||
color: black;
|
|
||||||
background-color: #ffffff;
|
|
||||||
}
|
|
||||||
|
|
||||||
table td {
|
|
||||||
padding-left: 0;
|
|
||||||
padding-right: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.maincolumn {
|
|
||||||
width: 43em;
|
|
||||||
margin-right: -40em;
|
|
||||||
margin-left: 15em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.main {
|
|
||||||
text-align: left;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Navigation */
|
|
||||||
|
|
||||||
.navsettop, .navsetbottom {
|
|
||||||
background-color: #f0f0e0;
|
|
||||||
padding: 0.25em 0 0.25em 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.navsettop {
|
|
||||||
margin-bottom: 1.5em;
|
|
||||||
border-bottom: 2px solid #e0e0c0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.navsetbottom {
|
|
||||||
margin-top: 2em;
|
|
||||||
border-top: 2px solid #e0e0c0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.navleft {
|
|
||||||
margin-left: 1ex;
|
|
||||||
position: relative;
|
|
||||||
float: left;
|
|
||||||
white-space: nowrap;
|
|
||||||
}
|
|
||||||
.navright {
|
|
||||||
margin-right: 1ex;
|
|
||||||
position: relative;
|
|
||||||
float: right;
|
|
||||||
white-space: nowrap;
|
|
||||||
}
|
|
||||||
.nonavigation {
|
|
||||||
color: #e0e0e0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.searchform {
|
|
||||||
display: inline;
|
|
||||||
margin: 0;
|
|
||||||
padding: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.searchbox {
|
|
||||||
width: 16em;
|
|
||||||
margin: 0px;
|
|
||||||
padding: 0px;
|
|
||||||
background-color: #eee;
|
|
||||||
border: 1px solid #ddd;
|
|
||||||
text-align: center;
|
|
||||||
vertical-align: middle;
|
|
||||||
}
|
|
||||||
|
|
||||||
#contextindicator {
|
|
||||||
position: fixed;
|
|
||||||
background-color: #c6f;
|
|
||||||
color: #000;
|
|
||||||
font-family: monospace;
|
|
||||||
font-weight: bold;
|
|
||||||
padding: 2px 10px;
|
|
||||||
display: none;
|
|
||||||
right: 0;
|
|
||||||
bottom: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Version */
|
|
||||||
|
|
||||||
.versionbox {
|
|
||||||
position: relative;
|
|
||||||
float: right;
|
|
||||||
left: 2em;
|
|
||||||
height: 0em;
|
|
||||||
width: 13em;
|
|
||||||
margin: 0em -13em 0em 0em;
|
|
||||||
}
|
|
||||||
.version {
|
|
||||||
font-size: small;
|
|
||||||
}
|
|
||||||
.versionNoNav {
|
|
||||||
font-size: xx-small; /* avoid overlap with author */
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Margin notes */
|
|
||||||
|
|
||||||
.refpara, .refelem {
|
|
||||||
position: relative;
|
|
||||||
float: right;
|
|
||||||
left: 2em;
|
|
||||||
height: 0em;
|
|
||||||
width: 13em;
|
|
||||||
margin: 0em -13em 0em 0em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.refpara {
|
|
||||||
top: -1em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.refcolumn {
|
|
||||||
background-color: #F5F5DC;
|
|
||||||
display: block;
|
|
||||||
position: relative;
|
|
||||||
width: 13em;
|
|
||||||
font-size: 85%;
|
|
||||||
border: 0.5em solid #F5F5DC;
|
|
||||||
margin: 0 0 0 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.refcontent {
|
|
||||||
margin: 0 0 0 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.refcontent p {
|
|
||||||
margin-top: 0;
|
|
||||||
margin-bottom: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Table of contents, inline */
|
|
||||||
|
|
||||||
.toclink {
|
|
||||||
text-decoration: none;
|
|
||||||
color: blue;
|
|
||||||
font-size: 85%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.toptoclink {
|
|
||||||
text-decoration: none;
|
|
||||||
color: blue;
|
|
||||||
font-weight: bold;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Table of contents, left margin */
|
|
||||||
|
|
||||||
.tocset {
|
|
||||||
position: relative;
|
|
||||||
float: left;
|
|
||||||
width: 12.5em;
|
|
||||||
margin-right: 2em;
|
|
||||||
}
|
|
||||||
.tocset td {
|
|
||||||
vertical-align: text-top;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocview {
|
|
||||||
text-align: left;
|
|
||||||
background-color: #f0f0e0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsub {
|
|
||||||
text-align: left;
|
|
||||||
margin-top: 0.5em;
|
|
||||||
background-color: #f0f0e0;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewlist, .tocsublist {
|
|
||||||
margin-left: 0.2em;
|
|
||||||
margin-right: 0.2em;
|
|
||||||
padding-top: 0.2em;
|
|
||||||
padding-bottom: 0.2em;
|
|
||||||
}
|
|
||||||
.tocviewlist table {
|
|
||||||
font-size: 82%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
|
|
||||||
margin-left: 0.4em;
|
|
||||||
border-left: 1px solid #bbf;
|
|
||||||
padding-left: 0.8em;
|
|
||||||
}
|
|
||||||
.tocviewsublist {
|
|
||||||
margin-bottom: 1em;
|
|
||||||
}
|
|
||||||
.tocviewsublist table,
|
|
||||||
.tocviewsublistonly table,
|
|
||||||
.tocviewsublisttop table,
|
|
||||||
.tocviewsublistbottom table {
|
|
||||||
font-size: 75%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewtitle * {
|
|
||||||
font-weight: bold;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewlink {
|
|
||||||
text-decoration: none;
|
|
||||||
color: blue;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewselflink {
|
|
||||||
text-decoration: underline;
|
|
||||||
color: blue;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocviewtoggle {
|
|
||||||
text-decoration: none;
|
|
||||||
color: blue;
|
|
||||||
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsublist td {
|
|
||||||
padding-left: 1em;
|
|
||||||
text-indent: -1em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsublinknumber {
|
|
||||||
font-size: 82%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsublink {
|
|
||||||
font-size: 82%;
|
|
||||||
text-decoration: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsubseclink {
|
|
||||||
font-size: 82%;
|
|
||||||
text-decoration: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsubnonseclink {
|
|
||||||
font-size: 82%;
|
|
||||||
text-decoration: none;
|
|
||||||
padding-left: 0.5em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.tocsubtitle {
|
|
||||||
font-size: 82%;
|
|
||||||
font-style: italic;
|
|
||||||
margin: 0.2em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.sepspace {
|
|
||||||
font-size: 40%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.septitle {
|
|
||||||
font-size: 70%;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ---------------------------------------- */
|
|
||||||
/* Some inline styles */
|
|
||||||
|
|
||||||
.indexlink {
|
|
||||||
text-decoration: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
.nobreak {
|
|
||||||
white-space: nowrap;
|
|
||||||
}
|
|
||||||
|
|
||||||
.stt {
|
|
||||||
}
|
|
||||||
|
|
||||||
.title {
|
|
||||||
font-size: 200%;
|
|
||||||
font-weight: normal;
|
|
||||||
margin-top: 2.8em;
|
|
||||||
text-align: center;
|
|
||||||
}
|
|
||||||
|
|
||||||
pre { margin-left: 2em; }
|
|
||||||
blockquote { margin-left: 2em; }
|
|
||||||
|
|
||||||
ol { list-style-type: decimal; }
|
|
||||||
ol ol { list-style-type: lower-alpha; }
|
|
||||||
ol ol ol { list-style-type: lower-roman; }
|
|
||||||
ol ol ol ol { list-style-type: upper-alpha; }
|
|
||||||
|
|
||||||
i {
|
|
||||||
}
|
|
||||||
|
|
||||||
.SubFlow {
|
|
||||||
display: block;
|
|
||||||
margin: 0em;
|
|
||||||
}
|
|
||||||
|
|
||||||
.boxed {
|
|
||||||
width: 100%;
|
|
||||||
background-color: #E8E8FF;
|
|
||||||
}
|
|
||||||
|
|
||||||
.hspace {
|
|
||||||
}
|
|
||||||
|
|
||||||
.slant {
|
|
||||||
font-style: oblique;
|
|
||||||
}
|
|
||||||
|
|
||||||
.badlink {
|
|
||||||
text-decoration: underline;
|
|
||||||
color: red;
|
|
||||||
}
|
|
||||||
|
|
||||||
.plainlink {
|
|
||||||
text-decoration: none;
|
|
||||||
color: blue;
|
|
||||||
}
|
|
||||||
|
|
||||||
.techoutside { text-decoration: underline; color: #b0b0b0; }
|
|
||||||
.techoutside:hover { text-decoration: underline; color: blue; }
|
|
||||||
|
|
||||||
/* .techinside:hover doesn't work with FF, .techinside:hover>
|
|
||||||
.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;
|
|
||||||
}
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
||||||
|
|
@ -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))))))
|
|
||||||
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
#lang scheme/base
|
|
||||||
(require (planet sbloch/picturing-programs:2))
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
;; 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.
|
;; 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 ())))
|
#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")))))
|
||||||
(require picturing-programs)
|
|
||||||
|
|
||||||
; Test cases for primitives:
|
; Test cases for primitives:
|
||||||
(check-expect (real->int 3.2) 3)
|
(check-expect (real->int 3.2) 3)
|
||||||
|
|
@ -132,13 +132,13 @@
|
||||||
"tri:" tri
|
"tri:" tri
|
||||||
"(map-image color-id tri):"
|
"(map-image color-id tri):"
|
||||||
(define ex1 (map-image color-id tri)) ex1
|
(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
|
(define ex2 (map-image kill-red tri)) ex2
|
||||||
"(map-image kill-red-preserving-alpha tri):"
|
"(map-image kill-red-preserving-alpha tri):"
|
||||||
(define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime
|
(define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime
|
||||||
"(map-image make-gradient tri):"
|
"(map-image make-gradient tri):"
|
||||||
(define ex3 (map-image make-gradient tri)) ex3
|
(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
|
(define ex4 (map-image kill-red hieroglyphics)) ex4
|
||||||
"(map-image kill-red scheme-logo):"
|
"(map-image kill-red scheme-logo):"
|
||||||
(define ex5 (map-image kill-red scheme-logo)) ex5
|
(define ex5 (map-image kill-red scheme-logo)) ex5
|
||||||
|
|
@ -259,15 +259,20 @@ fuzzy-tri
|
||||||
(make-gray (quotient (+ (color-red c)
|
(make-gray (quotient (+ (color-red c)
|
||||||
(color-green c)
|
(color-green c)
|
||||||
(color-blue c))
|
(color-blue c))
|
||||||
3)))
|
3)
|
||||||
|
(color-alpha c)))
|
||||||
|
|
||||||
; make-gray : natural -> color
|
; make-gray : natural(value) natural(alpha) -> color
|
||||||
(define (make-gray n)
|
(define (make-gray value alpha)
|
||||||
(make-color n n n))
|
(make-color value value value alpha))
|
||||||
|
|
||||||
; color->gray : image -> image
|
; color->gray : image -> image
|
||||||
(define (color->gray pic)
|
(define (color->gray pic)
|
||||||
(map-image pixel->gray pic))
|
(map-image pixel->gray pic))
|
||||||
|
|
||||||
|
"(color->gray bloch):"
|
||||||
(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)
|
||||||
|
|
@ -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")
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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"))
|
|
||||||
|
|
@ -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)])
|
|
||||||
|
|
@ -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))))))
|
|
||||||
|
|
@ -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")))
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
mred balls.ss &
|
|
||||||
./player carl &
|
|
||||||
./player sam &
|
|
||||||
Loading…
Reference in New Issue
Block a user