suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rewriting map-image to work with 5.1. Also added a bunch of test cases

Browse Source 
to map-image-bsl-tests.rkt.
This commit is contained in:
Stephen Bloch 2010-12-28 16:27:04 -05:00
parent fb25dc9a42
commit fb05266ad2
43 changed files with 8280 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/picturing-programs/book-pictures.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket
; 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)
(provide (all-defined-out))
(define bloch (bitmap "pictures/bloch.jpg"))
(define hieroglyphics (bitmap "pictures/small_hieroglyphics.png"))
(define hacker (bitmap "pictures/mad_hacker.png"))
(define book (bitmap "pictures/qbook.png"))
(define stick-figure (bitmap "pictures/stick-figure.png"))
(define scheme-logo (bitmap "pictures/schemelogo.png"))
(define calendar (bitmap "pictures/calendar.png"))

56
collects/picturing-programs/doc.html Normal file
View File

File diff suppressed because one or more lines are too long

336
collects/picturing-programs/doc.scrbl Normal file
View File

@ -0,0 +1,336 @@
#lang scribble/manual
@(require
(for-label racket
"main.rkt"
"io-stuff.rkt"
; "sb-universe.rkt"
"tiles.rkt"
"map-image.rkt"
2htdp/image
teachpack/2htdp/universe
(only-in lang/htdp-beginner check-expect)
))
@; teachpack["picturing-programs"]{Picturing Programs}
@title{Picturing Programs Teachpack}
@author{Stephen Bloch}
@; defmodule[installed-teachpack/picturing-programs]
@defmodule[(planet sbloch/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],
@;which are defined in several different places.
Provides a variety of functions for combining and manipulating images
and running interactive animations.
It's intended to be used with the textbook
@hyperlink["http://www.picturingprograms.com" "Picturing Programs"].
@section{Installation}
If you're reading this, you've probably already installed the teachpack successfully,
but if you need to install it on a different machine, ...
@itemize[#:style 'ordered
@item{start DrScheme}
@item{switch languages to ``Use the language declared in the
source'' and click ``Run''}
@item{in the Interactions pane, type
@racketblock[(require (planet sbloch/picturing-programs:2))]}
@item{after a few seconds, you should see the message
@racketoutput{Wrote file ``picturing-programs.rkt'' to installed-teachpacks directory.}}
@item{switch languages back to one of the HtDP languages, like Beginning Student}
@item{either
@itemize{
@item{in the Definitions pane, type
@racketblock[(require installed-teachpacks/picturing-programs)]
or}
@item{from the Language menu, choose "Add
Teachpack..." and select "picturing-programs.rkt"}
}
}
@item{click "Run"}
]
@section{Functions from image.rkt and universe.rkt}
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.
See the above links for how to use those teachpacks.
It also supersedes the older @racket[tiles] and @racket[sb-world] teachpacks,
so if you have those, don't load them either; use this instead.
This package also provides the following additional functions:
@; @include-section{image.rkt}
@section{New image functions}
@defproc[(rotate-cw [img image?])
image?]{Rotates an image 90 degrees clockwise.}
@defproc[(rotate-ccw [img image?])
image?]{Rotates an image 90 degrees counterclockwise.}
@defproc[(rotate-180 [img image?])
image?]{Rotates an image 180 degrees around its center.}
@defproc[(crop-top [img image?] [pixels natural-number/c])
image?]{Chops off the specified number of pixels from the top of the image.}
@defproc[(crop-bottom [img image?] [pixels natural-number/c])
image?]{Chops off the specified number of pixels from the bottom of the image.}
@defproc[(crop-left [img image?] [pixels natural-number/c])
image?]{Chops off the specified number of pixels from the left side of the image.}
@defproc[(crop-right [img image?] [pixels natural-number/c])
image?]{Chops off the specified number of pixels from the right side of the image.}
@defproc[(show-it [img image?])
image?]{Returns the given image unaltered. Useful as a draw handler for animations whose model is an image.}
@defproc[(reflect-vert [img image?])
image?]{The same as @racket[flip-vertical]; retained for compatibility.}
@defproc[(reflect-horiz [img image?])
image?]{The same as @racket[flip-horizontal]; retained for compatibility.}
@section{Variables}
This teachpack also defines variable names for some of the pictures used in the textbook.
@defthing[pic:bloch image?]{A picture of the author, c. 2005.}
@defthing[pic:hieroglyphics image?]{A picture of a stone tablet with
hieroglyphics on it.}
@defthing[pic:hacker image?]{A picture of a student sitting at a
computer.}
@defthing[pic:book image?]{A picture of a book with a question mark.}
@defthing[pic:stick-figure image?]{A picture of a stick figure, built
from geometric primitives.}
@defthing[pic:scheme-logo image?]{A picture of a DrScheme/DrRacket
logo.}
@defthing[pic:calendar image?]{A picture of an appointment calendar.}
Note that these seven variable names happen to start with "pic:", to
distinguish them from anything you might define that happens to be named
"calendar" or "book", but you can name a variable anything you want; in
particular, there's no requirement that your names start with "pic:".
@section{Pixel functions}
The above functions allow you to operate on a picture as a whole, but sometimes
you want to manipulate a picture pixel-by-pixel.
@subsection{Colors and pixels}
@defproc[(name->color [name string?])
(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, and blue components. If the name isn't
recognized, returns @racket[false].}
@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.}
@subsection{Specifying the color of each pixel of an image}
@defproc[(build-image [width natural-number/c]
[height natural-number/c]
[f (-> natural-number/c natural-number/c color?)])
image?]{
Builds an image of the specified size and shape by calling the specified function
on the coordinates of each pixel. For example,
@racketblock[
(define (fuzz pic)
(local [(define (near-pixel x y)
(get-pixel-color (+ x -3 (random 7))
(+ y -3 (random 7))
pic))]
(build-image (image-width pic)
(image-height pic)
near-pixel)))
]
produces a fuzzy version of the given picture by replacing each pixel with a
randomly chosen pixel near it.}
@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.}
@defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?])
image?]{
Applies the given function to each pixel in a given image, producing a new image the same
size and shape. For example,
@racketblock[
(define (lose-red x y old-color)
(make-color 0 (color-green old-color) (color-blue old-color)))
(map-image lose-red my-picture)]
produces a copy of @racket[my-picture] with all the red leached out,
leaving only the blue and green components.
@racketblock[
(define (apply-gradient x y old-color)
(make-color (min (* 3 x) 255) 0 (min (* 3 y) 255)))
(map-image apply-gradient my-picture)]
produces a picture the same size and shape as @racket[my-picture],
but 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?]{
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,
@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.
@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.}
@defproc[(real->int [num real?])
integer?]{
Not specific to colors, but useful if you're building colors by arithmetic.
For example,
@racketblock[
(define (bad-gradient x y)
(make-color (* 2.5 x) (* 1.6 y) 0))
(build-image 50 30 bad-gradient)
(define (good-gradient x y)
(make-color (real->int (* 2.5 x)) (real->int (* 1.6 y)) 0))
(build-image 50 30 good-gradient)
]
The version using @racket[bad-gradient] crashes because color components must be exact integers.
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
you're in a Beginner or Intermediate language):
@defproc[(with-input-from-string [input string?]
[thunk (-> any/c)])
any/c]{
Calls @tt{thunk}, which presumably uses @racket[read],
in such a way that @racket[read] reads from @tt{input} rather than from
the keyboard.}
@defproc[(with-output-to-string [thunk (-> any/c)])
string?]{
Calls @tt{thunk}, which presumably uses @racket[display], @racket[print],
@racket[write], and/or @racket[printf], in such a way that its output is
accumlated into a string, which is then returned.}
@defproc[(with-input-from-file [filename string?]
[thunk (-> any/c)]) any/c]{
Calls @tt{thunk}, which presumably uses @racket[read],
in such a way that @racket[read] reads from the specified file
rather than from the keyboard.}
@defproc[(with-output-to-file (filename string?) (thunk (-> any/c))) any/c]{
Calls @tt{thunk}, which presumably uses @racket[display], @racket[print],
@racket[write], and/or @racket[printf], in such a way that its output is
redirected into the specified file.}
@defproc[(with-input-from-url (url string?) (thunk (-> any/c))) any/c]{
Calls @tt{thunk}, which presumably uses @racket[read],
in such a way that @racket[read] reads from the HTML source of the
Web page at the specified URL rather than from the keyboard.}
@defproc[(with-io-strings (input string?) (thunk (-> any/c))) string?]{
Combines @racket[with-input-from-string] and @racket[with-output-to-string]:
calls @tt{thunk} with its input coming from @tt{input} and accumulates
its output into a string, which is returned. Especially useful for testing:
@racketblock[
(define (ask question)
(begin (display question)
(read)))
(define (greet)
(local [(define name (ask "What is your name?"))]
(printf "Hello, ~a!" name)))
(check-expect
(with-io-strings "Steve" greet)
"What is your name?Hello, Steve!")]
}
@; @include-section{worlds.scrbl}
@; @include-section{universes.scrbl}

4
collects/picturing-programs/dummy.rkt Normal file
View File

@ -0,0 +1,4 @@
;; 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 dummy) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require "main.rkt")

