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.
|
||||
; Doesn't work with a literal image, but it works to use a "bitmap"
|
||||
; reference to a file that's included with the teachpacks. Dec. 21, 2010.
|
||||
|
||||
(require 2htdp/image)
|
||||
(require (only-in 2htdp/image bitmap))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -1,11 +1,12 @@
|
|||
#lang scribble/manual
|
||||
#lang scribble/doc
|
||||
@(require
|
||||
scribble/manual
|
||||
(for-label racket
|
||||
"main.rkt"
|
||||
"io-stuff.rkt"
|
||||
; "sb-universe.rkt"
|
||||
"tiles.rkt"
|
||||
"map-image.rkt"
|
||||
picturing-programs/main
|
||||
;picturing-programs/io-stuff
|
||||
;picturing-programs/tiles
|
||||
;picturing-programs/dummy
|
||||
; picturing-programs/map-image
|
||||
2htdp/image
|
||||
teachpack/2htdp/universe
|
||||
(only-in lang/htdp-beginner check-expect)
|
||||
|
|
@ -16,19 +17,20 @@
|
|||
@author{Stephen Bloch}
|
||||
|
||||
@; defmodule[installed-teachpack/picturing-programs]
|
||||
@defmodule[(planet sbloch/picturing-programs)]
|
||||
@defmodule[picturing-programs]
|
||||
|
||||
@section{About This Teachpack}
|
||||
|
||||
@;Testing, testing: @racket[(list 'testing 1 2 3)].
|
||||
@;
|
||||
@;This is a reference to the @racket[list] function.
|
||||
@;Now a reference to @racket[triangle],
|
||||
@;and @racket[big-bang],
|
||||
@;and @racket[show-it],
|
||||
@;and @racket[crop-top],
|
||||
@;and @racket[map-image],
|
||||
@;and @racket[with-input-from-url],
|
||||
@;This is a reference to the @racket[list] function (which is a nice link).
|
||||
@;Now a reference to @racket[triangle] (good link),
|
||||
@;and @racket[big-bang] (good link),
|
||||
@;and @racket[show-it] (good link),
|
||||
@;and @racket[crop-top] (underlined in red, not a link),
|
||||
@;and @racket[map-image] (underlined in red, not a link),
|
||||
@;and @racket[dummyvar] (how does this look?),
|
||||
@;and @racket[with-input-from-url] (underlined in red, not a link),
|
||||
@;which are defined in several different places.
|
||||
|
||||
Provides a variety of functions for combining and manipulating images
|
||||
|
|
@ -46,7 +48,7 @@ This package includes all of
|
|||
@racketmodlink[2htdp/image]{the image teachpack} and
|
||||
and
|
||||
@racketmodlink[2htdp/universe]{the universe teachpack},
|
||||
so if you're using this teachpack, @emph{don't} also load either of those.
|
||||
so if you're using this teachpack, @italic{don't} also load either of those.
|
||||
See the above links for how to use those teachpacks.
|
||||
|
||||
It also supersedes the older @racket[tiles] and @racket[sb-world] teachpacks,
|
||||
|
|
@ -114,18 +116,46 @@ you want to manipulate a picture pixel-by-pixel.
|
|||
|
||||
@subsection{Colors and pixels}
|
||||
|
||||
@defproc[(name->color [name string?])
|
||||
(or/c color? false/c)]{
|
||||
Each pixel of a bitmap image has a @racket[color], a built-in structure with
|
||||
four components -- red, green, blue, and alpha -- each represented by an
|
||||
integer from 0 to 255. Larger alpha values are "more opaque": an image with
|
||||
alpha=255 is completely opaque, and one with alpha=0 is completely
|
||||
transparent.
|
||||
|
||||
Given a color name like "red", "turquoise", "forest green", @italic{etc.}, returns the corresponding
|
||||
color struct, showing the red, green, and blue components. If the name isn't
|
||||
Even if you're not trying to get transparency effects, alpha is also used
|
||||
for dithering to smooth out jagged edges. In
|
||||
@racket[(circle 50 "solid" "red")], the pixels inside the circle are pure
|
||||
red, with alpha=255; the pixels outside the circle are transparent (alpha=0);
|
||||
and the pixels on the boundary are red with various alpha values (for example,
|
||||
if one quarter of a pixel's area is inside
|
||||
the mathematical boundary of the circle, that pixel's alpha value will be
|
||||
63).
|
||||
|
||||
@defproc[(name->color [name (or/c string? symbol?)])
|
||||
(or/c color? false/c)]{
|
||||
Given a color name like "red", 'turquoise, "forest green", @italic{etc.}, returns the corresponding
|
||||
color struct, showing the red, green, blue, and alpha components. If the name isn't
|
||||
recognized, returns @racket[false].}
|
||||
|
||||
@defproc[(colorize [thing (or/c color? string? symbol? false/c)])
|
||||
(or/c color? false/c)]{
|
||||
Similar to @racket[name->color], but accepts colors and @racket[false] as
|
||||
well: colors produce themselves, while @racket[false] produces a transparent
|
||||
color.}
|
||||
|
||||
@defproc[(color=? [c1 (or/c color? string? symbol? false/c)]
|
||||
[c2 (or/c color? string? symbol? false/c)])
|
||||
boolean?]{
|
||||
Compares two colors for equality. As with @racket[colorize], treats
|
||||
@racket[false] as a transparent color (i.e. with an alpha-component of 0).
|
||||
All colors with alpha=0 are considered equal to one another, even if they have
|
||||
different red, green, or blue components.}
|
||||
|
||||
@defproc[(get-pixel-color [x natural-number/c] [y natural-number/c] [pic image?])
|
||||
color?]{
|
||||
|
||||
Gets the color of a specified pixel in the given image. If x and/or y are outside the
|
||||
bounds of the image, returns black.}
|
||||
Gets the color of a specified pixel in the given image. If x and/or y are outside
|
||||
the bounds of the image, returns a transparent color.}
|
||||
|
||||
@subsection{Specifying the color of each pixel of an image}
|
||||
@defproc[(build-image [width natural-number/c]
|
||||
|
|
@ -148,14 +178,24 @@ on the coordinates of each pixel. For example,
|
|||
produces a fuzzy version of the given picture by replacing each pixel with a
|
||||
randomly chosen pixel near it.}
|
||||
|
||||
@defproc[(build4-image [width natural-number/c] [height natural-number/c]
|
||||
[red-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||
[green-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||
[blue-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||
[alpha-function (-> natural-number/c natural-number/c
|
||||
natural-number/c)])
|
||||
image?]{
|
||||
A version of @racket[build-image] for students who don't know about structs yet.
|
||||
Each of the four functions takes in the x and y coordinates of a pixel, and
|
||||
should return an integer from 0 through 255 to determine that color component.}
|
||||
|
||||
@defproc[(build3-image [width natural-number/c] [height natural-number/c]
|
||||
[red-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||
[green-function (-> natural-number/c natural-number/c natural-number/c)]
|
||||
[blue-function (-> natural-number/c natural-number/c natural-number/c)])
|
||||
image?]{
|
||||
A version of @racket[build-image] for students who don't know about structs yet.
|
||||
Each of the three functions takes in the x and y coordinates of a pixel, and
|
||||
should return an integer from 0 through 255 to determine that color component.}
|
||||
Just like @racket[build4-image], but without specifying the alpha component
|
||||
(which defaults to 255, fully opaque).}
|
||||
|
||||
@defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?])
|
||||
image?]{
|
||||
|
|
@ -170,49 +210,97 @@ size and shape. For example,
|
|||
produces a copy of @racket[my-picture] with all the red leached out,
|
||||
leaving only the blue and green components.
|
||||
|
||||
Since @racket[make-color] with three arguments defaults alpha to 255,
|
||||
this function discards any alpha information (including edge-dithering)
|
||||
that was in the original image. To preserve this information, one could write
|
||||
@racketblock[
|
||||
(define (lose-red-but-not-alpha x y old-color)
|
||||
(make-color 0 (color-green old-color) (color-blue old-color) (color-alpha
|
||||
old-color)))]
|
||||
|
||||
Another example:
|
||||
@racketblock[
|
||||
(define (apply-gradient x y old-color)
|
||||
(make-color (min (* 3 x) 255) 0 (min (* 3 y) 255)))
|
||||
(make-color (min (* 3 x) 255)
|
||||
0
|
||||
(min (* 3 y) 255)))
|
||||
|
||||
(map-image apply-gradient my-picture)]
|
||||
produces a picture the same size and shape as @racket[my-picture],
|
||||
but with a smooth color gradient with red increasing from left to
|
||||
produces a picture the size of @racket[my-picture]'s bounding rectangle,
|
||||
with a smooth color gradient with red increasing from left to
|
||||
right and blue increasing from top to bottom.}
|
||||
|
||||
@defproc[(map3-image
|
||||
@defproc[(map4-image
|
||||
[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[alpha-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[img image?])
|
||||
image?]{
|
||||
|
||||
A version of map-image for students who don't know about structs yet. Each of the
|
||||
four given functions is assumed to have the contract
|
||||
@racketblock[num(x) num(y) num(r) num(g) num(b) num(alpha) -> num]
|
||||
For each pixel in the original picture, applies the four
|
||||
functions to the x coordinate, y coordinate, red, green, blue, and alpha
|
||||
components of the pixel.
|
||||
The results of the four functions are used as the red, green, blue, and alpha
|
||||
components in the corresponding pixel of the resulting picture.
|
||||
|
||||
For example,
|
||||
@racketblock[
|
||||
(define (zero x y r g b a) 0)
|
||||
(define (same-g x y r g b a) g)
|
||||
(define (same-b x y r g b a) b)
|
||||
(define (same-alpha x y r g b a) a)
|
||||
(map4-image zero same-g same-b same-alpha my-picture)]
|
||||
produces a copy of @racket[my-picture] with all the red leached out,
|
||||
leaving only the blue, green, and alpha components.
|
||||
|
||||
@racketblock[
|
||||
(define (3x x y r g b a) (min (* 3 x) 255))
|
||||
(define (3y x y r g b a) (min (* 3 y) 255))
|
||||
(define (return-255 x y r g b a) 255)
|
||||
(map4-image 3x zero 3y return-255 my-picture)]
|
||||
produces an opaque picture the size of @racket[my-picture]'s bounding rectangle,
|
||||
with a smooth color gradient with red increasing from left to
|
||||
right and blue increasing from top to bottom.
|
||||
}
|
||||
|
||||
@defproc[(map3-image
|
||||
[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
|
||||
[img image?])
|
||||
image?]{
|
||||
Like @racket[map4-image], but not specifying the alpha component. Note that
|
||||
the red, green, and blue functions also @italic{don't take in} alpha values.
|
||||
Each of the three given functions is assumed to have the contract
|
||||
@racketblock[num(x) num(y) num(r) num(g) num(b) -> num]
|
||||
For each pixel in the original picture, applies the three functions to the x
|
||||
coordinate, y coordinate, red, green, and blue components of the pixel.
|
||||
The results are used as a the red, green, and blue components in the
|
||||
corresponding pixel of the resulting picture.
|
||||
|
||||
A version of map-image for students who don't know about structs yet. Each of the three given functions is assumed
|
||||
to have the contract @racketblock[num(x) num(y) num(r) num(g) num(b) -> num ]
|
||||
For each pixel in the original picture, applies the three
|
||||
functions to the x coordinate, y coordinate, red, green, and blue components of the picture.
|
||||
The result of the first function is used as the red component, the second as green, and the third as blue
|
||||
in the corresponding pixel of the resulting picture.
|
||||
|
||||
For example,
|
||||
The alpha component in the resulting picture is copied from the source
|
||||
picture. For example,
|
||||
@racketblock[
|
||||
(define (zero x y r g b) 0)
|
||||
(define (same-g x y r g b) g)
|
||||
(define (same-b x y r g b) b)
|
||||
(map3-image zero same-g same-b my-picture)]
|
||||
produces a copy of @racket[my-picture] with all the red leached out,
|
||||
leaving only the blue and green components.
|
||||
|
||||
produces a copy of @racket[my-picture] with all the red leached out; parts of
|
||||
the picture that were transparent are still transparent, and parts that were
|
||||
dithered are still dithered.
|
||||
@racketblock[
|
||||
(define (3x x y r g b) (min (* 3 x) 255))
|
||||
(define (3y x y r g b) (min (* 3 y) 255))
|
||||
(map3-image 3x zero 3y my-picture)]
|
||||
produces a picture the same size and shape as @racket[my-picture],
|
||||
but with a smooth color gradient with red increasing from left to
|
||||
right and blue increasing from top to bottom.}
|
||||
(define (3x x y r g b a) (min (* 3 x) 255))
|
||||
(define (3y x y r g b a) (min (* 3 y) 255))
|
||||
(map3-image zero 3x 3y my-picture)]
|
||||
produces a @racket[my-picture]-shaped "window" on a color-gradient.
|
||||
}
|
||||
|
||||
@defproc[(real->int [num real?])
|
||||
integer?]{
|
||||
|
||||
Not specific to colors, but useful if you're building colors by arithmetic.
|
||||
For example,
|
||||
@racketblock[
|
||||
|
|
@ -227,37 +315,6 @@ The version using @racket[bad-gradient] crashes because color components must be
|
|||
The version using @racket[good-gradient] works.}
|
||||
|
||||
|
||||
@subsection{Transparency}
|
||||
Some image formats support @italic{transparency}, meaning that part of the image is
|
||||
ignored when layering it with other images.
|
||||
|
||||
@defproc[(pixel-visible? [x natural-number/c] [y natural-number/c] [pic image?])
|
||||
boolean?]{
|
||||
|
||||
Checks transparency: returns @racket[false] if the specified pixel in the image is transparent,
|
||||
@racket[true] if not.}
|
||||
|
||||
A @deftech{maybe-color} is either a color or @racket[false], which is treated as transparent.
|
||||
|
||||
@defproc[(maybe-color? [thing any/c])
|
||||
boolean?]{
|
||||
|
||||
Tests whether the argument is a @tech{maybe-color}.}
|
||||
|
||||
@defproc[(map-masked-image [f (-> natural-number/c natural-number/c maybe-color? maybe-color?)] [pic image?])
|
||||
image?]{
|
||||
|
||||
Like @racket[map-image], but the function will receive @racket[false] for any transparent pixel, and
|
||||
any place that it returns @racket[false] will be treated as a transparent pixel.}
|
||||
|
||||
@defproc[(build-masked-image [width natural-number/c]
|
||||
[height natural-number/c]
|
||||
[f (-> natural-number/c natural-number/c maybe-color?)])
|
||||
image?]{
|
||||
|
||||
Like @racket[build-image], but any place that the function returns @racket[false] will be treated
|
||||
as a transparent pixel.}
|
||||
|
||||
@section{Input and Output}
|
||||
This teachpack also provides several functions to help in testing
|
||||
I/O functions (in Advanced Student language; ignore this section if
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
`("The picturing-programs collection supersedes the tiles and sb-world collections. It provides functions to rotate, etc. images, as well as a slightly modified version of the universe teachpack."))
|
||||
(define release-notes '(
|
||||
(p "Version 2.5: Re-enabled diagonal reflection. Moved into the bundle
|
||||
(so it doesn't require a PLaneT install). Added some picture variables.")
|
||||
(so it doesn't require a PLaneT install). Added some picture variables.
|
||||
Rewrote a bunch of things for compatibility with 5.1.")
|
||||
(p "Version 2.4: Added change-to-color and map3-image. Cleaned up documentation.")
|
||||
(p "Version 2.3: Renamed files from .ss to .rkt, so they work better with Racket. Added map-image, build-image, name->color, and friends; re-fixed bug in rotate-cw and rotate-ccw.")
|
||||
(p "Version 2.2: Fixed bug in rotate-cw and rotate-ccw; restored reflect-vert and reflect-horiz; added with-input-from-url.")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang racket
|
||||
#lang racket/base
|
||||
(require racket/port lang/error net/url)
|
||||
(provide with-input-from-string
|
||||
with-output-to-string
|
||||
|
|
|
|||
|
|
@ -1,18 +1,18 @@
|
|||
#lang racket
|
||||
#lang racket/base
|
||||
(require 2htdp/universe
|
||||
htdp/error ; check-arg
|
||||
"tiles.rkt"
|
||||
"io-stuff.rkt"
|
||||
"map-image.rkt"
|
||||
"book-pictures.rkt")
|
||||
(provide (all-from-out "tiles.rkt") ; includes all-from-out 2htdp/image, plus a few simple add-ons
|
||||
(all-from-out "io-stuff.rkt") ; includes with-{input-from,output-to}-{string,file}, with-io-strings
|
||||
(all-from-out "map-image.rkt") ; includes (map,build)-[masked-]image, real->int, maybe-color?, name->color,
|
||||
; get-pixel-color, pixel-visible?
|
||||
(prefix-out pic: (all-from-out "book-pictures.rkt")) ; pic:calendar, pp:hacker, etc.
|
||||
)
|
||||
(provide show-it)
|
||||
(provide (all-from-out 2htdp/universe))
|
||||
(only-in htdp/error check-arg)
|
||||
picturing-programs/tiles
|
||||
picturing-programs/io-stuff
|
||||
picturing-programs/map-image
|
||||
picturing-programs/book-pictures)
|
||||
|
||||
(provide (all-from-out picturing-programs/tiles) ; includes all-from-out 2htdp/image, plus a few simple add-ons
|
||||
(all-from-out picturing-programs/io-stuff) ; includes with-{input-from,output-to}-{string,file}, with-io-strings
|
||||
(all-from-out picturing-programs/map-image)
|
||||
; includes (map,build)(3,4,)-image, real->int, name->color, colorize, get-pixel-color
|
||||
(prefix-out pic: (all-from-out picturing-programs/book-pictures)) ; pic:calendar, pp:hacker, etc.
|
||||
(all-from-out 2htdp/universe)
|
||||
show-it)
|
||||
|
||||
|
||||
(define (show-it img)
|
||||
|
|
|
|||
|
|
@ -14,8 +14,9 @@
|
|||
racket/snip
|
||||
racket/class
|
||||
2htdp/image
|
||||
(only-in htdp/error natural?)
|
||||
(only-in mrlib/image-core render-image))
|
||||
(require picturing-programs/book-pictures)
|
||||
;(require picturing-programs/book-pictures)
|
||||
|
||||
;(require mrlib/image-core)
|
||||
;(require 2htdp/private/image-more)
|
||||
|
|
@ -94,10 +95,10 @@
|
|||
(compose colorize f))
|
||||
|
||||
|
||||
; natural? : anything -> boolean
|
||||
(define (natural? it)
|
||||
(and (integer? it)
|
||||
(>= it 0)))
|
||||
;; natural? : anything -> boolean
|
||||
;(define (natural? it)
|
||||
; (and (integer? it)
|
||||
; (>= it 0)))
|
||||
|
||||
; color=? : broad-color broad-color -> boolean
|
||||
(define (color=? c1 c2)
|
||||
|
|
@ -111,95 +112,6 @@
|
|||
(= (color-green rc1) (color-green rc2))
|
||||
(= (color-blue rc1) (color-blue rc2)))))))
|
||||
|
||||
;; build-image-internal : nat(width) nat(height) (nat nat -> color) bitmap% -> image
|
||||
;(define (build-image-internal width height f mask-bm)
|
||||
;; (unless (and (natural? width) (natural? height))
|
||||
;; (error 'build-image "Expected natural numbers as first two arguments"))
|
||||
;; (unless (procedure-arity-includes? f 2)
|
||||
;; (error 'build-image "Expected function with contract number number -> color as third argument"))
|
||||
; (let* [[bm (make-bitmap width height)]
|
||||
; [bmdc (make-object bitmap-dc% bm)]
|
||||
; ]
|
||||
; (for* ((y (in-range height))
|
||||
; (x (in-range width)))
|
||||
; (send bmdc set-pixel x y (color->color% (f x y)))
|
||||
; ))
|
||||
; (send bmdc set-bitmap #f)
|
||||
; (make-image
|
||||
; (make-translate (quotient width 2) (quotient height 2)
|
||||
; (make-bitmap bm mask-bm 0 1 1 #f #f))
|
||||
; (make-bb width height height)
|
||||
; #f ; not normalized
|
||||
; )
|
||||
; )
|
||||
|
||||
;; build-image : natural(width) natural(height) (nat nat -> color) -> image
|
||||
;(define (build-image width height f)
|
||||
; (unless (and (natural? width) (natural? height))
|
||||
; (error 'build-image "Expected natural numbers as first two arguments"))
|
||||
; (unless (procedure-arity-includes? f 2)
|
||||
; (error 'build-image "Expected function with contract number number -> color as third argument"))
|
||||
; (if (or (zero? width) (zero? height)) ; bitmap% doesn't like zero-sized images
|
||||
; (rectangle width height "solid" "white")
|
||||
; (let* [[mask-bm (make-object bitmap% width height #t)] ; monochrome
|
||||
; [mask-bmdc (make-object bitmap-dc% mask-bm)]
|
||||
; [black (make-object color% 0 0 0)]]
|
||||
; (send mask-bmdc set-background black)
|
||||
; (send mask-bmdc clear)
|
||||
; ; (for ((y (in-range height)))
|
||||
; ; (for ((x (in-range width)))
|
||||
; ; (send mask-bmdc set-pixel x y black)))
|
||||
; ; can we replace this with (send mask-bmdc clear)?
|
||||
; (send mask-bmdc set-bitmap #f)
|
||||
; (build-image-internal width height f mask-bm)
|
||||
; )
|
||||
; )
|
||||
; )
|
||||
;
|
||||
;; build3-image: nat(width) nat(height) (nat nat -> nat) (nat nat -> nat) (nat nat -> nat) -> image
|
||||
;(define (build3-image width height rfunc gfunc bfunc)
|
||||
; (unless (and (natural? width) (natural? height))
|
||||
; (error 'build3-image "Expected natural numbers as first two arguments"))
|
||||
; (unless (procedure-arity-includes? rfunc 2)
|
||||
; (error 'build3-image "Expected function with contract number number -> number as third argument"))
|
||||
; (unless (procedure-arity-includes? gfunc 2)
|
||||
; (error 'build3-image "Expected function with contract number number -> number as fourth argument"))
|
||||
; (unless (procedure-arity-includes? bfunc 2)
|
||||
; (error 'build3-image "Expected function with contract number number -> number as fifth argument"))
|
||||
; (build-image width height
|
||||
; (lambda (x y) (make-color (rfunc x y) (gfunc x y) (bfunc x y)))))
|
||||
;
|
||||
;; build-masked-image : nat(width) nat(height) (nat nat -> maybe-color) -> image
|
||||
;(define (build-masked-image width height f)
|
||||
; (unless (and (natural? width) (natural? height))
|
||||
; (error 'build-masked-image "Expected natural numbers as first two arguments"))
|
||||
; (unless (procedure-arity-includes? f 2)
|
||||
; (error 'build-masked-image "Expected function with contract number number -> maybe-color as third argument"))
|
||||
; (if (or (zero? width) (zero? height)) ; bitmap% doesn't like zero-sized images
|
||||
; (rectangle width height "solid" "white")
|
||||
; (let* [[bm (make-object bitmap% width height)]
|
||||
; [bmdc (make-object bitmap-dc% bm)]
|
||||
; [mask-bm (make-object bitmap% width height #t)] ; monochrome
|
||||
; [mask-bmdc (make-object bitmap-dc% mask-bm)]
|
||||
; [visible (make-object color% 0 0 0)]
|
||||
; [transparent (make-object color% 255 255 255)]]
|
||||
; (for ((y (in-range height)))
|
||||
; (for ((x (in-range width)))
|
||||
; (let* [[mc (f x y)]
|
||||
; [color (if mc (color->color% mc) transparent)]
|
||||
; [mask (if mc visible transparent)]]
|
||||
; (send bmdc set-pixel x y color)
|
||||
; (send mask-bmdc set-pixel x y mask)
|
||||
; )))
|
||||
; (send bmdc set-bitmap #f)
|
||||
; (send mask-bmdc set-bitmap #f)
|
||||
; (make-image
|
||||
; (make-translate (quotient width 2) (quotient height 2)
|
||||
; (make-bitmap bm mask-bm 0 1 1 #f #f))
|
||||
; (make-bb width height height)
|
||||
; #f ; not normalized
|
||||
; )
|
||||
; )))
|
||||
|
||||
|
||||
|
||||
|
|
@ -401,25 +313,3 @@
|
|||
(bfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))
|
||||
(afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))))
|
||||
pic))
|
||||
|
||||
|
||||
;; map-masked-image : (int int maybe-color -> maybe-color) image -> image
|
||||
;(define (map-masked-image f pic)
|
||||
; (unless (procedure-arity-includes? f 3)
|
||||
; (error 'map-masked-image "Expected function with contract number number maybe-color -> maybe-color as first argument"))
|
||||
; (unless (image? pic)
|
||||
; (error 'map-masked-image "Expected image as second argument"))
|
||||
; (let* [[width (image-width pic)]
|
||||
; [height (image-height pic)]
|
||||
; [bm (make-object bitmap% width height)]
|
||||
; [bmdc (make-object bitmap-dc% bm)]
|
||||
; [mask (get-mask pic)]
|
||||
; ]
|
||||
; (render-image pic bmdc 0 0)
|
||||
; (build-masked-image
|
||||
; width height
|
||||
; (lambda (x y)
|
||||
; (f x y
|
||||
; (if (pixel-visible? x y pic)
|
||||
; (get-pixel-color x y pic)
|
||||
; #f))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
(require picturing-programs)
|
||||
#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ((lib "picturing-programs.rkt" "installed-teachpacks"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "picturing-programs.rkt" "installed-teachpacks")))))
|
||||
|
||||
|
||||
; Test cases for primitives:
|
||||
(check-expect (real->int 3.2) 3)
|
||||
|
|
@ -132,13 +132,13 @@
|
|||
"tri:" tri
|
||||
"(map-image color-id tri):"
|
||||
(define ex1 (map-image color-id tri)) ex1
|
||||
"(map-image kill-red tri):"
|
||||
"(map-image kill-red tri): should be green, on an opaque background with no red"
|
||||
(define ex2 (map-image kill-red tri)) ex2
|
||||
"(map-image kill-red-preserving-alpha tri):"
|
||||
(define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime
|
||||
"(map-image make-gradient tri):"
|
||||
(define ex3 (map-image make-gradient tri)) ex3
|
||||
"(map-image kill-red hieroglyphics):"
|
||||
"(map-image kill-red hieroglyphics): should be on an opaque background with no red"
|
||||
(define ex4 (map-image kill-red hieroglyphics)) ex4
|
||||
"(map-image kill-red scheme-logo):"
|
||||
(define ex5 (map-image kill-red scheme-logo)) ex5
|
||||
|
|
@ -259,15 +259,20 @@ fuzzy-tri
|
|||
(make-gray (quotient (+ (color-red c)
|
||||
(color-green c)
|
||||
(color-blue c))
|
||||
3)))
|
||||
3)
|
||||
(color-alpha c)))
|
||||
|
||||
; make-gray : natural -> color
|
||||
(define (make-gray n)
|
||||
(make-color n n n))
|
||||
; make-gray : natural(value) natural(alpha) -> color
|
||||
(define (make-gray value alpha)
|
||||
(make-color value value value alpha))
|
||||
|
||||
; color->gray : image -> image
|
||||
(define (color->gray pic)
|
||||
(map-image pixel->gray pic))
|
||||
|
||||
"(color->gray bloch):"
|
||||
(color->gray bloch)
|
||||
(color->gray hieroglyphics)
|
||||
"(overlay (color->gray hieroglyphics) bluebox):"
|
||||
(overlay (color->gray hieroglyphics) bluebox)
|
||||
"(overlay (color->gray (white->trans hieroglyphics)) bluebox):"
|
||||
(overlay (color->gray (white->trans hieroglyphics)) bluebox)
|
||||
|
|
@ -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