24
collects/picturing-programs/info.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang setup/infotab
(define name "picturing-programs")
(define categories '(media))
(define can-be-loaded-with 'all)
(define required-core-version "5.0.0.1")
(define primary-file "main.rkt")
(define scribblings '(("doc.scrbl" ())))
(define repositories '("4.x"))
(define blurb
`("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.")
(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.")
(p "Version 2.1: Added argument type-checking. And reflection primitives are now present but produce error message, rather than being missing.")
(p "Version 2.0: now fully compatible with 2htdp/image and 2htdp/universe. No pinholes; temporarily disabled reflection primitives.")
(p "Version 1.6: fixed same transparency bug for 4.2.4")
(p "Version 1.5: fixed same transparency bug for 4.2.3")
(p "Version 1.4: fixed transparency bug for 4.2.2")
(p "Version 1.3: initial release, for DrScheme 4.2.4")
(p "Version 1.2: initial release, for DrScheme 4.2.3")
(p "Version 1.1: initial release, for DrScheme 4.2.2")))

30
collects/picturing-programs/io-stuff.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang racket
(require racket/port lang/error net/url)
(provide with-input-from-string
with-output-to-string
with-input-from-file
with-output-to-file
with-input-from-url
with-io-strings)
; with-io-strings : input(string) thunk -> string
(define (with-io-strings input thunk)
(check-arg 'with-io-strings (string? input) "string" "first" input)
(check-arg 'with-io-strings (and (procedure? thunk)
(procedure-arity-includes? thunk 0))
"0-parameter function" "second" thunk)
(with-output-to-string
(lambda ()
(with-input-from-string input thunk))))
; with-input-from-url : url(string) thunk -> nothing
(define (with-input-from-url url-string thunk)
(check-arg 'with-input-from-url (string? url-string) "string" "first" url-string)
(check-arg 'with-input-from-url (and (procedure? thunk)
(procedure-arity-includes? thunk 0))
"0-parameter function" "second" thunk)
(call/input-url (string->url url-string)
get-pure-port
(lambda (port)
(current-input-port port)
(thunk))))

20
collects/picturing-programs/main.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang racket
(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))
(define (show-it img)
(check-arg 'show-it (image? img) "image" "first" img)
img)

431
collects/picturing-programs/map-image.rkt Normal file
View File

@ -0,0 +1,431 @@
#lang racket/base
; Spring 2010: started trying to get this to work.
; Late June 2010: Got build-image and map-image working.
; Added name->color and get-pixel-color.
; Added build-masked-image and map-masked-image.
; July 6, 2010: added change-to-color
; July 28, 2010: added map3-image and build3-image. Is change-to-color really useful?
; Dec. 26, 2010: added color=? to export (duh!)
; Dec. 26, 2010: API for bitmaps has changed for 5.1, so I need to rewrite to match it.
; Dec. 28, 2010: Robby added alphas into the "color" type, and provided an implementation
; of map-image. He recommends using racket/draw bitmaps rather than 2htdp/image bitmaps.
(require racket/draw
racket/snip
racket/class
2htdp/image
(only-in mrlib/image-core render-image))
(require picturing-programs/book-pictures)
;(require mrlib/image-core)
;(require 2htdp/private/image-more)
;; (require 2htdp/private/img-err)
;(require scheme/gui)
(require lang/prim)
(provide-primitives real->int
; maybe-color?
name->color
get-pixel-color
;pixel-visible?
; change-to-color
color=?
)
(provide-higher-order-primitive map-image (f _))
(provide-higher-order-primitive map3-image (rfunc gfunc bfunc _))
(provide-higher-order-primitive map4-image (rfunc gfunc bfunc afunc _))
;(provide-higher-order-primitive map-masked-image (f _))
(provide-higher-order-primitive build-image (_ _ f))
(provide-higher-order-primitive build3-image (_ _ rfunc gfunc bfunc))
(provide-higher-order-primitive build4-image (_ _ rfunc gfunc bfunc afunc))
;(provide-higher-order-primitive build-masked-image (_ _ f))
(define transparent (make-color 0 0 0 0))
(define (maybe-color? thing)
(or (color? thing)
(eqv? thing #f)
; (image-color? thing) ; handles string & symbol color names
))
(define (broad-color? thing)
(or (maybe-color? thing)
(image-color? thing)))
; color->color% : does the obvious
; Note that color% doesn't have an alpha component, so alpha is lost.
(define (color->color% c)
(if (string? c)
c
(make-object color%
(color-red c)
(color-green c)
(color-blue c))))
; color%->color : does the obvious, with alpha defaulting to full-opaque.
(define (color%->color c)
(make-color (send c red)
(send c green)
(send c blue)))
; name->color : string-or-symbol -> maybe-color
(define (name->color name)
(unless (or (string? name) (symbol? name))
(error 'name->color "argument must be a string or symbol"))
(let [[result (send the-color-database find-color
(if (string? name)
name
(symbol->string name)))]]
(if result
(color%->color result)
#f)))
;; lookup-if-nec : maybe-color -> maybe-color
;(define (lookup-if-nec c)
; (cond [(color? c)) c]
; [(or (string? c) (symbol? c)) (name->color c)]
; [(eqv? c #f) transparent]
; [else (error 'lookup-if-nec "Unrecognized type")]))
; colorize : broad-color -> color -- returns #f for unrecognized names
(define (colorize thing)
(cond [(color? thing) thing]
[(eqv? thing #f) transparent]
[(image-color? thing) (name->color thing)]
[else (error 'colorize "Unrecognized type")]))
; colorize-func : (... -> broad-color) -> (... -> color)
(define (colorize-func f)
(compose colorize f))
; natural? : anything -> boolean
(define (natural? it)
(and (integer? it)
(>= it 0)))
; color=? : broad-color broad-color -> boolean
(define (color=? c1 c2)
(let [[rc1 (colorize c1)]
[rc2 (colorize c2)]]
(unless (and (color? rc1) (color? rc2))
(error 'color=? "Expected two colors or color names as arguments"))
(and (= (color-alpha rc1) (color-alpha rc2)) ; Both alphas MUST be equal.
(or (= (color-alpha rc1) 0) ; If both are transparent, ignore rgb.
(and (= (color-red rc1) (color-red rc2))
(= (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
; )
; )))
(define (real->int num)
(inexact->exact (round num)))
; get-px : x y w h bytes -> color
(define (get-px x y w h bytes)
(define offset (* 4 (+ x (* y w))))
(make-color (bytes-ref bytes (+ offset 1))
(bytes-ref bytes (+ offset 2))
(bytes-ref bytes (+ offset 3))
(bytes-ref bytes offset)))
; set-px! : bytes x y w h color -> void
(define (set-px! bytes x y w h new-color)
(define offset (* 4 (+ x (* y w))))
(bytes-set! bytes offset (color-alpha new-color))
(bytes-set! bytes (+ offset 1) (color-red new-color))
(bytes-set! bytes (+ offset 2) (color-green new-color))
(bytes-set! bytes (+ offset 3) (color-blue new-color)))
; get-pixel-color : x y image -> color
; This will remember the last image on which it was called.
; Really terrible performance if you call it in alternation
; on two different images, but should be OK if you call it
; lots of times on the same image.
; Returns transparent if you ask about a position outside the picture.
(define get-pixel-color
(let [[last-image #f]
[last-bytes #f]]
(lambda (x y pic)
(define w (image-width pic))
(define h (image-height pic))
(unless (eqv? pic last-image)
; assuming nobody mutates an image between one get-pixel-color and the next
(set! last-image pic)
(define bm (make-bitmap w h))
(define bmdc (make-object bitmap-dc% bm))
(set! last-bytes (make-bytes (* 4 w h)))
(render-image pic bmdc 0 0)
(send bmdc set-bitmap #f)
(send bm get-argb-pixels 0 0 w h last-bytes))
(if (and (<= 0 x (sub1 w))
(<= 0 y (sub1 h)))
(get-px x y w h last-bytes)
transparent))))
;; pixel-visible? : nat(x) nat(y) image -> boolean
;; similar
;(define pixel-visible?
; (let [[last-image #f]
; [last-bm #f]
; [last-bmdc #f]]
; (lambda (x y pic)
; (unless (eqv? pic last-image)
; (set! last-image pic)
; (set! last-bm (get-mask pic))
; (set! last-bmdc (make-object bitmap-dc% last-bm)))
; (let [[mask-pix (get-px x y last-bmdc)]] ; assumes this doesn't crash if out of bounds
; (and (equal? mask-pix (make-color 0 0 0)) ; treat anything else as transparent
; (>= x 0)
; (>= y 0)
; (< x (image-width pic))
; (< y (image-height pic))
; )))))
;
; build-image-internal : natural(width) natural(height) (nat nat -> color) -> image
(define (build-image-internal w h f)
(define bm (make-bitmap w h))
(define bdc (make-object bitmap-dc% bm))
(define bytes (make-bytes (* w h 4)))
(for* ((y (in-range 0 h))
(x (in-range 0 w)))
(set-px! bytes x y w h (f x y)))
(send bm set-argb-pixels 0 0 w h bytes)
(make-object image-snip% bm))
; build-image : natural(width) natural(height) (nat nat -> broad-color) -> image
(define (build-image w h f)
(unless (natural? w)
(error 'build-image "Expected natural number as first argument"))
(unless (natural? h)
(error 'build-image "Expected natural number as second argument"))
(unless (procedure-arity-includes? f 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as third argument"))
(build-image-internal w h (colorize-func f)))
; build3-image : nat(width) nat(height) rfunc gfunc bfunc -> image
; where each of rfunc, gfunc, bfunc is (nat(x) nat(y) -> nat)
(define (build3-image w h rfunc gfunc bfunc)
(unless (natural? w)
(error 'build-image "Expected natural number as first argument"))
(unless (natural? h)
(error 'build-image "Expected natural number as second argument"))
(unless (procedure-arity-includes? rfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as third argument"))
(unless (procedure-arity-includes? gfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as fourth argument"))
(unless (procedure-arity-includes? bfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as fifth argument"))
(build-image-internal w h
(lambda (x y)
(make-color (rfunc x y) (gfunc x y) (bfunc x y)))))
; build4-image : nat(width) nat(height) rfunc gfunc bfunc afunc -> image
; where each of rfunc, gfunc, bfunc, afunc is (nat(x) nat(y) -> nat)
(define (build4-image w h rfunc gfunc bfunc afunc)
(unless (natural? w)
(error 'build-image "Expected natural number as first argument"))
(unless (natural? h)
(error 'build-image "Expected natural number as second argument"))
(unless (procedure-arity-includes? rfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as third argument"))
(unless (procedure-arity-includes? gfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as fourth argument"))
(unless (procedure-arity-includes? bfunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as fifth argument"))
(unless (procedure-arity-includes? afunc 2)
(error 'build-image "Expected function with contract num(x) num(y) -> color as sixth argument"))
(build-image-internal w h
(lambda (x y)
(make-color (rfunc x y) (gfunc x y) (bfunc x y) (afunc x y)))))
; map-image-internal : (int int color -> color) image -> image
(define (map-image-internal f img)
(define w (image-width img))
(define h (image-height img))
(define bm (make-bitmap w h))
(define bdc (make-object bitmap-dc% bm))
(render-image img bdc 0 0)
(send bdc set-bitmap #f)
(define bytes (make-bytes (* w h 4)))
(send bm get-argb-pixels 0 0 w h bytes)
(for* ((y (in-range 0 h))
(x (in-range 0 w)))
(set-px! bytes x y w h (f x y (get-px x y w h bytes))))
(send bm set-argb-pixels 0 0 w h bytes)
(make-object image-snip% bm))
; map-image : (int int color -> broad-color) image -> image
(define (map-image f img)
(unless (procedure-arity-includes? f 3)
(error 'map-image "Expected function with contract num(x) num(y) color -> color as first argument"))
(unless (image? img)
(error 'map-image "Expected image as second argument"))
(map-image-internal (colorize-func f) img))
; The version for use before students have seen structs:
; map3-image :
; (int(x) int(y) int(r) int(g) int(b) -> int(r))
; (int(x) int(y) int(r) int(g) int(b) -> int(g))
; (int(x) int(y) int(r) int(g) int(b) -> int(b))
; image -> image
; Note: by default, preserves alpha values from old image.
(define (map3-image rfunc gfunc bfunc pic)
(unless (procedure-arity-includes? rfunc 5)
(error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument"))
(unless (procedure-arity-includes? gfunc 5)
(error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument"))
(unless (procedure-arity-includes? bfunc 5)
(error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument"))
(unless (image? pic)
(error 'map3-image "Expected image as fourth argument"))
(map-image-internal
(lambda (x y c)
(make-color (rfunc x y (color-red c) (color-green c) (color-blue c))
(gfunc x y (color-red c) (color-green c) (color-blue c))
(bfunc x y (color-red c) (color-green c) (color-blue c))
(color-alpha c)))
pic))
; map4-image :
; (int(x) int(y) int(r) int(g) int(b) int(a) -> int(r))
; (int(x) int(y) int(r) int(g) int(b) int(a) -> int(g))
; (int(x) int(y) int(r) int(g) int(b) int(a) -> int(b))
; (int(x) int(y) int(r) int(g) int(b) int(a) -> int(a))
; image -> image
(define (map4-image rfunc gfunc bfunc afunc pic)
(unless (procedure-arity-includes? rfunc 6)
(error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(r) as first argument"))
(unless (procedure-arity-includes? gfunc 6)
(error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(g) as second argument"))
(unless (procedure-arity-includes? rfunc 6)
(error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(b) as third argument"))
(unless (procedure-arity-includes? gfunc 6)
(error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(alpha) as fourth argument"))
(unless (image? pic)
(error 'map4-image "Expected image as fifth argument"))
(map-image-internal
(lambda (x y c)
(make-color (rfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))
(gfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))
(bfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))
(afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))))
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))))))

BIN
collects/picturing-programs/pictures/bloch.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

BIN
collects/picturing-programs/pictures/calendar.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 339 B

BIN
collects/picturing-programs/pictures/mad_hacker.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.4 KiB

BIN
collects/picturing-programs/pictures/qbook.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 748 B

BIN
collects/picturing-programs/pictures/schemelogo.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.0 KiB

BIN
collects/picturing-programs/pictures/small_hieroglyphics.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.4 KiB

BIN
collects/picturing-programs/pictures/stick-figure.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.9 KiB

188
collects/picturing-programs/racket.css Normal file
View File

@ -0,0 +1,188 @@
/* See the beginning of "scribble.css". */
/* Monospace: */
.RktIn, .RktRdr, .RktPn, .RktMeta,
.RktMod, .RktKw, .RktVar, .RktSym,
.RktRes, .RktOut, .RktCmt, .RktVal {
font-family: monospace;
}
/* Serif: */
.inheritedlbl {
font-family: serif;
}
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 100%;
margin-top: 0.5em;
text-align: left;
background-color: #ECF5F5;
}
.inherited td {
font-size: 82%;
padding-left: 1em;
text-indent: -0.8em;
padding-right: 0.2em;
}
.inheritedlbl {
font-style: italic;
}
/* ---------------------------------------- */
/* Racket text styles */
.RktIn {
color: #cc6633;
background-color: #eeeeee;
}
.RktInBG {
background-color: #eeeeee;
}
.RktRdr {
}
.RktPn {
color: #843c24;
}
.RktMeta {
color: black;
}
.RktMod {
color: black;
}
.RktOpt {
color: black;
}
.RktKw {
color: black;
font-weight: bold;
}
.RktErr {
color: red;
font-style: italic;
}
.RktVar {
color: #262680;
font-style: italic;
}
.RktSym {
color: #262680;
}
.RktValLink {
text-decoration: none;
color: blue;
}
.RktModLink {
text-decoration: none;
color: blue;
}
.RktStxLink {
text-decoration: none;
color: black;
font-weight: bold;
}
.RktRes {
color: #0000af;
}
.RktOut {
color: #960096;
}
.RktCmt {
color: #c2741f;
}
.RktVal {
color: #228b22;
}
/* ---------------------------------------- */
/* Some inline styles */
.together {
width: 100%;
}
.prototype td {
vertical-align: text-top;
}
.longprototype td {
vertical-align: bottom;
}
.RktBlk td {
vertical-align: baseline;
}
.argcontract td {
vertical-align: text-top;
}
.highlighted {
background-color: #ddddff;
}
.defmodule {
width: 100%;
background-color: #F5F5DC;
}
.specgrammar {
float: right;
}
.RBibliography td {
vertical-align: text-top;
}
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}
.Rfilebox {
margin-left: 1em;
margin-right: 1em;
}
.Rfiletitle {
text-align: right;
margin: 0em 0em 0em 0em;
}
.Rfilename {
border-top: 1px solid #6C8585;
border-right: 1px solid #6C8585;
padding-left: 0.5em;
padding-right: 0.5em;
background-color: #ECF5F5;
}
.Rfilecontent {
margin: 0em 0em 0em 0em;
}

166
collects/picturing-programs/scheme.css Normal file
View File

@ -0,0 +1,166 @@
/* See the beginning of "scribble.css". */
/* Monospace: */
.ScmIn, .ScmRdr, .ScmPn, .ScmMeta,
.ScmMod, .ScmKw, .ScmVar, .ScmSym,
.ScmRes, .ScmOut, .ScmCmt, .ScmVal {
font-family: monospace;
}
/* Serif: */
.inheritedlbl {
font-family: serif;
}
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 100%;
margin-top: 0.5em;
text-align: left;
background-color: #ECF5F5;
}
.inherited td {
font-size: 82%;
padding-left: 1em;
text-indent: -0.8em;
padding-right: 0.2em;
}
.inheritedlbl {
font-style: italic;
}
/* ---------------------------------------- */
/* Scheme text styles */
.ScmIn {
color: #cc6633;
background-color: #eeeeee;
}
.ScmInBG {
background-color: #eeeeee;
}
.ScmRdr {
}
.ScmPn {
color: #843c24;
}
.ScmMeta {
color: #262680;
}
.ScmMod {
color: black;
}
.ScmOpt {
color: black;
}
.ScmKw {
color: black;
font-weight: bold;
}
.ScmErr {
color: red;
font-style: italic;
}
.ScmVar {
color: #262680;
font-style: italic;
}
.ScmSym {
color: #262680;
}
.ScmValLink {
text-decoration: none;
color: blue;
}
.ScmModLink {
text-decoration: none;
color: blue;
}
.ScmStxLink {
text-decoration: none;
color: black;
font-weight: bold;
}
.ScmRes {
color: #0000af;
}
.ScmOut {
color: #960096;
}
.ScmCmt {
color: #c2741f;
}
.ScmVal {
color: #228b22;
}
/* ---------------------------------------- */
/* Some inline styles */
.together {
width: 100%;
}
.prototype td {
vertical-align: text-top;
}
.longprototype td {
vertical-align: bottom;
}
.ScmBlk td {
vertical-align: baseline;
}
.argcontract td {
vertical-align: text-top;
}
.highlighted {
background-color: #ddddff;
}
.defmodule {
width: 100%;
background-color: #F5F5DC;
}
.specgrammar {
float: right;
}
.SBibliography td {
vertical-align: text-top;
}
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}

153
collects/picturing-programs/scribble-common.js Normal file
View File

@ -0,0 +1,153 @@
// 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 ? "&#9660;" : "&#9658;";
}
// 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";
});

0
collects/picturing-programs/scribble-style.css Normal file
View File

429
collects/picturing-programs/scribble.css Normal file
View File

@ -0,0 +1,429 @@
/* 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;
}

11
collects/picturing-programs/tests/README Normal file
View File

@ -0,0 +1,11 @@
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

12
collects/picturing-programs/tests/bad-draw.ss Normal file
View File

@ -0,0 +1,12 @@
#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))))))

87
collects/picturing-programs/tests/balls.ss Normal file
View File

@ -0,0 +1,87 @@
#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)

34
collects/picturing-programs/tests/design.txt Normal file
View File

@ -0,0 +1,34 @@
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

15
collects/picturing-programs/tests/full-scene-visible.ss Normal file
View File

@ -0,0 +1,15 @@
#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)

908
collects/picturing-programs/tests/image-equality-performance.ss Normal file
View File

@ -0,0 +1,908 @@
#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)))

2
collects/picturing-programs/tests/install-teachpack.ss Normal file
View File

@ -0,0 +1,2 @@
#lang scheme/base
(require (planet sbloch/picturing-programs:2))

196
collects/picturing-programs/tests/map-image-bsl-tests.rkt Executable file
View File

@ -0,0 +1,196 @@
;; 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/book-pictures)
(require picturing-programs/map-image)
(require 2htdp/image)
;(define (always-red x y) (name->color "red"))
;"(build-image 50 35 (lambda (x y) red)):"
;(build-image 50 35 always-red)
;"should be a 50x35 red rectangle"
;(define (a-gradient x y) (make-color (real->int (* x 2.5))
; (real->int (* y 2.5))
; 0))
;"(build-image 100 100 (lambda (x y) (make-color (* x 2.5) (* y 2.5) 0))):"
;(build-image 100 100 a-gradient)
;"should be a 100x100 square with a color gradient increasing in red from left to right, and in green from top to bottom"
; Test cases for primitives:
(check-expect (real->int 3.2) 3)
(check-expect (real->int 3.7) 4)
(check-expect (real->int 3.5) 4)
(check-expect (real->int 2.5) 2)
(check-expect (real->int #i3.2) 3)
(check-expect (real->int #i3.7) 4)
(check-expect (real->int #i3.5) 4)
(check-expect (real->int #i2.5) 2)
;(check-expect (maybe-color? (make-color 3 4 5)) true)
;(check-expect (maybe-color? (make-color 3 4 5 6)) true)
;(check-expect (maybe-color? false) true)
;(check-expect (maybe-color? true) false)
;(check-expect (maybe-color? (make-posn 3 4)) false)
;(check-expect (maybe-color? "red") false)
(check-expect (name->color "white") (make-color 255 255 255))
(check-expect (name->color "black") (make-color 0 0 0))
(check-expect (name->color "blue") (make-color 0 0 255))
(check-expect (name->color "plaid") false)
(check-expect (color=? (make-color 5 10 15) (make-color 5 10 15)) true)
(check-expect (color=? (make-color 5 10 15) (make-color 5 15 10)) false)
(check-expect (color=? (make-color 255 255 255) "white") true)
(check-expect (color=? (make-color 255 255 255) "blue") false)
(check-expect (color=? "forest green" 'forestgreen) true)
(check-expect (color=? "forest green" 'lightblue) false)
(check-expect (color=? (make-color 5 10 15 20) (make-color 5 10 15)) false)
(check-expect (color=? (make-color 5 10 15 255) (make-color 5 10 15)) true)
(check-expect (color=? (make-color 5 10 15 0) false) true)
(check-expect (color=? (make-color 5 10 15 20) false) false)
; Test cases for map3-image:
; red-id : x y r g b -> num
(define (red-id x y r g b) r)
; green-id : x y r g b -> num
(define (green-id x y r g b) g)
; blue-id : x y r g b -> num
(define (blue-id x y r g b) b)
; zero-5-args : x y r g b -> num
(define (zero-5-args x y r g b) 0)
(define tri (triangle 60 "solid" "orange"))
; (define hieroglyphics pic:hieroglyphics)
; (define scheme-logo pic:scheme-logo)
; (define bloch pic:bloch)
"tri:" tri
"(map3-image red-id green-id blue-id tri) should be tri:"
(map3-image red-id green-id blue-id tri)
"(map3-image zero-5-args green-id blue-id tri) should be a green triangle:"
(map3-image zero-5-args green-id blue-id tri)
"(map3-image zero-5-args green-id blue-id bloch) should be a de-redded Steve Bloch:"
(map3-image zero-5-args green-id blue-id bloch)
; gradient-g : x y r g b -> num
(define (gradient-g x y r g b) (min 255 (* 4 x)))
; gradient-b : x y r g b -> num
(define (gradient-b x y r g b) (min 255 (* 4 y)))
"(map3-image zero-5-args gradient-g gradient-b tri) should be a triangular window on a 2-dimensional color gradient:"
(map3-image zero-5-args gradient-g gradient-b tri)
"The same thing with some red:"
(map3-image red-id gradient-g gradient-b tri)
"And now let's try it on bloch. Should get a rectangular 2-dimensional color gradient:"
(map3-image zero-5-args gradient-g gradient-b bloch)
"The same thing preserving the red:"
(map3-image red-id gradient-g gradient-b bloch)
; color-id : x y color -> color
(define (color-id x y c)
c)
; kill-red : x y color -> color
(define (kill-red x y c)
(make-color 0 (color-green c) (color-blue c)))
(define (kill-red-preserving-alpha x y c)
(make-color 0 (color-green c) (color-blue c) (color-alpha c)))
; make-gradient : x y color -> color
(define (make-gradient x y c)
(make-color 0 (min (* 4 x) 255) (min (* 4 y) 255)))
(define (id x) x)
"tri:" tri
"(map-image color-id tri):"
(define ex1 (map-image color-id tri)) ex1
"(map-image kill-red tri):"
(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):"
(define ex4 (map-image kill-red hieroglyphics)) ex4
"(map-image kill-red scheme-logo):"
(define ex5 (map-image kill-red scheme-logo)) ex5
"(map-image kill-red bloch):"
(define ex6 (map-image kill-red bloch)) ex6
;(define (other-bloch-pixel x y)
; (get-pixel-color x (- (image-height bloch) y) bloch))
;(define flipped-bloch (build-image (image-width bloch) (image-height bloch) other-bloch-pixel))
;flipped-bloch
;
;
;(define RADIUS 3)
;
;(define (clip-to n low high)
; (min (max n low) high))
;(check-expect (clip-to 10 5 15) 10)
;(check-expect (clip-to 10 15 20) 15)
;(check-expect (clip-to 10 -20 7) 7)
;
;(define (near-bloch-pixel x y)
; (get-pixel-color
; (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-width bloch))
; (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-height bloch))
; bloch))
;
;(define fuzzy-bloch
; (build-image (image-width bloch) (image-height bloch) near-bloch-pixel))
;fuzzy-bloch
;
;(define (near-tri-mpixel x y)
; (if (pixel-visible? x y tri)
; (get-pixel-color
; (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-width tri))
; (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-height tri))
; tri)
; false))
;(define fuzzy-tri
; (build-masked-image (image-width tri) (image-height tri) near-tri-mpixel))
;fuzzy-tri
; Convert all white pixels to transparent
(define (white-pixel->trans x y old-color)
(if (color=? old-color "white")
false
old-color))
(define (white->trans pic)
(map-image
white-pixel->trans
pic))
(define (white-pixel->red x y old-color)
(if (color=? old-color 'white)
"red"
old-color))
(define (white->red pic)
(map-image white-pixel->red pic))
"(overlay (white->trans hieroglyphics) (rectangle 100 100 'solid 'blue)):"
(define hier (white->trans hieroglyphics))
(overlay hier (rectangle 100 100 "solid" "blue"))
; pixel->gray : x y color -> color
(check-expect (pixel->gray 3 17 (make-color 0 0 0)) (make-color 0 0 0))
(check-expect (pixel->gray 92 4 (make-color 50 100 150)) (make-color 100 100 100))
(define (pixel->gray x y c)
(make-gray (quotient (+ (color-red c)
(color-green c)
(color-blue c))
3)))
; make-gray : natural -> color
(define (make-gray n)
(make-color n n n))
; color->gray : image -> image
(define (color->gray pic)
(map-image pixel->gray pic))
(color->gray bloch)
(color->gray hieroglyphics)

3128
collects/picturing-programs/tests/map-image-isl-tests.rkt Executable file
View File

File diff suppressed because it is too large Load Diff

21
collects/picturing-programs/tests/perform-robby.ss Normal file
View File

@ -0,0 +1,21 @@
#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")

15
collects/picturing-programs/tests/player Normal file
View File

@ -0,0 +1,15 @@
#! /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))

18
collects/picturing-programs/tests/profile-robby.ss Normal file
View File

@ -0,0 +1,18 @@
#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)

20
collects/picturing-programs/tests/robby-optimization-gone.ss Normal file
View File

@ -0,0 +1,20 @@
#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))

24
collects/picturing-programs/tests/rotating-triangle.ss Normal file
View File

@ -0,0 +1,24 @@
;; 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))

7
collects/picturing-programs/tests/sam.ss Normal file
View File

@ -0,0 +1,7 @@
;; 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"))

74
collects/picturing-programs/tests/shared.ss Normal file
View File

@ -0,0 +1,74 @@
#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)])

21
collects/picturing-programs/tests/stop.ss Normal file
View File

@ -0,0 +1,21 @@
;; 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))))))

99
collects/picturing-programs/tests/stripes.rkt Normal file
View File

@ -0,0 +1,99 @@
;; 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")))

1561
collects/picturing-programs/tests/test-image.ss Normal file
View File

File diff suppressed because it is too large Load Diff

15
collects/picturing-programs/tests/ufo-rename.ss Normal file
View File

@ -0,0 +1,15 @@
#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))

13
collects/picturing-programs/tests/world0-stops.ss Normal file
View File

@ -0,0 +1,13 @@
;; 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))

3
collects/picturing-programs/tests/xrun Normal file
View File

@ -0,0 +1,3 @@
mred balls.ss &
./player carl &
./player sam &

143
collects/picturing-programs/tiles.rkt Normal file
View File

@ -0,0 +1,143 @@
#lang racket/base
; Modified 1/19/2005 to be compatible with new image.ss contracts.
; Modified 2/16/2005 to include stuff from world.ss as well as image.ss
; Modified 2/17/2005 to provide on-update-event (which requires overriding a few
; functions from world.ss)
; Modified 5/20/2005 to rename on-update-event as on-redraw-event, and
; handle pinholes more consistently in image-beside and image-above.
; Modified 1/26/2006 to remove the functions I was replacing in image.ss
; (since image.ss now does things the way I wanted) and
; to remove my tweaked copy of world.ss (since world.ss now does things the
; way I wanted).
; Modified 7/12/2006 to allow image-beside and image-above to take variable numbers of arguments.
; Modified 7/26/2006 to add image-beside-align-top, image-beside-align-bottom, image-above-align-left, and image-above-align-right.
; Modified 12/17/2007 to add crop-top, crop-bottom, crop-left, crop-right. Also utility functions slice-pic and unslice-pic.
; Modified 12/26/2007 to provide all-from image.ss, so we never have to mention image.ss at all.
; Modified 8/15/2008 to add image-above-align-center and image-beside-align-center.
; Modified 10/28/2008 to use provide/contract (and 4.x-style module specs, rather than (lib blah blah))
; Modified again 10/28/2008 to do more user-friendly "check-arg"-style checking instead.
; Modified 1/3/2009 to fix bugs in crop-* and unslice-pic related to zero-sized images.
; Modified 7/9/2009 for compatibility with DrScheme 4.2
; Modified 10/19/2009 for compatibility with DrScheme 4.2.2: image? is now in htdp/image, so it doesn't need to be required from htdp/advanced.
; Modified 1/12/2010: renamed image-above et al to above et al, image-beside et al to beside et al.
; place-image and scene+line are now defined in sb-universe, so they don't need to be here.
; Modified 1/30/2010 for compatibility with 4.2.4: require 2htdp/private/universe-image, which
; has a bunch of functions that accept both htdp-style images and 2htdp-style images.
; Modified 2/10/2010: replaced color-list with alpha-color-list to fix transparency bug.
; Modified 5/24/2010: eliminated all reference to pinholes, scenes, and htdp/image.
; Now using purely 2htdp/image, 2htdp/universe. Downside: no reflection primitives.
; Modified 6/23/2010: had rotate-cw and rotate-ccw reversed. And now we DO have reflection,
; so I'm putting it back in -- at least for vertical and horizontal axes.
; Modified 6/26/2010 to rename .ss to .rkt, lang scheme to lang racket, etc.
; Modified 7/2/2010: I did NOT have rotate-cw and rotate-ccw reversed; there's a bug in
; rotate that causes them to work incorrectly on bitmaps. Reversing them back.
; Modified 12/13/2010: Added flip-main and flip-other (formerly known as
; reflect-main-diag and reflect-other-diag, which had been disabled for
; a while).
(require
2htdp/image
lang/error ; check-arg, check-image, etc.
)
(provide
(all-from-out 2htdp/image)
; above above-align-right above-align-left above-align-center ; included in 2htdp/image
; beside beside-align-top beside-align-bottom beside-align-center ; include in 2htdp/image
reflect-vert reflect-horiz ; synonyms for flip-vertical and flip-horizontal, respectively
reflect-main-diag reflect-other-diag ; temporarily disabled
rotate-cw rotate-ccw rotate-180 ; will simply call rotate
; show-pinhole ; what's a pinhole?
crop-top crop-bottom crop-left crop-right) ; will simply call crop
;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
; reflect-horiz : image => image
(define (reflect-horiz picture)
(check-image 'reflect-horiz picture "first")
(flip-horizontal picture))
; reflect-vert : image => image
(define (reflect-vert picture)
(check-image 'reflect-vert picture "first")
(flip-vertical picture))
; reflect-main-diag : image => image
(define (reflect-main-diag picture)
(check-image 'reflect-main-diag picture "first")
(rotate -45 (flip-vertical (rotate 45 picture))))
; there ought to be a more efficient way than this....
; reflect-other-diag : image => image
(define (reflect-other-diag picture)
(check-image 'reflect-other-diag picture "first")
(rotate 45 (flip-vertical (rotate -45 picture))))
; synonyms
(define (flip-main picture) (reflect-main-diag picture))
(define (flip-other picture) (reflect-other-diag picture))
; natural-number? anything -> boolean
(define (natural-number? x)
(and (integer? x) (>= x 0)))
; crop-left : image natural-number -> image
; deletes that many pixels from left edge of image
(define (crop-left picture pixels)
(check-image 'crop-left picture "first")
(check-arg 'crop-left (natural-number? pixels) "natural number" "second" pixels)
(crop pixels 0
(- (image-width picture) pixels) (image-height picture)
picture))
; crop-top : image number -> image
; deletes that many pixels from top edge of image
(define (crop-top picture pixels)
(check-image 'crop-top picture "first")
(check-arg 'crop-top (natural-number? pixels) "natural number" "second" pixels)
(crop 0 pixels
(image-width picture) (- (image-height picture) pixels)
picture))
; crop-right : image number -> image
; deletes that many pixels from right edge of image
(define (crop-right picture pixels)
(check-image 'crop-right picture "first")
(check-arg 'crop-right (natural-number? pixels) "natural number" "second" pixels)
(crop 0 0
(- (image-width picture) pixels)
(image-height picture)
picture))
; crop-bottom : image number -> image
; deletes that many pixels from bottom edge of image
(define (crop-bottom picture pixels)
(check-image 'crop-bottom picture "first")
(check-arg 'crop-bottom (natural-number? pixels) "natural number" "second" pixels)
(crop 0 0
(image-width picture)
(- (image-height picture) pixels)
picture))
; rotate-cw : image => image
(define (rotate-cw picture)
(check-image 'rotate-cw picture "first")
(rotate -90 picture))
; rotate-ccw : image => image
; Ditto.
(define (rotate-ccw picture)
(check-image 'rotate-ccw picture "first")
(rotate 90 picture))
; rotate-180 : image => image
(define (rotate-180 picture)
(check-image 'rotate-180 picture "first")
(rotate 180 picture))