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

Split picturing-programs and swindle from the main repository.

Browse Source 
They are available at:
  https://github.com/racket/picturing-programs
  https://github.com/racket/swindle
This commit is contained in:
Sam Tobin-Hochstadt 2014-12-01 10:15:33 -05:00
parent 1d1d3f34c4
commit 3d0e2ad5cd
44 changed files with 0 additions and 10204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/main-distribution/info.rkt
View File

@ -37,7 +37,6 @@
"pconvert-lib"
"pict"
"pict-snip"
"picturing-programs"
"plai"
"planet"
"plot"
@ -63,7 +62,6 @@
"snip"
"srfi"
"string-constants"
"swindle"
"syntax-color"
"trace"
"typed-racket"

11
pkgs/picturing-programs/LICENSE.txt
View File

@ -1,11 +0,0 @@
picturing-programs
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

16
pkgs/picturing-programs/info.rkt
View File

@ -1,16 +0,0 @@
#lang info
(define collection 'multi)
(define deps '("base"
"draw-lib"
"gui-lib"
"snip-lib"
"htdp-lib"))
(define build-deps '("racket-doc"
"htdp-doc"
"scribble-lib"))
(define pkg-desc "Teaching libraries for _Picturing Programs_")
(define pkg-authors '(sbloch))

1
pkgs/picturing-programs/picturing-programs/.gitignore vendored
View File

@ -1 +0,0 @@
*.css

15
pkgs/picturing-programs/picturing-programs/HISTORY.txt
View File

@ -1,15 +0,0 @@
Version 2.5: Re-enabled diagonal reflection. Moved into the bundle
(so it doesn't require a PLaneT install). Added some picture variables.
Rewrote a bunch of things for compatibility with 5.1.
Version 2.4: Added change-to-color and map3-image. Cleaned up documentation.
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.
Version 2.2: Fixed bug in rotate-cw and rotate-ccw; restored reflect-vert and reflect-horiz; added with-input-from-url.
Version 2.1: Added argument type-checking. And reflection primitives are now present but produce error message, rather than being missing.
Version 2.0: now fully compatible with 2htdp/image and 2htdp/universe. No pinholes; temporarily disabled reflection primitives.
Version 1.6: fixed same transparency bug for 4.2.4
Version 1.5: fixed same transparency bug for 4.2.3
Version 1.4: fixed transparency bug for 4.2.2
Version 1.3: initial release, for DrScheme 4.2.4
Version 1.2: initial release, for DrScheme 4.2.3
Version 1.1: initial release, for DrScheme 4.2.2

11
pkgs/picturing-programs/picturing-programs/info.rkt
View File

@ -1,11 +0,0 @@
#lang info
(define categories '(media))
(define can-be-loaded-with 'all)
(define required-core-version "5.0.0.1")
(define primary-file "main.rkt")
(define scribblings '(("picturing-programs.scrbl" () (teaching -21))))
(define repositories '("4.x"))
(define compile-omit-paths '("tests"))
(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-note-files '(("Picturing Programs" "HISTORY.txt")))

22
pkgs/picturing-programs/picturing-programs/main.rkt
View File

@ -1,22 +0,0 @@
#lang racket/base
(require 2htdp/universe
(only-in htdp/error check-arg)
picturing-programs/private/tiles
picturing-programs/private/io-stuff
picturing-programs/private/map-image
picturing-programs/private/book-pictures)
(provide (all-from-out picturing-programs/private/tiles) ; includes all-from-out 2htdp/image, plus a few simple add-ons
(all-from-out picturing-programs/private/io-stuff) ; includes with-{input-from,output-to}-{string,file}, with-io-strings
(all-from-out picturing-programs/private/map-image)
; includes (map,build)(3,4,)-image, real->int, name->color, colorize, get-pixel-color
(all-from-out picturing-programs/private/book-pictures) ; pic:calendar, pic:hacker, etc.
(all-from-out 2htdp/universe)
show-it)
(provide provide all-defined-out all-from-out rename-out except-out
prefix-out struct-out)
(define (show-it img)
(check-arg 'show-it (image? img) "image" "first" img)
img)

543
pkgs/picturing-programs/picturing-programs/picturing-programs.scrbl
View File

@ -1,543 +0,0 @@
#lang scribble/doc
@(require
scribble/manual
(for-label racket
picturing-programs/main
;picturing-programs/io-stuff
;picturing-programs/tiles
;picturing-programs/dummy
; picturing-programs/map-image
2htdp/image
teachpack/2htdp/universe
(only-in lang/htdp-beginner check-expect)
))
@; teachpack["picturing-programs"]{Picturing Programs}
@title{@italic{Picturing Programs} Teachpack}
@author{Stephen Bloch}
@defmodule[picturing-programs]
@section{About This Teachpack}
@;Testing, testing: @racket[(list 'testing 1 2 3)].
@;
@;This is a reference to the @racket[list] function (which is a nice link).
@;Now a reference to @racket[triangle] (good link),
@;and @racket[big-bang] (good link),
@;and @racket[show-it] (good link),
@;and @racket[crop-top] (underlined in red, not a link),
@;and @racket[map-image] (underlined in red, not a link),
@;and @racket[dummyvar] (how does this look?),
@;and @racket[with-input-from-url] (underlined in red, not a link),
@;which are defined in several different places.
Provides a variety of functions for combining and manipulating images
and running interactive animations.
It's intended to be used with the textbook
@hyperlink["http://www.picturingprograms.com" "Picturing Programs"].
@section{Installation}
This package should be bundled with DrRacket version 5.1 and later, so there should be
no installation procedure.
@section{Functions from @racketmodname[2htdp/image] and @racketmodname[2htdp/universe]}
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, @italic{don't} also load either of those.
See the above links for how to use those teachpacks.
It also supersedes the older @racket[tiles] and @racket[sb-world] teachpacks,
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{Animation support}
Since the
@hyperlink["http://www.picturingprograms.com" "Picturing Programs"]
textbook introduces animations with image models before other model
types, we provide a draw handler for the simple case in which the
model is exactly what should be displayed in the animation window:
@defproc[(show-it [img image?])
image?]{Returns the given image unaltered. Useful as a draw handler for animations whose model is an image.}
@section{New image functions}
@; @defmodule*/no-declare[(picturing-programs/tiles)]
@declare-exporting[picturing-programs/private/tiles picturing-programs]
@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[(flip-main [img image?])
image?]{Reflects an image across the line x=y, moving the pixel
at coordinates (x,y) to (y,x). The top-right corner becomes the
bottom-left corner, and vice versa. Width and height are swapped.}
@defproc[(flip-other [img image?])
image?]{Reflects an image by moving the pixel at coordinates
(x,y) to (h-y, w-x). The top-left corner becomes the bottom-right
corner, and vice versa. Width and height are swapped.}
@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.}
@defproc[(reflect-main-diag [img image?])
image?]{The same as @racket[flip-main]; retained for
compatibility.}
@defproc[(reflect-other-diag [img image?])
image?]{The same as @racket[flip-other]; retained for
compatibility.}
@section{Variables}
@; @defmodule*/no-declare[(picturing-programs/book-pictures)]
@declare-exporting[picturing-programs/private/book-pictures picturing-programs]
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}
@; @defmodule*/no-declare[(picturing-programs/map-image)]
@declare-exporting[picturing-programs/private/map-image picturing-programs]
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}
Each pixel of a bitmap image has a @racket[color], a built-in structure with
four components -- red, green, blue, and alpha -- each represented by an
integer from 0 to 255. Larger alpha values are "more opaque": an image with
alpha=255 is completely opaque, and one with alpha=0 is completely
transparent.
Even if you're not trying to get transparency effects, alpha is also used
for dithering to smooth out jagged edges. In
@racket[(circle 50 "solid" "red")], the pixels inside the circle are pure
red, with alpha=255; the pixels outside the circle are transparent (alpha=0);
and the pixels on the boundary are red with various alpha values (for example,
if one quarter of a pixel's area is inside
the mathematical boundary of the circle, that pixel's alpha value will be
63).
@defproc[(name->color [name (or/c string? symbol?)])
(or/c color? false/c)]{
Given a color name like "red", 'turquoise, "forest green", @italic{etc.}, returns the corresponding
color struct, showing the red, green, blue, and alpha components. If the name isn't
recognized, returns @racket[false].}
@defproc[(colorize [thing (or/c color? string? symbol? false/c)])
(or/c color? false/c)]{
Similar to @racket[name->color], but accepts colors and @racket[false] as
well: colors produce themselves, while @racket[false] produces a transparent
color.}
@defproc[(color=? [c1 (or/c color? string? symbol? false/c)]
[c2 (or/c color? string? symbol? false/c)])
boolean?]{
Compares two colors for equality. As with @racket[colorize], treats
@racket[false] as a transparent color (i.e. with an alpha-component of 0).
All colors with alpha=0 are considered equal to one another, even if they have
different red, green, or blue components.}
@defproc[(get-pixel-color [x natural-number/c] [y natural-number/c] [pic image?])
color?]{
Gets the color of a specified pixel in the given image. If x and/or y are outside
the bounds of the image, returns a transparent color.}
@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,
@codeblock|{
; fuzz : image -> image
(define (fuzz pic)
(local [; near-pixel : num(x) num(y) -> color
(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[(build-image/extra
[width natural-number/c]
[height natural-number/c]
[f (-> natural-number/c natural-number/c any/c color?)] [extra any/c]) image?]{
Passes the @racket[extra] argument in as a third argument in each call
to @racket[f]. This allows students who haven't learned closures yet to do pixel-by-pixel image
manipulations inside a function depending on a parameter of that function.
For example, the above @racket[fuzz] example could also be written as
@codeblock|{
; near-pixel : number(x) number(y) image -> color
(define (near-pixel x y pic)
(get-pixel-color (+ x -3 (random 7))
(+ y -3 (random 7))
pic))
; fuzz : image -> image
(define (fuzz pic)
(build-image/extra (image-width pic)
(image-height pic)
near-pixel
pic))
}|
}
@defproc[(build4-image [width natural-number/c] [height natural-number/c]
[red-function (-> natural-number/c natural-number/c natural-number/c)]
[green-function (-> natural-number/c natural-number/c natural-number/c)]
[blue-function (-> natural-number/c natural-number/c natural-number/c)]
[alpha-function (-> natural-number/c natural-number/c
natural-number/c)])
image?]{
A version of @racket[build-image] for students who don't know about structs yet.
Each of the four functions takes in the x and y coordinates of a pixel, and
should return an integer from 0 through 255 to determine that color component.}
@defproc[(build3-image [width natural-number/c] [height natural-number/c]
[red-function (-> natural-number/c natural-number/c natural-number/c)]
[green-function (-> natural-number/c natural-number/c natural-number/c)]
[blue-function (-> natural-number/c natural-number/c natural-number/c)])
image?]{
Just like @racket[build4-image], but without specifying the alpha component
(which defaults to 255, fully opaque).}
@defproc*[([(map-image [f (-> color? color?)] [img image?]) image?]
[(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. The color of each pixel in the
result is the result of calling f on the corresponding
pixel in the input. If f accepts 3 parameters, it will be given the x
and y coordinates and the color of the old pixel; if it accepts 1, it
will be given only the color of the old pixel.
An example with a 1-parameter function:
@codeblock|{
; lose-red : color -> color
(define (lose-red 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.
Since @racket[make-color] defaults alpha to 255,
this definition of @racket[lose-red] discards any alpha information (including edge-dithering)
that was in the original image. To preserve this information, one could write
@racketblock[
(define (lose-red-but-not-alpha old-color)
(make-color 0 (color-green old-color) (color-blue old-color) (color-alpha
old-color)))]
An example with a 3-parameter (location-sensitive) function:
@codeblock|{
; apply-gradient : num(x) num(y) color -> color
(define (apply-gradient x y old-color)
(make-color (min (* 3 x) 255)
(color-green old-color)
(color-blue old-color)))
(map-image apply-gradient my-picture)}|
produces a picture the size of @racket[my-picture]'s bounding rectangle,
replacing the red component with a smooth color gradient increasing
from left to right, but with the green and blue components unchanged.}
@defproc*[([(map-image/extra [f (-> color? any/c color?)] [img image?] [extra any/c]) image?]
[(map-image/extra [f (-> natural-number/c natural-number/c color? any/c color?)] [img image?] [extra any/c]) image?])]{
Passes the @racket[extra] argument in as an additional argument in each call
to @racket[f]. This allows students who haven't learned closures yet to do pixel-by-pixel image
manipulations inside a function depending on a parameter of that function.
For example,
@codeblock|{
; clip-color : color number -> color
(check-expect (clip-color (make-color 30 60 90) 100)
(make-color 30 60 90))
(check-expect (clip-color (make-color 30 60 90) 50)
(make-color 30 50 50))
(define (clip-color c limit)
(make-color (min limit (color-red c))
(min limit (color-green c))
(min limit (color-blue c))))
; clip-picture-colors : number(limit) image -> image
(define (clip-picture-colors limit pic)
(map-image/extra clip-color pic limit))
}|
This @racket[clip-picture-colors] function clips each of the
color components at most to the specified limit.
Another example, using x and y coordinates as well:
@codeblock|{
; new-pixel : number(x) number(y) color height -> color
(check-expect (new-pixel 36 100 (make-color 30 60 90) 100)
(make-color 30 60 255))
(check-expect (new-pixel 58 40 (make-color 30 60 90) 100)
(make-color 30 60 102))
(define (new-pixel x y c h)
(make-color (color-red c)
(color-green c)
(real->int (* 255 (/ y h)))))
; apply-blue-gradient : image -> image
(define (apply-blue-gradient pic)
(map-image/extra new-pixel pic (image-height pic)))
}|
This @racket[apply-blue-gradient] function changes the blue component of an image to increase gradually
from the top to the bottom of the image, (almost) reaching 255 at the bottom of the image.
}
@defproc[(map4-image
[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[alpha-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[img image?])
image?]{
A version of map-image for students who don't know about structs yet. Each of the
four given functions is assumed to have the contract
@racketblock[num(x) num(y) num(r) num(g) num(b) num(alpha) -> num]
For each pixel in the original picture, applies the four
functions to the x coordinate, y coordinate, red, green, blue, and alpha
components of the pixel.
The results of the four functions are used as the red, green, blue, and alpha
components in the corresponding pixel of the resulting picture.
For example,
@codeblock|{
; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num
(define (zero x y r g b a) 0)
(define (same-g x y r g b a) g)
(define (same-b x y r g b a) b)
(define (same-alpha x y r g b a) a)
(map4-image zero same-g same-b same-alpha my-picture)}|
produces a copy of @racket[my-picture] with all the red leached out,
leaving only the blue, green, and alpha components.
@codeblock|{
; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num
(define (3x x y r g b a) (min (* 3 x) 255))
(define (3y x y r g b a) (min (* 3 y) 255))
(define (return-255 x y r g b a) 255)
(map4-image 3x zero 3y return-255 my-picture)}|
produces an opaque picture the size of @racket[my-picture]'s bounding rectangle,
with a smooth color gradient with red increasing from left to
right and blue increasing from top to bottom.
}
@defproc[(map3-image
[red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[blue-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)]
[img image?])
image?]{
Like @racket[map4-image], but not specifying the alpha component. Note that
the red, green, and blue functions also @italic{don't take in} alpha values.
Each of the three given functions is assumed to have the contract
@racketblock[num(x) num(y) num(r) num(g) num(b) -> num]
For each pixel in the original picture, applies the three functions to the x
coordinate, y coordinate, red, green, and blue components of the pixel.
The results are used as a the red, green, and blue components in the
corresponding pixel of the resulting picture.
The alpha component in the resulting picture is copied from the source
picture. For example,
@codeblock|{
; each function : num(x) num(y) num(r) num(g) num(b) -> num
(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; parts of
the picture that were transparent are still transparent, and parts that were
dithered are still dithered.
@codeblock|{
; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num
(define (3x x y r g b a) (min (* 3 x) 255))
(define (3y x y r g b a) (min (* 3 y) 255))
(map3-image zero 3x 3y my-picture)}|
produces a @racket[my-picture]-shaped "window" on a color-gradient.
}
@defproc*[([(fold-image [f (-> color? any/c any/c)] [init any/c] [img image?]) any/c]
[(fold-image [f (-> natural-number/c natural-number/c color? any/c any/c)] [init any/c] [img image?]) any/c])]{
Summarizes information from all the pixels of an image.
The result is computed by applying f successively to each pixel, starting with @racket[init].
If @racket[f] accepts four parameters, it is called with the coordinates and color of each
pixel as well as the previously-accumulated result; if it accepts two parameters, it is
given just the color of each pixel and the previously-accumulated result.
You may not assume anything about the order in which the pixels are visited, only
that each pixel will be visited exactly once.
An example with a 2-parameter function:
@codeblock|{
; another-white : color number -> number
(define (another-white c old-total)
(+ old (if (color=? c "white") 1 0)))
; count-white-pixels : image -> number
(define (count-white-pixels pic)
(fold-image another-white 0 pic))}|
Note that the accumulator isn't restricted to be a number: it could be a structure or a list,
enabling you to compute the average color, or a histogram of colors, etc.
}
@defproc*[([(fold-image/extra [f (-> color? any/c any/c any/c)] [init any/c] [img image?] [extra any/c]) any/c]
[(fold-image/extra [f (-> natural-number/c natural-number/c color? any/c any/c any/c)] [init any/c] [img image?] [extra any/c]) any/c])]{
Like @racket[fold-image], but passes the @racket[extra] argument in as an additional argument in each call
to @racket[f]. This allows students who haven't learned closures yet to call @racket[fold-image] on an
operation that depends on a parameter to a containing function.
For example,
@codeblock|{
; another-of-color : color number color -> number
(define (another-of-color c old color-to-count)
(+ old (if (color=? c color-to-count) 1 0)))
; count-pixels-of-color : image color -> number
(define (count-pixels-of-color pic color-to-count)
(fold-image/extra count-pixels-of-color 0 pic))
}|
}
@defproc[(real->int [num real?])
integer?]{
Not specific to colors, but useful if you're building colors by arithmetic.
For example,
@codeblock|{
; bad-gradient : num(x) num(y) -> color
(define (bad-gradient x y)
(make-color (* 2.5 x) (* 1.6 y) 0))
(build-image 50 30 bad-gradient)
; good-gradient : num(x) num(y) -> color
(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.}
@section{Input and Output}
@; @defmodule*/no-declare[(picturing-programs/io-stuff)]
@declare-exporting[picturing-programs/private/io-stuff picturing-programs]
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:
@codeblock|{
; ask : string -> prints output, waits for text input, returns it
(define (ask question)
(begin (display question)
(read)))
; greet : nothing -> prints output, waits for text input, prints output
(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}

16
pkgs/picturing-programs/picturing-programs/private/book-pictures.rkt
View File

@ -1,16 +0,0 @@
#lang racket/base
; Initial version, Dec. 13, 2010.
; Doesn't work with a literal image, but it works to use a "bitmap"
; reference to a file that's included with the teachpacks. Dec. 21, 2010.
(require (only-in 2htdp/image bitmap))
(provide (prefix-out pic: (all-defined-out)))
(define bloch (bitmap "pictures/bloch.png"))
(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"))

30
pkgs/picturing-programs/picturing-programs/private/io-stuff.rkt
View File

@ -1,30 +0,0 @@
#lang racket/base
(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))))

579
pkgs/picturing-programs/picturing-programs/private/map-image.rkt
View File

@ -1,579 +0,0 @@
#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.
; May 10, 2011: added build-image/extra and map-image/extra.
; Dec 1, 2011: allowed map-image and map-image/extra to give their
; function x and y or not, depending on their arity. This way one
; can write a function from color to color, and immediately map it
; onto an image.
; Apr 27, 2012: get-pixel-color has long had a "cache" of one image so it doesn't need
; to keep re-rendering. Experimenting with increasing this cache to two images, so we
; can call get-pixel-color on two images in alternation without thrashing. The cache
; itself seems to work, and having the cache size >= the number of images DOES improve
; performance for a series of get-pixel-color calls rotating among several images (each
; render seems to take about a ms).
; Apr 28, 2012: added fold-image and fold-image/extra.
(require (except-in racket/draw make-color make-pen)
racket/snip
racket/class
2htdp/image
(only-in htdp/error natural?)
(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
colorize
get-pixel-color
;pixel-visible?
; change-to-color
color=?
; show-cache
)
(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))
(provide-higher-order-primitive build-image/extra (_ _ f _))
(provide-higher-order-primitive map-image/extra (f _ _))
(provide-higher-order-primitive fold-image (f _ _))
(provide-higher-order-primitive fold-image/extra (f _ _ _))
(module+ test
(require "book-pictures.rkt" test-engine/racket-tests)
)
; check-procedure-arity : alleged-function nat-num symbol string
; Note: if you invoke these things from a BSL or BSLL program, the syntax checker will
; catch non-procedure arguments before the "(and (procedure? f) ..." test ever sees them,
; but that's no longer true if you invoke them from an ISLL, ASL, or racket program,
; so I'm keeping the test.
(define (check-procedure-arity f n func-name msg)
(unless (and (procedure? f) (procedure-arity-includes? f n))
(error func-name msg)))
(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
(format "Expected a string or symbol, but received ~v" name)))
(let [[result (send the-color-database find-color
(if (string? name)
name
(symbol->string name)))]]
(if result
(color%->color result)
#f)))
(module+ test
(check-expect (name->color "red") (make-color 255 0 0 255))
(check-expect (name->color "plaid") #f)
(check-error (name->color 7 "name->color: Expected a string or symbol, but received 7"))
)
; 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 (format "Expected a color, but received ~v" thing))]))
; 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 (color? rc1)
(error 'color=?
(format "Expected a color or color name as first argument, but received ~v" c1)))
(unless (color? rc2)
(error 'color=?
(format "Expected a color or color name as second argument, but received ~v" c2)))
(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)))))))
(module+ test
(check-expect (color=? "red" (make-color 255 0 0)) #t)
(check-expect (color=? (make-color 0 255 0) 'green) #t)
(check-expect (color=? "red" (make-color 255 0 1)) #f)
(check-expect (color=? (make-color 0 255 0 254) 'green) #f)
(check-expect (color=? (make-color 255 0 0 0) (make-color 0 255 0 0)) #t) ; if both alphas are 0...
(check-error (color=? 87 (make-color 87 87 87)) "colorize: Expected a color, but received 87")
(check-error (color=? "red" #t) "colorize: Expected a color, but received #t")
)
(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 CACHE-SIZE images on which it was called.
; Really terrible performance if you call it in alternation
; on CACHE-SIZE+1 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 CACHE-SIZE 3)
(define-struct ib (image bytes) #:transparent)
; A cache is a list of at most CACHE-SIZE ib's.
; search-cache: image cache -> bytes or #f
(define (search-cache pic cache)
(cond [(null? cache) #f]
[(eqv? pic (ib-image (car cache))) (ib-bytes (car cache))]
[else (search-cache pic (cdr cache))]))
; We'll do a simple LRU cache-replacement.
; add-and-drop : ib cache -> cache
; preserves size
(define (add-and-drop new-ib cache)
(cons new-ib (drop-last cache)))
; drop-last : non-empty list -> list
(define (drop-last L)
(cond [(null? L) (error 'drop-last "list is empty")]
[(null? (cdr L)) '()]
[else (cons (car L) (drop-last (cdr L)))]))
(define cache (build-list CACHE-SIZE (lambda (n) (ib #f #f))))
(define (show-cache) (map ib-image cache)) ; exported temporarily for debugging
(define (get-pixel-color x y pic)
(let* [(w (image-width pic))
(h (image-height pic))
(bytes
(or (search-cache pic cache)
(let* [(bm (make-bitmap w h))
(bmdc (make-object bitmap-dc% bm))
(new-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 new-bytes)
(set! cache (add-and-drop (ib pic new-bytes) cache))
new-bytes)))]
(if (and (<= 0 x (sub1 w))
(<= 0 y (sub1 h)))
(get-px x y w h bytes)
transparent))
)
; 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
(format "Expected a natural number as first argument, but received ~v" w)))
(unless (natural? h)
(error 'build-image
(format "Expected a natural number as second argument, but received ~v" h)))
(check-procedure-arity f 2 'build-image "Expected a function with contract num(x) num(y) -> color as third argument")
(build-image-internal w h (colorize-func f)))
(module+ test
(check-expect (build-image 50 30 (lambda (x y) "red"))
(rectangle 50 30 "solid" "red"))
(check-error (build-image "a" 30 (lambda (x y) "red"))
"build-image: Expected a natural number as first argument, but received \"a\"")
(check-error (build-image 50 #f (lambda (x y) "red"))
"build-image: Expected a natural number as second argument, but received #f")
(check-error (build-image 50 30 70)
"build-image: Expected a function with contract num(x) num(y) -> color as third argument")
(check-error (build-image 50 30 add1)
"build-image: Expected a function with contract num(x) num(y) -> color as third argument")
(check-error (build-image 50 30 +)
"colorize: Expected a color, but received 0")
)
; build-image/extra : natural(width) natural(height) (nat nat any -> broad-color) any -> image
; Like build-image, but passes a fixed extra argument to every call of the function.
; For students who don't yet know function closures.
(define (build-image/extra w h f extra)
(unless (natural? w)
(error 'build-image/extra
(format "Expected a natural number as first argument, but received ~v" w)))
(unless (natural? h)
(error 'build-image/extra
(format "Expected a natural number as second argument, but received ~v" h)))
(check-procedure-arity f 3 'build-image/extra "Expected a function with contract num(x) num(y) any -> color as third argument")
(build-image-internal w h
(colorize-func (lambda (x y) (f x y extra)))))
(module+ test
(check-expect (build-image/extra 50 30 (lambda (x y dummy) "red") "blue")
(rectangle 50 30 "solid" "red"))
(check-error (build-image/extra "a" 30 (lambda (x y dummy) "red") "blue")
"build-image/extra: Expected a natural number as first argument, but received \"a\"")
(check-error (build-image/extra 50 #f (lambda (x y dummy) "red") "blue")
"build-image/extra: Expected a natural number as second argument, but received #f")
(check-error (build-image/extra 50 30 70 "blue")
"build-image/extra: Expected a function with contract num(x) num(y) any -> color as third argument")
(check-error (build-image/extra 50 30 add1 "blue")
"build-image/extra: Expected a function with contract num(x) num(y) any -> color as third argument")
(check-error (build-image/extra 50 30 + 7)
"colorize: Expected a color, but received 7")
)
; check-component : anything symbol string -> anything
; returns first argument unaltered if it's an integer in [0-255]
(define (check-component it plaintiff message)
(if (and (integer? it) (>= it 0) (<= it 255))
it
(error plaintiff message)))
; 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 'build3-image
(format "Expected a natural number as first argument, but received ~v" w)))
(unless (natural? h)
(error 'build3-image
(format "Expected a natural number as second argument, but received ~v" h)))
(check-procedure-arity rfunc 2 'build3-image "Expected a function with contract num(x) num(y) -> [0-255] as third argument")
(check-procedure-arity gfunc 2 'build3-image "Expected a function with contract num(x) num(y) -> [0-255] as fourth argument")
(check-procedure-arity bfunc 2 'build3-image "Expected a function with contract num(x) num(y) -> [0-255] as fifth argument")
(build-image-internal w h
(lambda (x y)
(make-color (check-component (rfunc x y) 'build3-image "Expected third argument to return integer in range 0-255")
(check-component (gfunc x y) 'build3-image "Expected fourth argument to return integer in range 0-255")
(check-component (bfunc x y) 'build3-image "Expected fifth argument to return integer in range 0-255")
)))
)
(module+ test
(check-expect (build3-image 7 7 (lambda (x y) 0) (lambda (x y) 255) (lambda (x y) 0))
(square 7 "solid" "green"))
(check-error (build3-image 100 100 add1 + +)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as third argument")
(check-error (build3-image 100 100 + add1 +)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as fourth argument")
(check-error (build3-image 100 100 + + add1)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as fifth argument")
(check-error (build3-image 100 100 * + +)
"build3-image: Expected third argument to return integer in range 0-255") ; too big
(check-error (build3-image 100 100 + - +)
"build3-image: Expected fourth argument to return integer in range 0-255") ; too small
(check-error (build3-image 100 100 + + (compose sqrt +))
"build3-image: Expected fifth argument to return integer in range 0-255") ; not an integer
)
; 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 'build4-image
(format "Expected a natural number as first argument, but received ~v" w)))
(unless (natural? h)
(error 'build4-image
(format "Expected a natural number as second argument, but received ~v" h)))
(check-procedure-arity rfunc 2 'build4-image "Expected a function with contract num(x) num(y) -> [0-255] as third argument")
(check-procedure-arity gfunc 2 'build4-image "Expected a function with contract num(x) num(y) -> [0-255] as fourth argument")
(check-procedure-arity bfunc 2 'build4-image "Expected a function with contract num(x) num(y) -> [0-255] as fifth argument")
(check-procedure-arity afunc 2 'build4-image "Expected a function with contract num(x) num(y) -> [0-255] as sixth argument")
(build-image-internal w h
(lambda (x y)
(make-color (check-component (rfunc x y) 'build4-image "Expected third argument to return integer in range 0-255")
(check-component (gfunc x y) 'build4-image "Expected fourth argument to return integer in range 0-255")
(check-component (bfunc x y) 'build4-image "Expected fifth argument to return integer in range 0-255")
(check-component (afunc x y) 'build4-image "Expected sixth argument to return integer in range 0-255")
))))
(module+ test
(check-expect (build4-image 5 3
(lambda (x y) 0)
(lambda (x y) 0)
(lambda (x y) 255)
(lambda (x y) 127))
(rectangle 5 3 "solid" (make-color 0 0 255 127)))
(check-error (build4-image 100 100 add1 + + +)
"build4-image: Expected a function with contract num(x) num(y) -> [0-255] as third argument")
(check-error (build4-image 100 100 + add1 + +)
"build4-image: Expected a function with contract num(x) num(y) -> [0-255] as fourth argument")
(check-error (build4-image 100 100 + + add1 +)
"build4-image: Expected a function with contract num(x) num(y) -> [0-255] as fifth argument")
(check-error (build4-image 100 100 + + + add1)
"build4-image: Expected a function with contract num(x) num(y) -> [0-255] as sixth argument")
(check-error (build4-image 100 100 + + + (lambda (x y) "hello world"))
"build4-image: Expected sixth argument to return integer in range 0-255") ; not even a number
)
; 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)))
(define answer (f x y (get-px x y w h bytes)))
(if (color? answer)
(set-px! bytes x y w h answer)
(error 'map-image "Expected a function that returns a color")))
(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 (image? img)
(error 'map-image
(format "Expected an image as second argument, but received ~v" img)))
(cond [(procedure-arity-includes? f 3)
(map-image-internal (colorize-func f) img)]
[(procedure-arity-includes? f 1) ; allow f : color->color as a simple case
(map-image-internal (colorize-func (lambda (x y c) (f c))) img)]
[else (error 'map-image "Expected a function of one or three parameters, returning a color, as first argument")]))
(module+ test
(check-expect (map-image (lambda (c) "blue") (rectangle 5 3 "solid" "green"))
(rectangle 5 3 "solid" "blue"))
(check-expect (map-image (lambda (x y c) (if (< x 5) "blue" "green")) (rectangle 10 3 "solid" "red"))
(beside (rectangle 5 3 "solid" "blue") (rectangle 5 3 "solid" "green")))
(check-error (map-image (lambda (c) "blue") "green")
"map-image: Expected an image as second argument, but received \"green\"")
(check-error (map-image (lambda (c) 0) (rectangle 5 3 "solid" "green"))
"colorize: Expected a color, but received 0")
)
; map-image/extra : (nat nat color X -> broad-color) image X -> image
; Like map-image, but passes a fixed extra argument to every call of the function.
; For students who don't yet know function closures.
(define (map-image/extra f img extra)
(unless (image? img)
(error 'map-image/extra
(format "Expected an image as second argument, but received ~v" img)))
(cond [(procedure-arity-includes? f 4)
(map-image-internal (colorize-func (lambda (x y c) (f x y c extra))) img)]
[(procedure-arity-includes? f 2)
(map-image-internal (colorize-func (lambda (x y c) (f c extra))) img)]
[else (error 'map-image/extra "Expected a function taking two or four parameters, returning a color, as first argument")]))
; 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)
(check-procedure-arity rfunc 5 'map3-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as first argument")
(check-procedure-arity gfunc 5 'map3-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as second argument")
(check-procedure-arity bfunc 5 'map3-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as third argument")
(unless (image? pic)
(error 'map3-image
(format "Expected an image as fourth argument, but received ~v" pic)))
(map-image-internal
(lambda (x y c)
(define r (color-red c))
(define g (color-green c))
(define b (color-blue c))
(make-color (check-component (rfunc x y r g b) 'map3-image "Expected first argument to return integer in range 0-255")
(check-component (gfunc x y r g b) 'map3-image "Expected second argument to return integer in range 0-255")
(check-component (bfunc x y r g b) 'map3-image "Expected third argument to return integer in range 0-255")
(color-alpha c)))
pic))
(module+ test
(check-error (map3-image add1 + + pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as first argument")
(check-error (map3-image + add1 + pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as second argument")
(check-error (map3-image + + add1 pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as third argument")
(check-error (map3-image + + + 17)
"map3-image: Expected an image as fourth argument, but received 17")
(check-error (map3-image - max max (rectangle 5 3 "solid" "blue")) ; too small
"map3-image: Expected first argument to return integer in range 0-255")
(check-error (map3-image max - max (rectangle 5 3 "solid" "blue"))
"map3-image: Expected second argument to return integer in range 0-255")
(check-error (map3-image max max - (rectangle 5 3 "solid" "blue"))
"map3-image: Expected third argument to return integer in range 0-255")
(check-error (map3-image + max max (rectangle 5 3 "solid" "blue"))
"map3-image: Expected first argument to return integer in range 0-255") ; too big
)
; 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)
(check-procedure-arity rfunc 6 'map4-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as first argument")
(check-procedure-arity gfunc 6 'map4-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as second argument")
(check-procedure-arity bfunc 6 'map4-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as third argument")
(check-procedure-arity afunc 6 'map4-image "Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as fourth argument")
(unless (image? pic)
(error 'map4-image
"Expected an image as fifth argument, but received ~v" pic))
(map-image-internal
(lambda (x y c)
(define r (color-red c))
(define g (color-green c))
(define b (color-blue c))
(define a (color-alpha c))
(make-color (check-component (rfunc x y r g b a) 'map4-image "Expected first argument to return integer in range 0-255")
(check-component (gfunc x y r g b a) 'map4-image "Expected second argument to return integer in range 0-255")
(check-component (bfunc x y r g b a) 'map4-image "Expected third argument to return integer in range 0-255")
(check-component (afunc x y r g b a) 'map4-image "Expected fourth argument to return integer in range 0-255")
))
pic))
(module+ test
(check-error (map4-image add1 + + + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as first argument")
(check-error (map4-image + add1 + + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as second argument")
(check-error (map4-image + + add1 + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as third argument")
(check-error (map4-image + + + add1 pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as fourth argument")
(check-error (map4-image + + + + 17)
"map4-image: Expected an image as fifth argument, but received 17")
)
; fold-image : ([x y] c X -> X) X image -> X
; fold-image-internal : ([nat nat] color X -> X) X image -> image
(define (fold-image-internal f init 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)
(define answer init)
(for* ((y (in-range 0 h))
(x (in-range 0 w)))
(set! answer (f x y (get-px x y w h bytes) answer)))
answer)
(define (fold-image f init img)
(unless (image? img)
(error 'fold-image
(format "Expected an image as third argument, but received ~v" img)))
(cond [(procedure-arity-includes? f 4)
(fold-image-internal f init img)]
[(procedure-arity-includes? f 2) ; allow f : color X->X as a simple case
(fold-image-internal (lambda (x y c old-value) (f c old-value)) init img)]
[else (error 'fold-image "Expected a function of two or four parameters as first argument")]))
; fold-image/extra : ([x y] c X Y -> X) X image Y -> X
(define (fold-image/extra f init img extra)
(unless (image? img)
(error 'fold-image/extra
(format "Expected an image as third argument, but received ~v" img)))
(cond [(procedure-arity-includes? f 5)
(fold-image-internal (lambda (x y c old-value) (f x y c old-value extra)) init img)]
[(procedure-arity-includes? f 3)
(fold-image-internal (lambda (x y c old-value) (f c old-value extra)) init img)]
[else (error 'fold-image/extra "Expected a function taking three or five parameters as first argument")]
))
(module+ test
; more checks
;(check-error (map-image (lambda (c) c) pic:bloch)
; "No, this should NOT produce an error.")
(test)
) ; end of test module

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/bloch.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 33 KiB

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/calendar.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 339 B

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/mad_hacker.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.4 KiB

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/qbook.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 941 B

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/schemelogo.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.0 KiB

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/small_hieroglyphics.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 3.9 KiB

BIN
pkgs/picturing-programs/picturing-programs/private/pictures/stick-figure.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 370 B

205
pkgs/picturing-programs/picturing-programs/private/tiles.rkt
View File

@ -1,205 +0,0 @@
#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).
; Modified 8/??/2011: reworded a bunch of error messages in accordance
; with Guillaume & Kathi's research.
; Modified 10/??/2011: fixed error messages in crop functions.
; Modified 10/20/2012: moved error-message tests into this file
(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
flip-main flip-other ; synonyms for the above
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)
(check-image 'flip-main picture "first")
(reflect-main-diag picture))
(define (flip-other picture)
(check-image 'flip-other picture "first")
(reflect-other-diag picture))
; natural-number? anything -> boolean
(define (natural-number? x)
(and (integer? x) (>= x 0)))
; natural-bounded? natural anything -> boolean
(define (natural-bounded? max x)
(and (natural-number? x) (<= x max)))
; 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-bounded? (image-width picture) pixels)
(format "natural number <= ~a" (image-width picture))
"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-bounded? (image-height picture) pixels)
(format "natural number <= ~a" (image-height picture))
"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-bounded? (image-width picture) pixels)
(format "natural number <= ~a" (image-width picture))
"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-bounded? (image-height picture) pixels)
(format "natural number <= ~a" (image-height picture))
"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))
(module+ test
(require "book-pictures.rkt")
(require test-engine/racket-tests)
(check-error (reflect-horiz 17)
"reflect-horiz: expected <image> as first argument, given 17")
; (check-error (reflect-horiz pic:hacker) "shouldn't actually error out")
; (check-expect 3 4)
(check-error (reflect-vert "hello")
"reflect-vert: expected <image> as first argument, given \"hello\"")
(check-error (reflect-main-diag #t)
"reflect-main-diag: expected <image> as first argument, given #t")
(check-error (reflect-other-diag #f)
"reflect-other-diag: expected <image> as first argument, given #f")
(check-error (flip-main 'blue)
"flip-main: expected <image> as first argument, given 'blue")
(check-error (flip-other "snark")
"flip-other: expected <image> as first argument, given \"snark\"")
(check-error (crop-left pic:hacker 50)
"crop-left: expected <natural number <= 48> as second argument, given 50")
(check-error (crop-right pic:bloch 100)
"crop-right: expected <natural number <= 93> as second argument, given 100")
(check-error (crop-top pic:book 56)
"crop-top: expected <natural number <= 39> as second argument, given 56")
(check-error (crop-bottom pic:hacker 56)
"crop-bottom: expected <natural number <= 48> as second argument, given 56")
(check-error (crop-left pic:hacker -3)
"crop-left: expected <natural number <= 48> as second argument, given -3")
(check-error (crop-top pic:book 3.2)
"crop-top: expected <natural number <= 39> as second argument, given 3.2")
(check-error (crop-bottom pic:book pic:book)
"crop-bottom: expected <natural number <= 39> as second argument, given (object:image% ...)") ; was "<image>" in *SL, but "(object:image% ...)" in racket/base
(check-error (rotate-cw 17)
"rotate-cw: expected <image> as first argument, given 17")
(check-error (rotate-ccw #t)
"rotate-ccw: expected <image> as first argument, given #t")
(check-error (rotate-180 "goodbye")
"rotate-180: expected <image> as first argument, given \"goodbye\"")
(test) ; need this if not using *SL testing
)

188
pkgs/picturing-programs/picturing-programs/racket.css
View File

@ -1,188 +0,0 @@
/* 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
pkgs/picturing-programs/picturing-programs/scheme.css
View File

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

513
pkgs/picturing-programs/picturing-programs/tests/map-image-bsl-tests.rkt
View File

@ -1,513 +0,0 @@
;; The first three lines of this file were inserted by DrRacket. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require picturing-programs)
; 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-error (name->color 7) "name->color: Expected a string or symbol, but received 7")
(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)
(check-error (color=? "white" 3) "colorize: Expected a color, but received 3")
(check-error (color=? "plaid" "white") "color=?: Expected a color or color name as first argument, but received \"plaid\"")
(check-error (color=? "white" "plaid") "color=?: Expected a color or color name as second argument, but received \"plaid\"")
; Test cases for map3-image:
;(check-error (map3-image 5 + + pic:bloch)
; "map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as first argument")
; Actually, the above is caught by Check Syntax, before map3-image has a chance to check anything.
(check-error (map3-image sqrt + + pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as first argument")
;(check-error (map3-image + 5 + pic:bloch)
; "map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as second argument")
(check-error (map3-image + sqrt + pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as second argument")
;(check-error (map3-image + + 5 pic:bloch)
; "map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as third argument")
(check-error (map3-image + + sqrt pic:bloch)
"map3-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as third argument")
(check-error (map3-image + + + 5)
"map3-image: Expected an image as fourth argument, but received 5")
; 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)
"Test cases for map3-image:"
"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)
; x-gradient-5 : x y r g b -> num
(define (x-gradient-5 x y r g b) (min 255 (* 4 x)))
; y-gradient-5 : x y r g b -> num
(define (y-gradient-5 x y r g b) (min 255 (* 4 y)))
"(map3-image zero-5-args x-gradient-5 y-gradient-5 tri) should be a triangular window on a 2-dimensional color gradient:"
(map3-image zero-5-args x-gradient-5 y-gradient-5 tri)
"The same thing with some red:"
(map3-image red-id x-gradient-5 y-gradient-5 tri)
"And now let's try it on bloch. Should get a rectangular 2-dimensional color gradient, no bloch:"
(map3-image zero-5-args x-gradient-5 y-gradient-5 bloch)
"The same thing preserving the red:"
(map3-image red-id x-gradient-5 y-gradient-5 bloch)
"Rotating colors r->g->b->r:"
(map3-image blue-id red-id green-id bloch)
"Test cases for map4-image:"
;(check-error (map4-image 5 + + + pic:bloch)
; "map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) -> [0-255] as first argument")
(check-error (map4-image sqrt + + + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as first argument")
;(check-error (map4-image + 5 + + pic:bloch)
; "map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as second argument")
(check-error (map4-image + sqrt + + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as second argument")
;(check-error (map4-image + + 5 + pic:bloch)
; "map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as third argument")
(check-error (map4-image + + sqrt + pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as third argument")
;(check-error (map4-image + + + 5 pic:bloch)
; "map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as fourth argument")
(check-error (map4-image + + + sqrt pic:bloch)
"map4-image: Expected a function with contract num(x) num(y) num(r) num(g) num(b) num(a) -> [0-255] as fourth argument")
(check-error (map4-image + + + + 5)
"map4-image: Expected an image as fifth argument, but received 5")
; red-id6 : x y r g b a -> num
(define (red-id6 x y r g b a) r)
; green-id6 : x y r g b a -> num
(define (green-id6 x y r g b a) g)
; blue-id6 : x y r g b a -> num
(define (blue-id6 x y r g b a) b)
; alpha-id6 : x y r g b a -> num
(define (alpha-id6 x y r g b a) a)
; zero-6-args : x y r g b a -> num
(define (zero-6-args x y r g b a) 0)
;
"(map4-image red-id6 green-id6 blue-id6 alpha-id6 tri) should be tri:"
(map4-image red-id6 green-id6 blue-id6 alpha-id6 tri)
"(map4-image zero-6-args green-id6 blue-id6 alpha-id6 tri) should be a green triangle:"
(map4-image zero-6-args green-id6 blue-id6 alpha-id6 tri)
"(map4-image zero-6-args green-id6 blue-id6 alpha-id6 bloch) should be a de-redded Steve Bloch:"
(map4-image zero-6-args green-id6 blue-id6 alpha-id6 bloch)
(define bluebox (rectangle 100 100 "solid" "light blue"))
; x-gradient-6 : x y r g b a -> num
(define (x-gradient-6 x y r g b a) (min 255 (* 4 x)))
; y-gradient-6 : x y r g b a -> num
(define (y-gradient-6 x y r g b a) (min 255 (* 4 y)))
"(map4-image zero-6-args x-gradient-6 y-gradient-6 alpha-id6 tri) should be a triangular window on a 2-dimensional color gradient, light blue background:"
(overlay (map4-image zero-6-args x-gradient-6 y-gradient-6 alpha-id6 tri) bluebox)
"(map4-image red-id green-id blue-id x-gradient-6 tri) should be a triangle with a 1-dimensional alpha gradient:"
(overlay (map4-image red-id6 green-id6 blue-id6 x-gradient-6 tri) bluebox)
"Same thing on bloch:"
(overlay (map4-image red-id6 green-id6 blue-id6 x-gradient-6 bloch) bluebox)
; Test cases for map-image:
;(check-error (map-image 5 pic:bloch)
; "map-image: Expected a function with contract num(x) num(y) color -> color as first argument")
(check-error (map-image make-posn pic:bloch)
"map-image: Expected a function of one or three parameters, returning a color, as first argument")
(check-error (map-image + 5)
"map-image: Expected an image as second argument, but received 5")
; 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)))
(define (kill-red-without-xy 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)))
"tri:" tri
"(map-image color-id tri):"
(define ex1 (map-image color-id tri)) ex1
"(map-image kill-red tri): should be green, on an opaque background with no red"
(define ex2 (map-image kill-red tri)) ex2
"(map-image kill-red-preserving-alpha tri):"
(define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime
"(map-image kill-red-ignoring-xy tri):"
(define ex2again (map-image kill-red-without-xy tri)) ex2again
"(map-image make-gradient tri):"
(define ex3 (map-image make-gradient tri)) ex3
"(map-image kill-red hieroglyphics): should be on an opaque background with no red"
(define ex4 (map-image kill-red hieroglyphics)) ex4
"(map-image kill-red scheme-logo):"
(define ex5 (map-image kill-red scheme-logo)) ex5
"(map-image kill-red bloch):"
(define ex6 (map-image kill-red bloch)) ex6
"(map-image kill-red-without-xy bloch) (should look the same):"
(define ex7 (map-image kill-red-without-xy bloch)) ex7
(define (return-5 x y c) 5)
(check-error (map-image return-5 bloch) "colorize: Expected a color, but received 5")
"Test cases for build3-image:"
(define (x-gradient-2 x y) (min 255 (* 4 x)))
(define (y-gradient-2 x y) (min 255 (* 4 y)))
(define (zero-2-args x y) 0)
"(build3-image 60 40 zero-2-args x-gradient-2 y-gradient-2) should be a 60x40 rectangle with no red, green increasing from left to right, and blue increasing from top to bottom:"
(build3-image 60 40 zero-2-args x-gradient-2 y-gradient-2)
(check-error (build3-image "hello" true sqrt sqrt sqrt)
"build3-image: Expected a natural number as first argument, but received \"hello\"")
(check-error (build3-image 17 true sqrt sqrt sqrt)
"build3-image: Expected a natural number as second argument, but received true")
(check-error (build3-image 17 24 sqrt sqrt sqrt)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as third argument")
(check-error (build3-image 17 24 x-gradient-2 sqrt sqrt)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as fourth argument")
(check-error (build3-image 17 24 x-gradient-2 y-gradient-2 sqrt)
"build3-image: Expected a function with contract num(x) num(y) -> [0-255] as fifth argument")
(define (return-minus-5 x y) -5)
(check-error (build3-image 17 24 x-gradient-2 y-gradient-2 return-minus-5)
"build3-image: Expected fifth argument to return integer in range 0-255")
"Test cases for build4-image:"
"(build4-image 50 50 x-gradient-2 x-gradient-2 zero-2-args y-gradient-2) should be a square, increasingly yellow from left to right and increasingly alpha from top to bottom. On a blue background."
(overlay (build4-image 50 50 x-gradient-2 x-gradient-2 zero-2-args y-gradient-2) bluebox)
"Test cases for build-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"
(check-error (build-image 3.2 100 a-gradient) "build-image: Expected a natural number as first argument, but received 3.2")
(check-error (build-image 100 -2 a-gradient) "build-image: Expected a natural number as second argument, but received -2")
(check-error (build-image 100 100 sqrt) "build-image: Expected a function with contract num(x) num(y) -> color as third argument")
(define (other-bloch-pixel x y)
(get-pixel-color x (- (image-height bloch) y 1) bloch))
"(build-image (image-width bloch) (image-height bloch) other-bloch-pixel): should be flipped vertically"
(build-image (image-width bloch) (image-height bloch) other-bloch-pixel)
(define (other-pixel x y pic)
(get-pixel-color x (- (image-height pic) y 1) pic))
(define (my-flip pic)
(build-image/extra (image-width pic) (image-height pic) other-pixel pic))
"(my-flip pic:hieroglyphics):"
(my-flip pic:hieroglyphics)
(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 (sub1 (image-width bloch)))
(clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (sub1 (image-height bloch)))
bloch))
"fuzzy bloch, radius=3, not adjusting size of image:"
(define fuzzy-bloch
(build-image (image-width bloch) (image-height bloch) near-bloch-pixel))
fuzzy-bloch
(define (near-tri-mpixel x y)
(get-pixel-color
(clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS)))
0 (+ RADIUS RADIUS -1 (image-width tri)))
(clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS)))
0 (+ RADIUS RADIUS -1 (image-height tri)))
tri)
)
(define fuzzy-tri
(build-image (+ RADIUS RADIUS (image-width tri))
(+ RADIUS RADIUS (image-height tri))
near-tri-mpixel))
"fuzzy triangle, radius=3, adjusting size of image to allow fuzz on all sides:"
fuzzy-tri
; Convert all white pixels to transparent
(define (white-pixel->trans old-color)
(if (> (+ (color-red old-color) (color-green old-color) (color-blue old-color))
750)
false
old-color))
(define (white->trans pic)
(map-image
white-pixel->trans
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 (make-color 0 0 0)) (make-color 0 0 0))
(check-expect (pixel->gray (make-color 50 100 150)) (make-color 100 100 100))
(define (pixel->gray c)
(make-gray (quotient (+ (color-red c)
(color-green c)
(color-blue c))
3)
(color-alpha c)))
; make-gray : natural(value) natural(alpha) -> color
(define (make-gray value alpha)
(make-color value value value alpha))
; color->gray : image -> image
(define (color->gray pic)
(map-image pixel->gray pic))
"(color->gray bloch):"
(color->gray bloch)
"(overlay (color->gray hieroglyphics) bluebox):"
(overlay (color->gray hieroglyphics) bluebox)
"(overlay (color->gray (white->trans hieroglyphics)) bluebox):"
(overlay (color->gray (white->trans hieroglyphics)) bluebox)
; invert-pixel : x y color -> color
(check-expect (invert-pixel (make-color 0 0 0)) (make-color 255 255 255))
(check-expect (invert-pixel (make-color 50 100 150)) (make-color 205 155 105))
(define (invert-pixel color)
(make-color (- 255 (color-red color))
(- 255 (color-green color))
(- 255 (color-blue color))))
; invert-pic : image -> image
(define (invert-pic pic)
(map-image invert-pixel pic))
(check-expect (invert-pic (rectangle 30 20 "solid" "red"))
(rectangle 30 20 "solid" (make-color 0 255 255)))
(invert-pic pic:bloch) "should be Dr. Bloch in photonegative"
; Test cases for map-image/extra and build-image/extra:
; Exercise 27.4.1:
; apply-threshold : number threshold -> number
(check-expect (apply-threshold 100 200) 0)
(check-expect (apply-threshold 100 100) 255)
(check-expect (apply-threshold 100 75) 255)
(define (apply-threshold component threshold)
(if (< component threshold)
0
255))
; simple-new-pixel : color number(threshold) -> color
; Converts color components below threshold to 0, and those >= threshold to 255.
(check-expect (simple-new-pixel (make-color 50 100 200) 150)
(make-color 0 0 255))
(check-expect (simple-new-pixel (make-color 50 100 200) 90)
(make-color 0 255 255))
(define (simple-new-pixel c threshold)
(make-color (apply-threshold (color-red c) threshold)
(apply-threshold (color-green c) threshold)
(apply-threshold (color-blue c) threshold)))
"map-image/extra simple-new-pixel..."
(map-image/extra simple-new-pixel pic:bloch 200)
(map-image/extra simple-new-pixel pic:bloch 150)
(map-image/extra simple-new-pixel pic:bloch 100)
; new-pixel : number(x) number(y) color height -> color
(check-expect (new-pixel 36 100 (make-color 30 60 90) 100)
(make-color 30 60 255))
(check-expect (new-pixel 58 40 (make-color 30 60 90) 100)
(make-color 30 60 102))
(define (new-pixel x y c h)
; x number
; y number
; c color
; h number
(make-color (color-red c)
(color-green c)
(real->int (* 255 (/ y h)))))
; apply-blue-gradient : image -> image
(define (apply-blue-gradient pic)
(map-image/extra new-pixel pic (image-height pic)))
(apply-blue-gradient pic:bloch)
"should be Dr. Bloch with an amount of blue increasing steadily from top to bottom"
(apply-blue-gradient (rectangle 40 60 "solid" "red"))
"should be a rectangle shading from red at the top to purple at the bottom"
; flip-pixel : num(x) num(y) image -> color
(define (flip-pixel x y pic)
(if (>= x y)
(get-pixel-color x y pic)
(get-pixel-color y x pic)))
(define (diag-mirror pic)
(build-image/extra (image-width pic) (image-width pic) flip-pixel pic))
(diag-mirror pic:bloch)
"should be the upper-right corner of Dr. Bloch's head, mirrored to the lower-left"
; myflip : image -> image
; vertical reflection defined by bitmap operations
(define (myflip pic)
(build-image/extra (image-width pic) (image-height pic)
myflip-helper pic))
; myflip-helper : number(x) number(y) image -> color
(check-expect (myflip-helper 10 2 tri) (name->color "orange"))
(check-expect (myflip-helper 10 49 tri) (make-color 255 255 255 0)) ; Why it's a transparent white
; rather than a transparent black, I don't know....
(check-expect (myflip-helper 30 2 tri) (name->color "orange"))
(check-expect (myflip-helper 30 49 tri) (name->color "orange"))
(define (myflip-helper x y pic)
(get-pixel-color x (- (image-height pic) y 1) pic))
(check-expect (myflip pic:bloch) (flip-vertical pic:bloch))
; add-red : image number -> image
(define (add-red pic how-much)
(map-image/extra add-red-helper pic how-much))
; add-red-helper : num(x) num(y) color number -> color
(check-expect (add-red-helper 58 19 (make-color 29 59 89) 40)
(make-color 69 59 89))
(check-expect (add-red-helper 214 3 (make-color 250 200 150 100) 30)
(make-color 255 200 150 100))
(define (add-red-helper x y c how-much)
(make-color (min 255 (+ how-much (color-red c)))
(color-green c)
(color-blue c)
(color-alpha c)))
(define red-bloch (add-red pic:bloch 50))
(check-expect (get-pixel-color 30 20 red-bloch)
(make-color 133 56 35))
(check-expect (get-pixel-color 30 50 red-bloch)
(make-color 255 173 149))
; clip-color : color number -> color
(check-expect (clip-color (make-color 30 60 90) 100)
(make-color 30 60 90))
(check-expect (clip-color (make-color 30 60 90) 50)
(make-color 30 50 50))
(define (clip-color c limit)
(make-color (min limit (color-red c))
(min limit (color-green c))
(min limit (color-blue c))))
; clip-picture-colors : number(limit) image -> image
(define (clip-picture-colors limit pic)
(map-image/extra clip-color pic limit))
pic:bloch
"clip-picture-colors..."
(clip-picture-colors 240 pic:bloch)
(clip-picture-colors 200 pic:bloch)
(clip-picture-colors 150 pic:bloch)
(clip-picture-colors 100 pic:bloch)
; another-white : color number -> number
(define (another-white c old)
(+ old (if (color=? c "white") 1 0)))
; count-white-pixels : image -> number
(define (count-white-pixels pic)
(fold-image another-white 0 pic))
(check-expect (count-white-pixels (rectangle 15 10 "solid" "blue")) 0)
(check-expect (count-white-pixels (rectangle 15 10 "solid" "white")) 150)
; another-color : color number color -> number
(define (another-color c old color-to-count)
(+ old (if (color=? c color-to-count) 1 0)))
; count-colored-pixels : image color -> number
(define (count-colored-pixels pic color-to-count)
(fold-image/extra another-color 0 pic color-to-count))
(check-expect (count-colored-pixels (rectangle 15 10 "solid" "blue") "blue") 150)
(check-expect (count-colored-pixels (overlay (rectangle 5 10 "solid" "blue") (ellipse 15 30 "solid" "green"))
"blue")
50)
(check-expect (count-colored-pixels (overlay (rectangle 5 10 "solid" "blue") (ellipse 20 30 "solid" "green"))
"blue")
40) ; because the overlaid rectangle is offset by half a pixel, so the top and bottom rows aren't "blue"
(define-struct rgba (red green blue alpha))
; like "color" but without bounds-checking
; accumulate-color : color rgba -> rgba
(define (accumulate-color c old)
(make-rgba (+ (color-red c) (rgba-red old))
(+ (color-green c) (rgba-green old))
(+ (color-blue c) (rgba-blue old))
(+ (color-alpha c) (rgba-alpha old))))
; scale-rgba : number rgba -> rgba
(define (scale-rgba factor old)
(make-rgba (* factor (rgba-red old))
(* factor (rgba-green old))
(* factor (rgba-blue old))
(* factor (rgba-alpha old))))
; average-color : image -> rgba
(define (average-color pic)
(scale-rgba (/ 1 (* (image-width pic) (image-height pic)))
(fold-image accumulate-color (make-rgba 0 0 0 0) pic)))
(check-expect (average-color (rectangle 5 10 "solid" "blue"))
(make-rgba 0 0 255 255))
(check-expect (average-color (overlay (rectangle 5 10 "solid" "blue")
(rectangle 25 10 "solid" "black")))
(make-rgba 0 0 51 255))

89
pkgs/picturing-programs/picturing-programs/tests/map-image-isl-tests.rkt
View File

@ -1,89 +0,0 @@
;; The first three lines of this file were inserted by DrRacket. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname map-image-isl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require picturing-programs)
(define tri (triangle 60 "solid" "orange"))
(define hieroglyphics pic:hieroglyphics)
(define scheme-logo pic:scheme-logo)
(define bloch pic:bloch)
"(build-image 50 35 (lambda (x y) red)):"
(build-image 50 35 (lambda (x y) "red"))
"should be a 50x35 red rectangle"
; myflip : image -> image
; vertical reflection defined by bitmap operations
(define (myflip pic)
(local [(define (other-pixel x y) (get-pixel-color x (- (image-height pic) y 1) pic))]
(build-image (image-width pic) (image-height pic)
other-pixel)))
(check-expect (myflip pic:bloch) (flip-vertical pic:bloch))
(define RADIUS 1)
(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)
; replace-alpha : color number -> color
(define (replace-alpha old-color alpha)
(make-color (color-red old-color)
(color-green old-color)
(color-blue old-color)
alpha))
(define (myfuzz pic)
(local [(define (near-pixel x y)
(get-pixel-color
(clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (sub1 (image-width pic)))
(clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (sub1 (image-height pic)))
pic)
)]
(build-image (image-width pic) (image-height pic)
near-pixel)))
(myfuzz bloch)
(myfuzz tri)
(define (masked-fuzz pic)
; Like myfuzz, but preserves the old mask
(local [(define (near-pixel x y)
(replace-alpha
(get-pixel-color
(clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-width pic))
(clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-height pic))
pic)
(color-alpha (get-pixel-color x y pic))
))]
(build-image (image-width pic) (image-height pic)
near-pixel)))
(masked-fuzz bloch)
(masked-fuzz tri)
; Convert all white pixels to transparent
(define (white->trans pic)
(local [(define white (name->color "white"))
(define (new-color #; x #; y old-color) ; leave out x & y (dec2011)
(if (equal? old-color white)
false
old-color))]
(map-image new-color pic)))
(define hier (white->trans hieroglyphics))
(overlay hier (rectangle 100 100 "solid" "blue"))
(define (diamond-color x y)
(make-color (* 5 (max (abs (- x 50)) (abs (- y 50))))
0
(* 2 y)))
(build-image 100 100 diamond-color)
(define (animation-test dummy)
(big-bang bloch (on-draw show-it) (on-tick myfuzz 1)))
"Run (animation-test 'blah) to test myfuzz as tick handler."

44
pkgs/picturing-programs/picturing-programs/tests/rotating-triangle.rkt
View File

@ -1,44 +0,0 @@
;; The first three lines of this file were inserted by DrRacket. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname rotating-triangle) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require picturing-programs)
(define R 60)
(define SIDE (* R (sqrt 3)))
(define TRI (triangle SIDE "solid" "blue"))
(define CIRC (circle R "solid" "white"))
(define tricirc (overlay/xy TRI
(- (/ SIDE 2) R) 0
CIRC))
(define (rotate-1 pic)
(rotate 1 pic))
;Triangle rotating by itself (with its top and left attached to the top and left of the window):
(define (test1 dummy)
(big-bang TRI
(on-tick rotate-1 .05)
(check-with image?)
(on-draw show-it)))
;Triangle rotating around its center:
(define (test2 dummy)
(big-bang tricirc
(on-tick rotate-1 .05)
(check-with image?)
(on-draw show-it)))
;show-on-yellow : image -> image
(define (show-on-yellow pic)
(overlay pic (rectangle (* 2 R) (* 2 R) "solid" "yellow")))
;Triangle rotating around its center, on a yellow background:
(define (test3 dummy)
(big-bang tricirc
(on-tick rotate-1 .05)
(check-with image?)
(on-draw show-on-yellow)))
"Triangle rotating by itself (with its top and left attached to the top
and left of the window): (test1 'blah)"
"Triangle rotating around its center: (test2 'blah)"
"Triangle rotating around its center, on a yellow background: (test3 'blah)"

7
pkgs/picturing-programs/picturing-programs/tests/test-docs-complete.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require rackunit/docs-complete)
;(check-docs (quote picturing-programs/private/tiles))
;(check-docs (quote picturing-programs/private/map-image))
(check-docs (quote picturing-programs))
;(check-docs (quote picturing-programs/private/io-stuff))
;(check-docs (quote picturing-programs/private/book-pictures))

3
pkgs/picturing-programs/teachpack/picturing-programs.rkt
View File

@ -1,3 +0,0 @@
#lang racket/base
(require picturing-programs)
(provide (all-from-out picturing-programs))

11
pkgs/swindle/LICENSE.txt
View File

@ -1,11 +0,0 @@
swindle
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

594
pkgs/swindle/base.rkt
View File

@ -1,594 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> The `base' module defines some basic low-level syntactic extensions to
;;> Racket. It can be used by itself to get these extensions.
#lang mzscheme
(provide (all-from-except mzscheme
#%module-begin #%top #%app define let let* letrec lambda
keyword? keyword->string string->keyword))
;;>> (#%module-begin ...)
;;> `base' is a language module -- it redefines `#%module-begin' to load
;;> itself for syntax definitions.
(provide (rename module-begin~ #%module-begin))
(define-syntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object
stx (list (quote-syntax require-for-syntax) 'swindle/base))
(cdr e))
stx)
(raise-syntax-error #f "bad syntax" stx)))
;; This doesn't work anymore (from 203.4)
;; (syntax-rules ()
;; [(_ . body) (#%plain-module-begin
;; (require-for-syntax swindle/base) . body)])
)
;;>> (#%top . id)
;;> This special syntax is redefined to make keywords (symbols whose names
;;> begin with a ":") evaluate to themselves.
(provide (rename top~ #%top))
(define-syntax (top~ stx)
(syntax-case stx ()
[(_ . x)
(let ([s (syntax-e #'x)])
(if (and (symbol? s)
(not (eq? s '||))
(eq? #\: (string-ref (symbol->string s) 0)))
(syntax/loc stx (#%datum . x))
(syntax/loc stx (#%top . x))))]))
;;>> (#%app ...)
;;> Redefined so it is possible to apply using dot notation: `(foo x . y)'
;;> is the same as `(apply foo x y)'. This is possible only when the last
;;> (dotted) element is an identifier.
(provide (rename app~ #%app))
(define-syntax (app~ stx)
(syntax-case stx ()
[(_ x ...) (syntax/loc stx (#%app x ...))]
[(_ . x)
(let loop ([s (syntax-e #'x)] [r '()])
(cond [(list? s) (syntax/loc stx (#%app . x))]
[(pair? s) (loop (cdr s) (cons (car s) r))]
[else (let ([e (and (syntax? s) (syntax-e s))])
(if (or (null? e) (pair? e))
(loop e r)
(quasisyntax/loc stx
(#%app apply . #,(reverse (cons s r))))))]))]))
;; these are defined as normal bindings so code that uses this module can use
;; them, but for the syntax level of this module we need them too.
(define-for-syntax (keyword*? x)
(and (symbol? x) (not (eq? x '||))
(eq? (string-ref (symbol->string x) 0) #\:)))
(define-for-syntax (syntax-keyword? x)
(keyword*? (if (syntax? x) (syntax-e x) x)))
;;>> (define id-or-list ...)
;;> The standard `define' form is modified so defining :keywords is
;;> forbidden, and if a list is used instead of an identifier name for a
;;> function then a curried function is defined.
;;> => (define (((plus x) y) z) (+ x y z))
;;> => plus
;;> #<procedure:plus>
;;> => (plus 5)
;;> #<procedure:plus:1>
;;> => ((plus 5) 6)
;;> #<procedure:plus:2>
;;> => (((plus 5) 6) 7)
;;> 18
;;> Note the names of intermediate functions.
;;>
;;> In addition, the following form can be used to define multiple values:
;;> => (define (values a b) (values 1 2))
(provide (rename define~ define))
(define-syntax (define~ stx)
;; simple version
;; (syntax-case stx ()
;; [(_ (name arg ...) body ...)
;; #`(define~ name (lambda~ (arg ...) body ...))]
;; [(_ name body ...) #'(define name body ...)])
;; this version makes created closures have meaningful names
;; also -- forbid using :keyword identifiers
;; also -- make (define (values ...) ...) a shortcut for define-values (this
;; is just a patch, a full solution should override `define-values', and
;; also deal with `let...' and `let...-values' and lambda binders)
;; also -- if the syntax is top-level, then translate all defines into a
;; define with (void) followed by a set! -- this is for the problem of
;; defining something that is provided by some module, and re-binding a
;; syntax
(define top-level? (eq? 'top-level (syntax-local-context)))
(syntax-case* stx (values)
;; compare symbols if at the top-level
(if top-level?
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
module-identifier=?)
[(_ name expr) (identifier? #'name)
(cond [(syntax-keyword? #'name)
(raise-syntax-error #f "cannot redefine a keyword" stx #'name)]
[top-level?
(syntax/loc stx
(begin (define-values (name) (void)) (set! name expr)))]
[else
(syntax/loc stx (define-values (name) expr))])]
[(_ (values name ...) expr)
(cond [(ormap (lambda (id) (and (syntax-keyword? id) id))
(syntax->list #'(name ...)))
=> (lambda (id)
(raise-syntax-error #f "cannot redefine a keyword" stx id))]
[top-level?
(syntax/loc stx
(begin (define name (void)) ... (set!-values (name ...) expr)))]
[else (syntax/loc stx (define-values (name ...) expr))])]
[(_ names body0 body ...) (pair? (syntax-e #'names))
(let loop ([s #'names] [args '()])
(syntax-case s ()
[(name . arg) (loop #'name (cons #'arg args))]
[name
(let ([sym (syntax-object->datum #'name)])
(let loop ([i (sub1 (length args))]
[as (reverse (cdr args))]
[body #'(begin body0 body ...)])
(if (zero? i)
(cond [(syntax-keyword? #'name)
(raise-syntax-error
#f "cannot redefine a keyword" stx #'name)]
[top-level?
(quasisyntax/loc stx
(begin (define name (void))
(set! name (lambda~ #,(car args) #,body))))]
[else
(quasisyntax/loc stx
(define name (lambda~ #,(car args) #,body)))])
(loop (sub1 i) (cdr as)
(syntax-property
(quasisyntax/loc stx (lambda~ #,(car as) #,body))
'inferred-name
(string->symbol (format "~a:~a" sym i)))))))]))]))
;;>> (let ([id-or-list ...] ...) ...)
;;>> (let* ([id-or-list ...] ...) ...)
;;>> (letrec ([id-or-list ...] ...) ...)
;;> All standard forms of `let' are redefined so they can generate
;;> functions using the same shortcut that `define' allows. This includes
;;> the above extension to the standard `define'. For example:
;;> => (let ([((f x) y) (+ x y)]) ((f 1) 2))
;;> 3
;;> It also includes the `values' keyword in a similar way to `define'.
;;> For example:
;;> => (let ([(values i o) (make-pipe)]) i)
;;> #<pipe-input-port>
(provide (rename let~ let) (rename let*~ let*) (rename letrec~ letrec))
(define-syntaxes (let~ let*~ letrec~)
(let* ([process
(lambda (stx var0 val0 . flat?)
(syntax-case var0 (values)
[(values var ...) (null? flat?) #`((var ...) . #,val0)]
[_ (let loop ([var var0] [args '()])
(if (identifier? var)
(if (null? args)
(let ([val (syntax->list val0)])
(if (and (pair? val) (null? (cdr val)))
(list (if (null? flat?) (list var) var) (car val))
(raise-syntax-error
#f "bad binding" stx #`(#,var0 #,@val0))))
(let ([sym (syntax-e var)])
(let loop ([i (sub1 (length args))]
[as (reverse args)]
[val val0])
(if (< i 0)
(list (if (null? flat?) (list var) var)
(car (syntax->list val)))
(loop (sub1 i) (cdr as)
(let ([val #`((lambda~ #,(car as) #,@val))])
(if (zero? i)
val
(syntax-property
val 'inferred-name
(if (zero? i)
sym
(string->symbol
(format "~a:~a" sym i)))))))))))
(syntax-case var ()
[(var . args1) (loop #'var (cons #'args1 args))])))]))]
[mk-bindings
(lambda (stx bindings . flat?)
(syntax-case bindings ()
[((var val more ...) ...)
(datum->syntax-object
#'bindings
(map (lambda (x y) (apply process stx x y flat?))
(syntax->list #'(var ...))
(syntax->list #'((val more ...) ...)))
#'bindings)]))]
[mk-let
(lambda (tag . lbl)
(lambda (stx)
(syntax-case stx ()
[(_ label bindings body0 body ...)
(and (identifier? #'label) (pair? lbl))
(quasisyntax/loc stx
(#,(car lbl) label #,(mk-bindings stx #'bindings #t)
body0 body ...))]
[(_ bindings body0 body ...)
(quasisyntax/loc stx
(#,tag #,(mk-bindings stx #'bindings) body0 body ...))])))])
(values (mk-let #'let-values #'let)
(mk-let #'let*-values)
(mk-let #'letrec-values))))
;;>> (lambda formals body ...)
;;> The standard `lambda' is extended with Lisp-like &-keywords in its
;;> argument list. This extension is available using the above short
;;> syntax. There is one important difference between these keywords and
;;> Lisp: some &-keywords are used to access arguments that follow the
;;> keyword part of the arguments. This makes it possible to write
;;> procedures that can be invoked as follows:
;;> (f <required-args> <optional-args> <keyword-args> <additional-args>)
;;> (Note: do not use more keywords after the <additional-args>!)
;;>
;;> Available &-keywords are:
(provide (rename lambda~ lambda))
(define-syntax (lambda~ stx)
(define (process-optional-arg o)
(syntax-case o ()
[(var default) (identifier? #'var) (list #'var #'default)]
[(var) (identifier? #'var) (list #'var #'#f)]
[var (identifier? #'var) (list #'var #'#f)]
[var (raise-syntax-error #f "not a valid &optional spec" stx #'var)]))
(define (process-keyword-arg k)
(define (key var)
(datum->syntax-object
k
(string->symbol
(string-append ":" (symbol->string (syntax-object->datum var))))
k k))
(syntax-case k ()
[(var key default)
(and (identifier? #'var) (syntax-keyword? #'key))
(list #'var #'key #'default)]
[(var default) (identifier? #'var) (list #'var (key #'var) #'default)]
[(var) (identifier? #'var) (list #'var (key #'var) #'#f)]
[var (identifier? #'var) (list #'var (key #'var) #'#f)]
[var (raise-syntax-error #f "not a valid &key spec" stx #'var)]))
(syntax-case stx ()
[(_ formals expr0 expr ...)
(let ([vars '()]
[opts '()]
[keys '()]
[rest #f] ; keys and all (no optionals)
[rest-keys #f] ; like the above, minus specified keys
[body #f] ; stuff that follows all keywords
[all-keys #f] ; all keys, excluding body
[other-keys #f]) ; unprocessed keys, excluding body
;; relations:
;; rest = (append all-keys body)
;; rest-keys = (append other-keys body)
(let loop ([state #f] [args #'formals])
(syntax-case args ()
[() #f]
[(v . xs)
(let* ([v #'v]
[k (if (symbol? v) v (and (identifier? v) (syntax-e v)))]
[x (and k (symbol->string k))])
(cond
;; check &-keywords according to their name, so something like
;; (let ([&rest 1]) (lambda (&rest r) ...))
;; works as expected
[(and x (> (string-length x) 0) (eq? #\& (string-ref x 0)))
(case k
;;> * &optional, &opt, &opts: denote an optional argument, possibly with a
;;> default value (if the variable is specified as `(var val)').
;;> => ((lambda (x &optional y [z 3]) (list x y z)) 1)
;;> (1 #f 3)
;;> => ((lambda (x &optional y [z 3]) (list x y z)) 1 2 #f)
;;> (1 2 #f)
[(&optional &optionals &opt &opts)
(if state
(raise-syntax-error
#f "misplaced &optional argument" stx #'formals)
(loop 'o #'xs))]
;;> * &keys, &key: a keyword argument -- the variable should be specified
;;> as `x' or `(x)' to be initialized by an `:x' keyword, `(x v)' to
;;> specify a default value `v', and `(x k v)' to further specify an
;;> arbitrary keyword `k'.
;;> => ((lambda (&key x [y 2] [z :zz 3]) (list x y z)) :x 'x :zz 'z)
;;> (x 2 z)
;;> Note that keyword values take precedence on the left, and that
;;> keywords are not verified:
;;> => ((lambda (&key y) y) :y 1 :z 3 :y 2)
;;> 1
[(&key &keys)
(if (memq state '(#f o r!))
(loop 'k #'xs)
(raise-syntax-error
#f "misplaced &keys argument" stx #'formals))]
;;> * &rest: a `rest' argument which behaves exactly like the Scheme dot
;;> formal parameter (actually a synonym for it: can't use both). Note
;;> that in case of optional arguments, the rest variable holds any
;;> arguments that were not used for defaults, but using keys doesn't
;;> change its value. For example:
;;> => ((lambda (x &rest r) r) 1 2 3)
;;> (2 3)
;;> => ((lambda (x &optional y &rest r) r) 1)
;;> ()
;;> => ((lambda (x &optional y &rest r) r) 1 2 3)
;;> (3)
;;> => ((lambda (x &optional y . r) r) 1 2 3)
;;> (3)
;;> => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4)
;;> (2 (:y 2 3 4))
;;> => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4 5)
;;> (2 (:y 2 3 4 5))
;;> Note that the last two examples indicate that there is no error if
;;> the given argument list is not balanced.
[(&rest)
(if (pair? (syntax-e #'xs))
(loop 'r #'xs)
(raise-syntax-error
#f "no name for &rest argument" stx #'formals))]
;;> * &rest-keys: similar to `&rest', but all specified keys are removed
;;> with their values.
;;> => ((lambda (x &key y &rest r) r) 1 :x 2 :y 3)
;;> (:x 2 :y 3)
;;> => ((lambda (x &key y &rest-keys r) r) 1 :x 2 :y 3)
;;> (:x 2)
[(&rest-keys)
(if (pair? (syntax-e #'xs))
(loop 'rk #'xs)
(raise-syntax-error
#f "no name for &rest-keys argument" stx #'formals))]
;;> * &body: similar to `&rest-keys', but all key/values are removed one
;;> by one until a non-key is encountered. (Warning: this is *not* the
;;> same as in Common Lisp!)
;;> => ((lambda (x &key y &body r) r) 1 :x 2 :y 3)
;;> ()
;;> => ((lambda (x &key y &body r) r) 1 :x 2 :y 3 5 6)
;;> (5 6)
[(&body &rest-all-keys) ; &rest-all-keys for compatibility
(if (pair? (syntax-e #'xs))
(loop 'b #'xs)
(raise-syntax-error
#f "no name for &body argument"
stx #'formals))]
;;> * &all-keys: the list of all keys+vals, without a trailing body.
;;> => ((lambda (&keys x y &all-keys r) r) :x 1 :z 2 3 4)
;;> (:x 1 :z 2)
[(&all-keys)
(if (pair? (syntax-e #'xs))
(loop 'ak #'xs)
(raise-syntax-error
#f "no name for &all-keys argument"
stx #'formals))]
;;> * &other-keys: the list of unprocessed keys+vals, without a trailing
;;> body.
;;> => ((lambda (&keys x y &other-keys r) r) :x 1 :z 2 3 4)
;;> (:z 2)
[(&other-keys)
(if (pair? (syntax-e #'xs))
(loop 'ok #'xs)
(raise-syntax-error
#f "no name for &other-keys argument"
stx #'formals))]
;;>
;;> Finally, here is an example where all &rest-like arguments are
;;> different:
;;> => ((lambda (&keys x y
;;> &rest r
;;> &rest-keys rk
;;> &body b
;;> &all-keys ak
;;> &other-keys ok)
;;> (list r rk b ak ok))
;;> :z 1 :x 2 2 3 4)
;;> ((:z 1 :x 2 2 3 4) (:z 1 2 3 4) (2 3 4) (:z 1 :x 2) (:z 1))
;;> Note that the following invariants hold:
;;> * rest = (append all-keys body)
;;> * rest-keys = (append other-keys body)
[else (raise-syntax-error
#f "unknown lambda &-keyword" stx v)])]
[(not (or x (memq state '(o k))))
(raise-syntax-error #f "not an identifier" stx v)]
[else
(let ([test (lambda (var name)
(if var
(raise-syntax-error
#f (format "too many &~a arguments" name)
stx #'formals)
(set! state 'r!)))])
(case state
[(#f) (set! vars (cons v vars))]
[(o) (set! opts (cons v opts))]
[(k) (set! keys (cons v keys))]
[(r!) (raise-syntax-error
#f "second identifier after a &rest or similar"
stx v)]
[(r) (test rest 'rest ) (set! rest v)]
[(rk) (test rest-keys 'rest-keys ) (set! rest-keys v)]
[(b) (test body 'body ) (set! body v)]
[(ak) (test all-keys 'all-keys ) (set! all-keys v)]
[(ok) (test other-keys 'other-keys) (set! other-keys v)]
[else (raise-syntax-error #f "bad lambda formals" stx v)])
(loop state #'xs))]))]
[v (loop state #'(&rest v))]))
(set! vars (reverse vars))
(set! opts (map process-optional-arg (reverse opts)))
(set! keys (map process-keyword-arg (reverse keys)))
(when (and (or rest-keys body all-keys other-keys) (not rest))
(set! rest #'rest))
(cond
;; non-trivial case -- full processing
[(or (pair? opts) (pair? keys) rest-keys body all-keys other-keys)
(unless rest (set! rest #'rest))
;; other-keys is computed from all-keys
(when (and other-keys (not all-keys)) (set! all-keys #'all-keys))
(quasisyntax/loc stx
(lambda (#,@vars . #,rest)
(let*-values
(#,@(map (lambda (o)
#`[(#,(car o))
(if (pair? #,rest)
(begin0 (car #,rest)
(set! #,rest (cdr #,rest)))
#,(cadr o))])
opts)
#,@(map (lambda (k)
#`[(#,(car k))
(getarg #,rest #,(cadr k)
(lambda () #,(caddr k)))])
keys)
#,@(if rest-keys
#`([(#,rest-keys)
(filter-out-keys '#,(map cadr keys) #,rest)])
#'())
#,@(cond
;; At most one scan for body, all-keys, other-keys. This
;; could be much shorter by always using keys/args, but a
;; function call is not a place to spend time on.
[(and body all-keys)
#`([(#,all-keys #,body)
;; inlined keys/args
(let loop ([args #,rest] [keys '()])
(cond [(or (null? args)
(null? (cdr args))
(not (keyword*? (car args))))
(values (reverse keys) args)]
[else (loop (cddr args)
(list* (cadr args) (car args)
keys))]))])]
[body
#`([(#,body)
(let loop ([args #,rest])
(if (or (null? args)
(null? (cdr args))
(not (keyword*? (car args))))
args
(loop (cddr args))))])]
[all-keys
#`([(#,all-keys)
;; inlined keys/args, not returning args
(let loop ([args #,rest] [keys '()])
(cond [(or (null? args)
(null? (cdr args))
(not (keyword*? (car args))))
(reverse keys)]
[else (loop (cddr args)
(list* (cadr args) (car args)
keys))]))])]
[else #'()])
#,@(if other-keys
#`([(#,other-keys) ; use all-keys (see above)
(filter-out-keys '#,(map cadr keys) #,all-keys)])
#'()))
expr0 expr ...)))]
;; common cases: no optional, keyword, or other fancy stuff
[(null? vars)
(quasisyntax/loc stx
(lambda #,(or rest #'()) expr0 expr ...))]
[else
(quasisyntax/loc stx
(lambda (#,@vars . #,(or rest #'())) expr0 expr ...))]))]))
;; Keyword utilities
(provide (rename keyword*? keyword?) syntax-keyword?
(rename keyword->string* keyword->string)
(rename string->keyword* string->keyword)
;; also provide the builtin as `real-keyword'
(rename keyword? real-keyword?)
(rename keyword->string real-keyword->string)
(rename string->keyword string->real-keyword))
;;>> (keyword? x)
;;> A predicate for keyword symbols (symbols that begin with a ":").
;;> (Note: this is different from Racket's keywords!)
(define (keyword*? x)
(and (symbol? x) (not (eq? x '||))
(eq? (string-ref (symbol->string x) 0) #\:)))
;;>> (syntax-keyword? x)
;;> Similar to `keyword?' but also works for an identifier (a syntax
;;> object) that contains a keyword.
(define (syntax-keyword? x)
(keyword*? (if (syntax? x) (syntax-e x) x)))
;;>> (keyword->string k)
;;>> (string->keyword s)
;;> Convert a Swindle keyword to a string and back.
(define (keyword->string* k)
(if (keyword*? k)
(substring (symbol->string k) 1)
(raise-type-error 'keyword->string "keyword" k)))
(define (string->keyword* s)
(if (string? s)
(string->symbol (string-append ":" s))
(raise-type-error 'string->keyword "string" s)))
;; Keyword searching utilities (note: no errors for odd length)
(provide getarg syntax-getarg getargs keys/args filter-out-keys)
;;>> (getarg args keyword [not-found])
;;> Searches the given list of arguments for a value matched with the
;;> given keyword. Similar to CL's `getf', except no error checking is
;;> done for an unbalanced list. In case no value is found, the optional
;;> default value can be used -- this can be either a thunk, a promise, or
;;> any other value that will be used as is. For a repeated keyword the
;;> leftmost occurrence is used.
(define (getarg args keyword . not-found)
(let loop ([args args])
(cond [(or (null? args) (null? (cdr args)))
(and (pair? not-found)
(let ([x (car not-found)])
(cond [(procedure? x) (x)]
[(promise? x) (force x)]
[else x])))]
[(eq? (car args) keyword) (cadr args)]
[else (loop (cddr args))])))
;;>> (syntax-getarg syntax-args keyword [not-found])
;;> Similar to `getarg' above, but the input is a syntax object of a
;;> keyword-value list.
(define (syntax-getarg syntax-args keyword . not-found)
(when (syntax? keyword) (set! keyword (syntax-e keyword)))
(let loop ([args syntax-args])
(syntax-case args ()
[(key arg . more)
(if (eq? (syntax-e #'key) keyword) #'arg (loop #'more))]
[_ (and (pair? not-found)
(let ([x (car not-found)])
(cond [(procedure? x) (x)]
[(promise? x) (force x)]
[else x])))])))
;;>> (getargs initargs keyword)
;;> The same as `getarg' but return the list of all key values matched --
;;> no need for a default value. The result is in the same order as in
;;> the input.
(define (getargs initargs keyword)
(define (scan tail)
(cond [(null? tail) '()]
[(null? (cdr tail)) (error 'getargs "keyword list not balanced.")]
[(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))]
[else (scan (cddr tail))]))
(scan initargs))
;;>> (keys/args args)
;;> The given argument list is scanned and split at the point where there
;;> are no more keyword-values, and the two parts are returned as two
;;> values.
;;> => (keys/args '(:a 1 :b 2 3 4 5))
;;> (:a 1 :b 2)
;;> (3 4 5)
(define (keys/args args)
(let loop ([args args] [keys '()])
(cond [(or (null? args) (null? (cdr args)) (not (keyword*? (car args))))
(values (reverse keys) args)]
[else (loop (cddr args) (list* (cadr args) (car args) keys))])))
;;>> (filter-out-keys outs args)
;;> The keywords specified in the outs argument, with their matching
;;> values are filtered out of the second arguments.
(define (filter-out-keys outs args)
(let loop ([as args] [r '()])
(cond [(null? as) (reverse r)]
[(null? (cdr as)) (reverse (cons (car as) r))]
[else
(loop (cddr as)
(if (memq (car as) outs) r (list* (cadr as) (car as) r)))])))

732
pkgs/swindle/clos.rkt
View File

@ -1,732 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module contains only syntax definitions, which makes Swindle closer
;;> to CLOS -- making the object system much more convenient to use.
#lang s-exp swindle/turbo
(require swindle/tiny-clos)
(provide (all-from swindle/tiny-clos))
;;; ---------------------------------------------------------------------------
;;; General helpers
(defsyntax (args-arity stx)
(syntax-case stx ()
[(_ args)
(let loop ([args #'args] [n 0])
(syntax-case args ()
[(a . more)
(or (not (identifier? #'a))
;; stop at &-keyword
(let ([sym (syntax-e #'a)])
(or (eq? sym '||)
(not (eq? #\& (string-ref (symbol->string sym) 0))))))
(loop #'more (add1 n))]
[() (datum->syntax-object stx n stx)]
[_ (quasisyntax/loc stx (make-arity-at-least #,n))]))]))
;;; ---------------------------------------------------------------------------
;;; Generic macros
;;>>... Generic macros
;;>> (generic)
;;> | (generic name initargs ...)
;;> | (generic name (arg ...) initargs ...)
;;> Create a generic function object (an instance of the
;;> `*default-generic-class*' parameter). The first form uses the default
;;> name given by the syntactical context, the second one gets an explicit
;;> name and the third also gets a list of arguments which is used to
;;> count the required number of arguments. If there is no argument list
;;> to count, the first method that gets added will set this number. The
;;> two last forms allow initargs to be passed to the <generic> instance
;;> creation, for example, to specify a `:combination' argument. (The
;;> first form does not allow keywords, since a keyword would be taken as
;;> the name.)
(defsyntax* (generic stx)
(syntax-case stx ()
[(_)
#`(make (*default-generic-class*) :name '#,(syntax-local-name))]
[(_ name) (identifier? #'name)
#'(make (*default-generic-class*) :name 'name)]
[(_ name initarg initargs ...)
(and (identifier? #'name) (syntax-keyword? #'initarg))
#'(make (*default-generic-class*) initarg initargs ... :name 'name)]
[(_ name args) (identifier? #'name)
#`(make (*default-generic-class*)
:name 'name :arity (args-arity args))]
[(_ name args initarg initargs ...)
(and (identifier? #'name) (syntax-keyword? #'initarg))
#`(make (*default-generic-class*)
initarg initargs ... :name 'name :arity (args-arity args))]))
;;>> (defgeneric name (arg ...) initargs ...)
;;> | (defgeneric (name arg ...) initargs ...)
;;> | (defgeneric name initargs ...)
;;> This form defines a generic function using the `generic' syntax given
;;> above. The last form doesn't specify a number of arguments. Some
;;> extra `initargs' can be specified too but they are needed mainly for a
;;> `:combination' argument.
(defsyntax* (defgeneric stx)
(let* ([ctx (syntax-local-context)]
[ctx (cond [(pair? ctx) (car ctx)]
[(eq? ctx 'top-level) ctx]
[else #f])]
[mark (lambda (name)
((syntax-local-value #'generic-contexts-defined?) name ctx))])
(syntax-case stx ()
[(_ name args initargs ...) (identifier? #'name)
(begin (mark #'name) #'(define name (generic name args initargs ...)))]
[(_ (name . args) initargs ...) (identifier? #'name)
(begin (mark #'name) #'(define name (generic name args initargs ...)))]
[(_ name initargs ...) (identifier? #'name)
(begin (mark #'name) #'(define name (generic name initargs ...)))])))
;; returns #t if an identifier id in context ctx is already defined as a genric
;; (used by defmethod to detect when it should expand to an add-method)
(define-syntax generic-contexts-defined?
(let ([table (make-hash-table 'weak)])
(lambda (id ctx)
;; ctx is either the first element of (syntax-local-context) or
;; 'top-level. Note that top-level identifiers in different modules
;; should not be `module-identifier=?' (eg, `eval' takes care of this).
(let ([cs (hash-table-get table ctx (lambda () '()))])
(or (ormap (lambda (c) (module-identifier=? id c)) cs) ; defined
(begin (hash-table-put! table ctx (cons id cs)) ; undefined
#f))))))
;;; ---------------------------------------------------------------------------
;;; Method macros
;;>>... Method macros
;;>> (call-next-method [args ...]) [*local*]
;;>> (next-method?) [*local*]
;;> These are bindings which are available only in method bodies.
;;> `call-next-method' will invoke the next method in a generic invocation
;;> sequence if any. If arguments are given to `call-next-method', it
;;> will change the arguments for the next method -- but this is done when
;;> the methods are already filtered and sorted, so the new arguments
;;> should always be consistent with the old types. If there are no
;;> methods left, or when calling a method directly, or when a before or
;;> after method is used, the `no-next-method' generic will be used --
;;> normally resulting in an error. `next-method?' returns `#t' if there
;;> is another method ready to be called.
(defsyntax (make-method-specs/initargs stx)
(syntax-case stx ()
[(_ name args0 body . more)
(let loop ([args #'args0] [specializers '()] [arguments '()])
(syntax-case args (=)
[([arg = val] . rest)
(loop #'rest
(cons #'(singleton val) specializers) (cons #'arg arguments))]
[([arg type] . rest)
(loop #'rest (cons #'type specializers) (cons #'arg arguments))]
[([arg] . rest)
(loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
[(arg . rest)
(and (identifier? #'arg)
;; stop at &-keyword
(let ([sym (syntax-e #'arg)])
(or (eq? sym '||)
(not (eq? #\& (string-ref (symbol->string sym) 0))))))
(loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
[_ ; both null and rest argument
(let* ([specializers (reverse specializers)]
[arguments (reverse arguments)]
[name-e (syntax-e #'name)]
[cnm (datum->syntax-object
#'args0 'call-next-method #'args0)])
(unless (null? (syntax-e args))
(set! arguments
(if (null? arguments) args (append arguments args))))
(let ([makeit
(quasisyntax/loc stx
(make (*default-method-class*)
:specializers (list #,@specializers)
:name '#,(if name-e #'name (syntax-local-name))
:procedure
(lambda (#,cnm . #,arguments)
;; See "Trick" in tiny-clos.rkt
;; -- use a syntax to not do this unless needed
(letsyntax
([#,(datum->syntax-object
#'args0 'next-method? #'args0)
(lambda (stx)
(syntax-case stx ()
[(__) #'(not (eq? '*no-next-method*
(object-name #,cnm)))]
[(__ . xs)
#'((named-lambda next-method? () 1)
. xs)]
[__
#'(named-lambda next-method? ()
(not
(eq? '*no-next-method*
(object-name #,cnm))))]))])
. body))
. more))])
(if name-e
(quasisyntax/loc stx (letrec ([name #,makeit]) name))
makeit)))]))]))
;;>> (method (arg ...) body ...)
;;>> (named-method name (arg ...) body ...)
;;>> (qualified-method qualifier (arg ...) body ...)
;;> These forms are all similar variants to create a method object (and
;;> instance of the `*default-method-class*' parameter). A method looks
;;> very similar to a lambda expression, except that the an argument can
;;> be a of the form `[arg spec]' where `spec' is a specializer -- either
;;> a class or a singleton specifier (the square brackets are equivalent
;;> to round parens, just make the code more readable). Also, an argument
;;> can have the form of `[arg = val]' which is shorthand for specifying
;;> `[arg (singleton val)]'. In case of a simple argument, <top> is
;;> always used as a specializer, but this processing stops as soon as a
;;> &-keyword is encountered. The `named-method' form is used to provide
;;> an explicit name (which can be used to call itself recursively) , and
;;> `qualified-method' is used to provide an explicit qualifier (which
;;> should be one of the standard qualifiers (:primary, :around, :before,
;;> or :after) when using the standard <method> and <generic> classes).
;;>
;;> The resulting method can be added to a generic and these specializers
;;> will be used when filtering applicable methods, or it can be used by
;;> itself and the specializers will be used to check the arguments. This
;;> makes it easy to use `method' instead of `lambda' to get some type
;;> information, but note that the result is going to run slower since the
;;> type check only takes time but cannot be used by Racket to optimize
;;> the code.
;;>
;;> Note that the specializer argument are evaluated normally, which means
;;> that anything can be used, even something like:
;;> (let ([x (list <string> <integer>)])
;;> (method ([x (2nd x)] [y = (+ 2 3)]) (+ x y)))
(defsubst* (method args body0 body ...)
(make-method-specs/initargs #f args (body0 body ...)))
(defsubst* (named-method name args body0 body ...)
(make-method-specs/initargs name args (body0 body ...)))
(defsubst* (qualified-method qualifier args body0 body ...)
(make-method-specs/initargs #f args (body0 body ...) :qualifier qualifier))
;;>> (-defmethod-create-generics- [#t/#f])
;;> This is a syntax parameter (see above) holding a boolean. When this
;;> is set to `#t' (the default), then the `defmethod' form below will try
;;> to detect when the first definition happens and automatic add a
;;> `defgeneric' form to define the object as a generic. A safer but less
;;> convenient approach would be to set this to `#f' and always do an
;;> explicit `defgeneric'.
(define-syntax-parameter* -defmethod-create-generics- #t)
(defsyntax (method-def-adder stx)
(syntax-case stx ()
[(_ qualifier name args body ...) (identifier? #'name)
;; always make it with no name so add-method will add it
(with-syntax ([method-make (syntax/loc stx
(qualified-method qualifier args body ...))])
(let ([ctx (syntax-local-context)])
(cond
[(or ; if:
;; not enabled
(not (syntax-e ((syntax-local-value
#'-defmethod-create-generics-))))
;; expression position -- same as using add-method
(eq? 'expression ctx)
;; defined symbol or second module binding
(identifier-binding #'name)
;; already defined in this local context or top-level
(let ([ctx (cond [(pair? ctx) (car ctx)]
[(eq? ctx 'top-level) ctx]
[else #f])])
(and ctx ((syntax-local-value #'generic-contexts-defined?)
#'name ctx))))
;; then use add-method
;; (printf ">>> ~s: add\n" (syntax-e #'name))
(syntax/loc stx (add-method name method-make))]
;; this might still be useful sometimes...
;; [(eq? 'top-level ctx)
;; ;; if top-level then use a trick: try to use an
;; (syntax/loc stx
;; (define name ; trick: try using exising generic
;; (let ([g (or (no-errors name) (generic name))])
;; (add-method g method-make)
;; g)))]
[else
;; first module or function binding
;; (printf ">>> ~s: def\n" (syntax-e #'name))
(syntax/loc stx (define name
(let ([g (generic name)])
(add-method g method-make)
g)))])))]))
;;>> (defmethod name [qualifier] (arg ...) body ...)
;;> | (defmethod [qualifier] (name arg ...) body ...)
;;> This form is used to define a method object using `method' and its
;;> variants above. A qualifier (a :keyword) can be specified anywhere
;;> before the argument list, and the name can be either specified before
;;> the arguments (Lisp style) or with the arguments (Scheme style).
;;> Depending on `-defmethod-create-generics-' (see above), this form
;;> might add a `defgeneric' form to define the given `name' as a generic
;;> object, and then add the created method. The created method is
;;> attached to the generic in any case, which makes the name of this form
;;> a little misleading since it is not always defining a variable value.
;;> In a local definition context, this should do the right thing as long
;;> as `defmethod' or `defgeneric' is used to define the method (but note
;;> that using a local generic function, is very inefficient) -- for
;;> example, both of these work (defining a local generic):
;;> (define (f)
;;> (defgeneric foo)
;;> (defmethod (foo [x <c1>]) 1)
;;> (defmethod (foo [x <c2>]) 2)
;;> 3)
;;> (define (f)
;;> (defmethod (foo [x <c1>]) 1)
;;> (defmethod (foo [x <c2>]) 2)
;;> 3)
;;> but this fails because the first `defmethod' doesn't know that it is
;;> already defined:
;;> (define (f)
;;> (define foo (generic foo))
;;> (defmethod (foo [x c1]) 1)
;;> (defmethod (foo [x c1]) 2)
;;> 3)
;;> second "but" -- this:
;;> (define (f)
;;> (define foo (generic foo))
;;> blah
;;> (defmethod (foo [x <c1>]) 1)
;;> (defmethod (foo [x <c2>]) 2)
;;> 3)
;;> works because a `defmethod' in an expression context is always the
;;> same as `add-method'.
(defsyntax* (defmethod stx)
(define (n+a? stx)
(let ([na (syntax-e stx)]) (and (pair? na) (identifier? (car na)))))
(syntax-case stx ()
[(_ name qualifier args body0 body ...)
(and (identifier? #'name) (syntax-keyword? #'qualifier))
(syntax/loc stx
(method-def-adder qualifier name args body0 body ...))]
[(_ qualifier name args body0 body ...)
(and (identifier? #'name) (syntax-keyword? #'qualifier))
(syntax/loc stx
(method-def-adder qualifier name args body0 body ...))]
[(_ qualifier name+args body0 body ...)
(and (n+a? #'name+args) (syntax-keyword? #'qualifier))
;; simple pattern matching with (name . args) and using args won't work
;; since the destructing loses the arguments context and call-next-method
;; won't be accessible in the body.
(with-syntax ([name (car (syntax-e #'name+args))]
[args (datum->syntax-object ; hack binding context!
#'name+args
(cdr (syntax-e #'name+args))
#'name+args)])
(syntax/loc stx
(method-def-adder qualifier name args body0 body ...)))]
[(_ name+args body0 body ...) (n+a? #'name+args)
;; same as above
(with-syntax ([name (car (syntax-e #'name+args))]
[args (datum->syntax-object ; hack binding context!
#'name+args
(cdr (syntax-e #'name+args))
#'name+args)])
(syntax/loc stx
(method-def-adder #f name args body0 body ...)))]
[(_ name args body0 body ...) (identifier? #'name)
(syntax/loc stx (method-def-adder #f name args body0 body ...))]))
;;>> (beforemethod ...)
;;>> (aftermethod ...)
;;>> (aroundmethod ...)
;;>> (defbeforemethod ...)
;;>> (defaftermethod ...)
;;>> (defaroundmethod ...)
;;> These forms are shorthands that will generate a qualified method using
;;> one of the standard qualifiers.
(defsubst* (beforemethod . more) (qualified-method :before . more))
(defsubst* (aftermethod . more) (qualified-method :after . more))
(defsubst* (aroundmethod . more) (qualified-method :around . more))
(defsubst* (defbeforemethod . more) (defmethod :before . more))
(defsubst* (defaftermethod . more) (defmethod :after . more))
(defsubst* (defaroundmethod . more) (defmethod :around . more))
;;; ---------------------------------------------------------------------------
;;; Class macros
;;>>... Class macros
(defsyntax (make-class-form stx)
(define (slots/initargs s/a)
(let loop ([xs s/a] [r '()])
(syntax-case xs ()
[() (values (datum->syntax-object #'s/a (reverse r) #'s/a)
#'())]
[((name . args) . more) (identifier? #'name)
(loop #'more (cons #'(list 'name . args) r))]
[(key val . more) (syntax-keyword? #'key)
(values (datum->syntax-object #'s/a (reverse r) #'s/a)
#'(key val . more))]
[(name . more) (identifier? #'name)
(loop #'more (cons #'(list 'name) r))])))
(syntax-case stx ()
[(_ metaclass cname supers . s/a)
(let*-values ([(slots initargs) (slots/initargs #'s/a)]
[(meta) (syntax-getarg initargs :metaclass #'metaclass)])
(with-syntax ([(arg ...) #`(#,@initargs
:direct-supers (list . supers)
:direct-slots (list #,@slots)
:name '#,(if (syntax-e #'cname)
#'cname (syntax-local-name)))])
(if (identifier? #'cname)
#`(rec-make (cname #,meta arg ...))
#`(make #,meta arg ...))))]))
;;>> (class [name] (super ...) slot ... class-initarg ...)
;;> Create a class object (an instance of the `*default-class-class*'
;;> parameter). An explicit name can optionally be specified explicitly.
;;> The list of superclasses are evaluated normally, so they can be any
;;> expression (as with the `method' forms). Each slot can be either a
;;> symbol, which will be used as the slot name, or a list that begins
;;> with a symbol and continues with a keyword-argument option list.
;;> Finally, more initargs for the class generation can be provided. See
;;> the `defclass' forms below for an explanation on the available slot
;;> option and class initargs. If a name is given, then `rec-make' is
;;> used, see that for a description.
(defsyntax* (class stx)
(syntax-case stx ()
[(_ name supers slot ...) (identifier? #'name)
#'(make-class-form (*default-class-class*) name supers slot ...)]
[(_ supers slot ...)
#'(make-class-form (*default-class-class*) #f supers slot ...)]))
;;>> (entityclass [name] (super) slot ... class-initarg ...)
;;> Same as the `class' form, but creates an entity class object (an
;;> instance of the `*default-entityclass-class*' parameter).
(defsyntax* (entityclass stx)
(syntax-case stx ()
[(_ name supers slot ...) (identifier? #'name)
#'(make-class-form (*default-entityclass-class*) name supers slot ...)]
[(_ supers slot ...)
#'(make-class-form (*default-entityclass-class*) #f supers slot ...)]))
;;>> (-defclass-auto-initargs- [#f/initargs])
;;> This is a syntax parameter (see above) holding either `#f' or an
;;> initargs list . If it is not `#f', `defclass' below will add its
;;> contents to the end of the given initargs (so user supplied arguments
;;> can override them). The default is `#f'.
(define-syntax-parameter* -defclass-auto-initargs- #f)
;;>> (-defclass-autoaccessors-naming- [naming-keyword])
;;> This syntax parameter holds a keyword symbol that is used in the
;;> `defclass' for the `:autoaccessors' if it is specified as `#t' or if
;;> it used due to `:auto'. See the description of the `:autoaccessors'
;;> option below for possible values. The default is `:class-slot'.
(define-syntax-parameter* -defclass-autoaccessors-naming- :class-slot)
;;>> (-defclass-accessor-mode- [mode-keyword])
;;> This syntax parameter holds a keyword symbol that is used in the
;;> `defclass' for the way accessors, readers, and writers are generated.
;;> It can be `:defmethod' for using `defmethod', `:defgeneric' for using
;;> `defgeneric' and then `add-method', `:add-method' for using
;;> `add-method', `:method' for defining an independent method, or
;;> `:procedure' for defining a simple Scheme procedure. The default is
;;> `:defmethod. This default is usually fine, but a situation where this
;;> is important is if the syntax parameter `-defmethod-create-generics-'
;;> is set to `#f' so a `defmethod' requires a prior `defgeneric' so a
;;> defclass will not work unless the generic functions are defined in
;;> advance.
(define-syntax-parameter* -defclass-accessor-mode- :defmethod)
;;>> (defclass name (super ...) slot ... class-initarg ...)
;;> This form uses the `class' form above to define a new class. See the
;;> `class' form for the syntax. Note that slot-options that are not
;;> compile-time ones (method names) are accumulated according to the
;;> class precedence list.
;;>
;;> Available slot options are:
;;> * :initarg keyword
;;> Use `keyword' in `make' to provide a value for this slot.
;;> * :initializer func
;;> Use the given function to initialize the slot -- either a thunk or a
;;> function that will be applied on the initargs given to `make'.
;;> * :initvalue value
;;> Use `value' as the default for this slot.
;;> * :reader name
;;> Define `name' (an unquoted symbol) as a reader method for this slot.
;;> * :writer name
;;> Define `name' (an unquoted symbol) as a writer method for this slot.
;;> * :accessor name
;;> Define `name' (an unquoted symbol) as an accessor method for this
;;> slot -- this means that two methods are defined: `name' and
;;> `set-name!'.
;;> * :type type
;;> Restrict this slot value to objects of the given `type'.
;;> * :lock { #t | #f | value }
;;> If specified and non-`#f', then this slot is locked. `#t' locks it
;;> permanently, but a different value works as a key: they allow setting
;;> the slot by using cons of the key and the value to set.
;;> * :allocation { :class | :instance }
;;> Specify that this slot is a normal one (`:instance', the default),
;;> or allocated per class (`:class').
;;> The specific way of creating helper methods (for readers, writers, and
;;> accessors) is determined by `-defclass-accessor-mode-' (see above).
;;>
;;> Available class options (in addition to normal ones that initialize
;;> the class slots like `:name', `:direct-slots', `:direct-supers') are:
;;> * :metaclass class
;;> create a class object which is an instance of the `class'
;;> meta-class (this means that an instance of the given meta-class
;;> should be used for creating the new class).
;;> * :autoinitargs { #t | #f }
;;> if set to `#t', make the class definition automatically generate
;;> initarg keywords from the slot names. (The keywords have the same
;;> name as the slots, eg `:foo'.)
;;> * :autoaccessors { #f | #t | :class-slot | :slot }
;;> if set to non-`#f', generate accessor methods automatically --
;;> either using the classname "-" slotname convention (`:class-slot')
;;> or just the slotname (`:slot'). If it is `#t' (or turned on by
;;> `:auto') then the default naming style is taken from the
;;> `-defclass-autoaccessors-naming-' syntax parameter. Note that for
;;> this, and other external object definitions (`:automaker' and
;;> `:autopred'), the class name is stripped of a surrounding "<>"s if
;;> any.
;;> * :automaker { #f | #t }
;;> automatically creates a `maker' function using the "make-" classname
;;> naming convention. The maker function is applied on arguments and
;;> keyword-values -- if there are n slots, then arguments after the
;;> first n are passed to `make' to create the instance, then the first
;;> n are `slot-set!'ed into the n slots. This means that it can get
;;> any number of arguments, and usually there is no point in additional
;;> keyword values (since if they initialize slots, their values will
;;> get overridden anyway). It also means that the order of the
;;> arguments depend on the *complete* list of the class's slots (as
;;> given by `class-slots'), so use caution when doing multiple
;;> inheritance (actually, in that case it is probably better to avoid
;;> these makers anyway).
;;> * :autopred { #f | #t }
;;> automatically create a predicate function using the `classname "?"'
;;> naming convention.
;;> * :default-slot-options { #f | '(keyword ...) }
;;> if specified as a quoted list, then slot descriptions are modified
;;> so the first arguments are taken as values to the specified
;;> keywords. For example, if it is `'(:type :initvalue)' then a slot
;;> description can have a single argument for `:type' after the slot
;;> name, a second argument for `:initvalue', and the rest can be more
;;> standard keyword-values. This is best set with
;;> `-defclass-auto-initargs-'
;;> * :auto { #f | #t }
;;> if specified as `#t', then all automatic behavior available above is
;;> turned on.
;; The following option is added in extra.rkt
;;> * :printer { #f | #t | procedure }
;;> if given, install a printer function. `#t' means install the
;;> `print-object-with-slots' function from "clos.rkt", otherwise, it is
;;> expected to be a function that gets an object, an escape boolean
;;> flag an an optional port (i.e, 2 or more arguments), and prints the
;;> object on the class using the escape flag to select `display'-style
;;> (`#f') or `write'-style (#t).
;;>
;;> Note that the class object is made by `class' with a name, so it is
;;> possible to use the class itself as the value of `:type' properties
;;> for a recursive class.
;;>
;;> Whenever the classname is used, it is taken from the defined name,
;;> without a surrounding "<>"s if any. Note that some of these options
;;> are processed at compile time (all method names and auto-generation of
;;> methods).
(defsyntax (make-defclass-form stx)
(syntax-case stx ()
[(_ class-maker name supers . slots0)
(identifier? #'name)
(let loop ([slots1 #'slots0] [slots2 '()])
(syntax-case slots1 ()
[(slot more ...) (not (syntax-keyword? #'slot))
(loop #'(more ...) (cons #'slot slots2))]
[(initarg ...) ; if slots1 is not null then it contains class keywords
(let* ([autoargs (let ([as ((syntax-local-value
#'-defclass-auto-initargs-))])
(and (syntax? as) (syntax-e as) as))]
[initargs (if autoargs
#`(initarg ... #,@autoargs) #'(initarg ...))]
[defmethods '()]
[sgetarg (lambda (arg . def)
(let ([a (apply syntax-getarg initargs arg def)])
(if (syntax? a) (syntax-object->datum a) a)))]
[all-auto (sgetarg :auto)]
[autoaccessors (sgetarg :autoaccessors (and all-auto #t))]
[automaker (or (sgetarg :automaker) all-auto)]
[autopred (or (sgetarg :autopred) all-auto)]
[accessor-mode (syntax-e ((syntax-local-value
#'-defclass-accessor-mode-)))]
[default-slot-options (sgetarg :default-slot-options)]
[string-name
(regexp-replace
#rx"^<(.*)>$" (symbol->string (syntax-e #'name)) "\\1")])
(define (get-defaccessor-form a-name typed-args untyped-args body)
(case accessor-mode
[(:defmethod)
#`(defmethod (#,a-name #,@typed-args) #,body)]
[(:defgeneric)
#`(begin (defgeneric (#,a-name #,@untyped-args))
(add-method #,a-name (method #,typed-args #,body)))]
[(:add-method)
#`(add-method #,a-name (method #,typed-args #,body))]
[(:method) #`(define #,a-name (method #,typed-args #,body))]
[(:procedure) #`(define (#,a-name #,@untyped-args) #,body)]
[else (error
'defclass
"bad value in -defclass-accessor-mode-: ~e"
accessor-mode)]))
(define (addreader reader sname)
(push! (get-defaccessor-form
reader #'((x name)) #'(x) #`(slot-ref x '#,sname))
defmethods))
(define (addwriter writer sname type)
(push! (get-defaccessor-form
writer #`((x name) #,(if type #`(n #,type) #'n)) #'(x n)
#`(slot-set! x '#,sname n))
defmethods))
(define (do-slot slot)
(define-values (sname args)
(syntax-case slot ()
[(sname args ...)
(values
#'sname
(cond
[(not default-slot-options) #'(args ...)]
[(and (list? default-slot-options)
(= 2 (length default-slot-options))
(memq (car default-slot-options)
'(quote quasiquote)))
(let loop ([d (cadr default-slot-options)]
[as #'(args ...)]
[r '()])
(syntax-case as ()
[(v rest ...) (pair? d)
(loop (cdr d)
#'(rest ...)
(list* #'v (car d) r))]
[_ (datum->syntax-object #'(args ...)
(append (reverse r) as)
#'(args ...))]))]
[else (raise-syntax-error
#f "bad form for :default-slot-options"
stx initargs)]))]
[sname (values #'sname #'())]))
(let ([reader (syntax-getarg args :reader)]
[writer (syntax-getarg args :writer)]
[accessor
(syntax-getarg
args :accessor
(and autoaccessors
(thunk
(if (eq? autoaccessors :slot)
sname
(datum->syntax-object
sname
(string->symbol
(concat string-name "-"
(symbol->string (syntax-e sname))))
sname)))))]
[type (syntax-getarg args :type)])
(when reader (addreader reader sname))
(when writer (addwriter writer sname type))
(when accessor
(addreader accessor sname)
(addwriter
(datum->syntax-object
accessor
(string->symbol
(concat "set-" (symbol->string (syntax-e accessor)) "!"))
accessor)
sname type))
(let loop ([as args] [res (list sname)])
(syntax-case as ()
[(keyword value more ...)
(loop #'(more ...)
(list* (if (memq (syntax-e #'keyword)
'(:reader :writer :accessor))
#''value #'value)
#'keyword res))]
[() (datum->syntax-object as (reverse res) as)]))))
(when (eq? autoaccessors #t)
(set! autoaccessors
(syntax-e ((syntax-local-value
#'-defclass-autoaccessors-naming-)))))
(unless (memq autoaccessors '(#t #f :slot :class-slot))
(raise-syntax-error
#f (concat "`:autoaccessors' expecting either a "
"`:slot' or `:class-slot' as value.")
stx initargs))
(let ([slots (map do-slot (reverse slots2))])
#`(begin
(define name
(class-maker name supers
. #,(datum->syntax-object
#'slots0
;; note: append with a non-list 2nd arg
(append
slots (if all-auto
#`(:autoinitargs #t #,@initargs)
initargs))
#'slots0)))
#,@(datum->syntax-object
#'stx (reverse defmethods) #'stx)
#,@(if automaker
(with-syntax
([maker (datum->syntax-object
#'name
(string->symbol
(concat "make-" string-name))
#'name)])
#'((define maker
(let ([slots (class-slots name)])
(lambda args
(let loop ([as args] [ss slots] [r '()])
(if (or (null? as) (null? ss))
(let ([new (make name . as)])
(for-each (lambda (x)
(slot-set! new . x))
r)
new)
(loop (cdr as) (cdr ss)
(cons (list (caar ss) (car as))
r)))))))))
'())
#,@(if autopred
(with-syntax
([pred? (datum->syntax-object
#'name
(string->symbol (concat string-name "?"))
#'name)])
#'((define (pred? x) (instance-of? x name))))
'()))))]))]))
(defsubst* (defclass name supers slot ...)
(make-defclass-form class name supers slot ...))
;;>> (defentityclass name (super ...) slot ... class-initarg ...)
;;> The same as `defclass', but for entity classes.
(defsubst* (defentityclass name supers slot ...)
(make-defclass-form entityclass name supers slot ...))
;;; ---------------------------------------------------------------------------
;;; Forms with a provide version
;;>>...
;;> *** Auto provide forms
;;>> (defgeneric* ...)
;;>> (defclass* ...)
;;>> (defentityclass* ...)
;;> These forms are defined as the original version, except that the
;;> defined variable is automatically provided (made using
;;> `make-provide-syntax' above). Note that there is no version for
;;> `defmethod' since it should not be used where a single definition
;;> place is needed -- and it wouldn't make sense to have multiple
;;> `provide' forms for every `defmethod*' occurrence. Note that
;;> `defclass*' provides only the class identifier and not any
;;> automatically generated ones (accessors etc).
(provide defgeneric*) (make-provide-syntax defgeneric defgeneric*)
(provide defclass*) (make-provide-syntax defclass defclass*)
(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)

80
pkgs/swindle/custom.rkt
View File

@ -1,80 +0,0 @@
;;; CustomSwindle
;;; Name: CustomSwindle
;;; DialogName: Customized Swindle
;;; OneLine: Sample Customized Swindle
;;; URL: http://www.barzilay.org/Swindle/
;;; This file demonstrates how a customized Swindle-based language can be
;;; created. Most of these things could be done with the GUI language
;;; customizing, but (a) it will make it very verbose, (b) most syntax settings
;;; are things that beginners should not know about, (c) it will not allow
;;; things like the redefinition of `lambda' which is done below. To make a
;;; customization file, it should be some *.rkt file in this directory, that
;;; begins in the same way as above commented prefix: beginning with the magic
;;; string, and then specifying some parameters for this language. Specifying
;;; the language's name as it appears at the top of the interactions menu
;;; (defaults to the file name minus the ".rkt"), the name as it appears in the
;;; language selection dialog box (defaults to the Name), the one-line
;;; description (appears at the bottom of the language dialog), and a URL to
;;; jump to when the name in the interactions is clicked. Remember that since
;;; the language can be pretty different than Swindle, then appropriate
;;; documentation should be added too.
;;;
;;; This is a good place to add common functionality and customizations, but
;;; not things that can be made into a module -- a teachpack is better for
;;; those.
#lang swindle
;; provide all swindle, minus `lambda' which is overriden to `method'
(provide (all-from-except swindle lambda))
(provide (rename lambda~ lambda))
(defsubst lambda~ method)
;; some default customizations
(*make-safely* #t)
;; set some syntax parameters -- must use eval!
(eval #'(begin
;; simple defclass forms:
(-defclass-auto-initargs-
(;; auto acccessors, constructors, and predicates
:auto #t
;; first two things after a slot name are type and initvalue
:default-slot-options '(:type :initvalue)
;; printed representation of objects shows slot contents
:printer print-object-with-slots))
;; set the accessor names made by the above
(-defclass-autoaccessors-naming- :class-slot)
;; always use an explicit generic
(-defmethod-create-generics- #f)
;; use defgeneric + add-method for accessors (since defmethod now
;; wouldn't create the generic)
(-defclass-accessor-mode- :defgeneric)))
;;; To make things even better, it is best to change preferences so Swindle
;;; syntax get indented correctly. For this, create the default preference
;;; file "plt/collects/defaults/plt-prefs.rkt", and in it you can put any
;;; specific preferences you want as the defaults for people who run the system
;;; for the first time (see the "Preference Files" section in the Help Desk).
;;; The two relevant settings are -- make Swindle the default language:
;;; (drscheme:205-settings
;;; (("Swindle" "Full Swindle")
;;; #6(#f current-print mixed-fraction-e #f #t debug)))
;;; And to make indentation handle Swindle forms correctly, locate the tab
;;; specifications line and add the swindle forms indentation:
;;; (framework:tabify
;;; (... stuff which is already there ...
;;; (define* define) (define-syntax* define) (defsyntax define)
;;; (defsyntax* define) (letsyntax lambda) (defsubst define)
;;; (defsubst* define) (letsubst lambda) (defmacro define)
;;; (defmacro* define) (letmacro lambda) (named-lambda lambda)
;;; (thunk lambda) (while lambda) (until lambda) (dotimes lambda)
;;; (dolist lambda) (no-errors lambda) (regexp-case lambda)
;;; (generic lambda) (defgeneric define) (method lambda)
;;; (named-method lambda) (qualified-method lambda) (defmethod define)
;;; (beforemethod lambda) (aftermethod lambda) (aroundmethod lambda)
;;; (defbeforemethod define) (defaftermethod define)
;;; (defaroundmethod define) (class lambda) (entityclass lambda)
;;; (defclass define) (defentityclass define) (defgeneric* define)
;;; (defclass* define) (defentityclass* define) (with-slots lambda)
;;; (with-accessors lambda) (matcher lambda) (match lambda)
;;; (defmatcher define) (defmatcher0 define)))

969
pkgs/swindle/extra.rkt
View File

@ -1,969 +0,0 @@
#lang s-exp swindle/turbo
;;> This module defines some additional useful functionality which requires
;;> Swindle.
(require swindle/clos)
;;; ---------------------------------------------------------------------------
;;; A convenient `defstruct'
;; This makes it possible to create Racket structs using Swindle's `make' and
;; keyword arguments.
(define struct-to-slot-names (make-hash-table))
(hash-table-put! struct-to-slot-names <struct> '())
(add-method initialize (method ([s <struct>] initargs) ???))
(define (struct-type->class* stype maker slots)
(let* ([this (struct-type->class stype)]
[superslots (let ([s (class-direct-supers this)])
(and (pair? s) (null? (cdr s))
(hash-table-get
struct-to-slot-names (car s) (thunk #f))))])
(when superslots
(when (some (lambda (x) (memq x superslots)) slots)
(error 'defstruct "cannot redefine slot names"))
(let ([allslots (append superslots slots)])
(hash-table-put! struct-to-slot-names this slots)
(add-method allocate-instance
(let ([???s (build-list (length allslots) (lambda _ ???))])
(method ([class = this] initargs) (maker . ???s))))
(add-method initialize
(let ([none "-"]
[keys (build-list
(length slots)
(lambda (n) (list (symbol-append ': (nth slots n)) n)))]
[setter! (5th (call-with-values
(thunk (struct-type-info stype))
list))])
(method ([obj this] initargs)
(for-each (lambda (k)
(let ([v (getarg initargs (1st k) none)])
(unless (eq? none v)
(setter! obj (2nd k) v))))
keys)
(call-next-method))))))
this))
;;>> (defstruct <struct-name> ([super]) slot ...)
;;> This is just a Swindle-style syntax for one of
;;> (define-struct struct-name (slot ...) (make-inspector))
;;> (define-struct (struct-name super) (slot ...) (make-inspector))
;;> with an additional binding of <struct-name> to the Swindle class that
;;> is computed by `struct-type->class'. The `(make-inspector)' is needed
;;> to make this a struct that we can access information on. Note that in
;;> method specifiers, the `struct:foo' which is defined by
;;> `define-struct' can be used just like `<foo>'. What all this means is
;;> that you can use Racket structs if you just want Swindle's generic
;;> functions, but use built in structs that are more efficient since they
;;> are part of the implementation. For example:
;;>
;;> => (defstruct <foo> () x y)
;;> => <foo>
;;> #<primitive-class:foo>
;;> => (defmethod (bar [x <foo>]) (foo-x x))
;;> => (bar (make-foo 1 2))
;;> 1
;;> => (defmethod (bar [x struct:foo]) (foo-x x))
;;> => (bar (make-foo 3 4))
;;> 3
;;> => (generic-methods bar)
;;> (#<method:bar:foo>)
;;> => (defstruct <foo2> (foo) z)
;;> => (bar (make-foo2 10 11 12))
;;> 10
;;>
;;> To make things even easier, the super-struct can be written using a
;;> "<...>" syntax which will be stripped, and appropriate methods are
;;> added to `allocate-instance' and `initialize' so structs can be built
;;> using keywords:
;;>
;;> => (defstruct <foo3> (<foo>) z)
;;> => (foo-x (make <foo3> :z 3 :y 2 :x 1))
;;> 1
;;> => (foo3-z (make <foo3> :z 3 :y 2 :x 2))
;;> 3
;;>
;;> The `<struct-name>' identifier *must* be of this form -- enclosed in
;;> "<>"s. This restriction is due to the fact that defining a Racket
;;> struct `foo', makes `foo' bound as a syntax object to something that
;;> cannot be used in any other way.
(defsyntax* (defstruct stx)
(define <>-re #rx"^<(.*)>$")
(define (<>-id? id)
(and (identifier? id)
(regexp-match? <>-re (symbol->string (syntax-e id)))))
(define (doit name super slots)
(let* ([str (regexp-replace <>-re (symbol->string (syntax-e name)) "\\1")]
[name-sans-<> (datum->syntax-object name (string->symbol str) name)]
[struct:name (datum->syntax-object
name (string->symbol (concat "struct:" str)) name)]
[make-struct (datum->syntax-object
name (string->symbol (concat "make-" str)) name)]
[super (and super (datum->syntax-object
super (string->symbol
(regexp-replace
<>-re (symbol->string (syntax-e super))
"\\1"))
super))])
(quasisyntax/loc stx
(begin
(define-struct #,(if super #`(#,name-sans-<> #,super) name-sans-<>)
#,slots (make-inspector))
(define #,name
(struct-type->class* #,struct:name #,make-struct '#,slots))))))
(syntax-case stx ()
[(_ name (s) slot ...) (<>-id? #'name) (doit #'name #'s #'(slot ...))]
[(_ name ( ) slot ...) (<>-id? #'name) (doit #'name #f #'(slot ...))]
[(_ name more ...) (not (<>-id? #'name))
(raise-syntax-error #f "requires a name that looks like \"<...>\""
stx #'name)]))
;;; ---------------------------------------------------------------------------
;;; Convenient macros
(defsyntax process-with-slots
(syntax-rules ()
[(_ obj () (bind ...) body ...)
(letsubst (bind ...) body ...)]
[(_ obj ((id slot) slots ...) (bind ...) body ...)
(process-with-slots
obj (slots ...) (bind ... (id (slot-ref obj slot))) body ...)]
[(_ obj (id slots ...) (bind ...) body ...)
(process-with-slots
obj (slots ...) (bind ... (id (slot-ref obj 'id))) body ...)]))
;;>> (with-slots obj (slot ...) body ...)
;;> Evaluate the body in an environment where each `slot' is defined as a
;;> symbol-macro that accesses the corresponding slot value of `obj'.
;;> Each `slot' is either an identifier `id' which makes it stand for
;;> `(slot-ref obj 'id)', or `(id slot)' which makes `id' stand for
;;> `(slot-ref obj slot)'.
(defsubst* (with-slots obj (slot ...) body0 body ...)
(process-with-slots obj (slot ...) () body0 body ...))
(defsyntax process-with-accessors
(syntax-rules ()
[(_ obj () (bind ...) body ...)
(letsubst (bind ...) body ...)]
[(_ obj ((id acc) accs ...) (bind ...) body ...)
(process-with-accessors
obj (accs ...) (bind ... (id (acc obj))) body ...)]
[(_ obj (id accs ...) (bind ...) body ...)
(process-with-accessors
obj (accs ...) (bind ... (id (id obj))) body ...)]))
;;>> (with-accessors obj (accessor ...) body ...)
;;> Evaluate the body in an environment where each `accessor' is defined
;;> as a symbol-macro that accesses `obj'. Each `accessor' is either an
;;> identifier `id' which makes it stand for `(id obj)', or
;;> `(id accessor)' which makes `id' stand for `(accessor obj);.
(defsubst* (with-accessors obj (acc ...) body0 body ...)
(process-with-accessors obj (acc ...) () body0 body ...))
;;; ---------------------------------------------------------------------------
;;; An "as" conversion operator.
;;>> (as class obj)
;;> Converts `obj' to an instance of `class'. This is a convenient
;;> generic wrapper around Scheme conversion functions (functions that
;;> look like `foo->bar'), but can be used for other classes too.
(defgeneric* as (class object))
(defmethod (as [c <class>] [x <top>])
(if (instance-of? x c)
x
(error 'as "can't convert ~e -> ~e; given: ~e." (class-of x) c x)))
;;>> (add-as-method from-class to-class op ...)
;;> Adds a method to `as' that will use the function `op' to convert
;;> instances of `from-class' to instances of `to-class'. More operators
;;> can be used which will make this use their composition. This is used
;;> to initialize `as' with the standard Scheme conversion functions.
(define* (add-as-method from to . op)
(let ([op (apply compose op)])
(add-method as (method ([c = to] [x from]) (op x)))))
;; Add Scheme primitives.
(for-each
(lambda (args)
(apply (lambda (from to . ops)
(add-as-method from to . ops)
(let ([from* (cond [(eq? from <string>) <immutable-string>]
[(eq? from <bytes>) <immutable-bytes>]
[else #f])])
(when from* (add-as-method from* to . ops))))
args))
`((,<immutable-string> ,<string> ,string-copy)
(,<string> ,<immutable-string> ,string->immutable-string)
(,<string> ,<symbol> ,string->symbol)
(,<symbol> ,<string> ,symbol->string)
(,<string> ,<keyword> ,string->keyword)
(,<keyword> ,<string> ,keyword->string)
(,<exact> ,<inexact> ,exact->inexact)
(,<inexact> ,<exact> ,inexact->exact)
(,<number> ,<string> ,number->string)
(,<string> ,<number> ,string->number)
(,<char> ,<string> ,string)
(,<char> ,<integer> ,char->integer)
(,<integer> ,<char> ,integer->char)
(,<string> ,<list> ,string->list)
(,<list> ,<string> ,list->string)
(,<vector> ,<list> ,vector->list)
(,<list> ,<vector> ,list->vector)
(,<number> ,<integer> ,inexact->exact ,round)
(,<rational> ,<integer> ,inexact->exact ,round)
(,<struct> ,<vector> ,struct->vector)
(,<string> ,<regexp> ,regexp)
(,<regexp> ,<string> ,object-name)
(,<immutable-bytes> ,<bytes> ,bytes-copy)
(,<bytes> ,<immutable-bytes> ,bytes->immutable-bytes)
(,<bytes> ,<list> ,bytes->list)
(,<list> ,<bytes> ,list->bytes)
(,<bytes> ,<byte-regexp> ,byte-regexp)
(,<byte-regexp> ,<bytes> ,object-name)
(,<string> ,<bytes> ,string->bytes/utf-8)
(,<bytes> ,<string> ,bytes->string/utf-8)
(,<string> ,<path> ,string->path)
(,<path> ,<string> ,path->string)
(,<bytes> ,<path> ,bytes->path)
(,<path> ,<bytes> ,path->bytes)
;; Some weird combinations
(,<symbol> ,<number> ,string->number ,symbol->string)
(,<number> ,<symbol> ,string->symbol ,number->string)
(,<struct> ,<list> ,vector->list ,struct->vector)
(,<bytes> ,<number> ,string->number ,bytes->string/utf-8)
(,<number> ,<bytes> ,string->bytes/utf-8 ,number->string)
))
;;; ---------------------------------------------------------------------------
;;; Recursive equality.
;;>> (equals? x y)
;;> A generic that compares `x' and `y'. It has an around method that
;;> will stop and return `#t' if the two arguments are `equal?'. It is
;;> intended for user-defined comparison between any instances.
(defgeneric* equals? (x y))
(defaroundmethod (equals? [x <top>] [y <top>])
;; check this first in all cases
(or (equal? x y) (call-next-method)))
(defmethod (equals? [x <top>] [y <top>])
;; the default is false - the around method returns #t if they're equal?
#f)
;;>> (add-equals?-method class pred?)
;;> Adds a method to `equals?' that will use the given `pred?' predicate
;;> to compare instances of `class'.
(define* (add-equals?-method class pred?)
(add-method equals? (method ([x class] [y class]) (pred? x y))))
;;>> (class+slots-equals? x y)
;;> This is a predicate function (not a generic function) that will
;;> succeed if `x' and `y' are instances of the same class, and all of
;;> their corresponding slots are `equals?'. This is useful as a quick
;;> default for comparing simple classes (but be careful and avoid
;;> circularity problems).
(define* (class+slots-equals? x y)
(let ([xc (class-of x)] [yc (class-of y)])
(and (eq? xc yc)
(every (lambda (s)
(equals? (slot-ref x (car s)) (slot-ref y (car s))))
(class-slots xc)))))
;;>> (make-equals?-compare-class+slots class)
;;> Make `class' use `class+slots-equals?' for comparison with `equals?'.
(define* (make-equals?-compare-class+slots class)
(add-equals?-method class class+slots-equals?))
;;; ---------------------------------------------------------------------------
;;; Generic addition for multiple types.
;;>> (add x ...)
;;> A generic addition operation, initialized for some Scheme types
;;> (numbers (+), lists (append), strings (string-append), symbols
;;> (symbol-append), procedures (compose), and vectors). It dispatches
;;> only on the first argument.
(defgeneric* add (x . more))
;;>> (add-add-method class op)
;;> Add a method to `add' that will use `op' to add objects of class
;;> `class'.
(define* (add-add-method c op)
;; dispatch on first argument
(add-method add (method ([x c] . more) (apply op x more))))
(add-add-method <number> +)
(add-add-method <list> append)
(add-add-method <string> string-append)
(add-add-method <symbol> symbol-append)
(add-add-method <procedure> compose)
(defmethod (add [v <vector>] . more)
;; long but better than vectors->lists->append->vectors
(let* ([len (apply + (map vector-length (cons v more)))]
[vec (make-vector len)])
(let loop ([i 0] [v v] [vs more])
(dotimes [j (vector-length v)]
(set! (vector-ref vec (+ i j)) (vector-ref v j)))
(unless (null? vs) (loop (+ i (vector-length v)) (car vs) (cdr vs))))
vec))
;;; ---------------------------------------------------------------------------
;;; Generic len for multiple types.
;;>> (len x)
;;> A generic length operation, initialized for some Scheme types (lists
;;> (length), strings (string-length), vectors (vector-length)).
(defgeneric* len (x))
;;>> (add-len-method class op)
;;> Add a method to `len' that will use `op' to measure objects length for
;;> instances of `class'.
(define* (add-len-method c op)
(add-method len (method ([x c]) (op x))))
(add-len-method <list> length)
(add-len-method <string> string-length)
(add-len-method <vector> vector-length)
;;; ---------------------------------------------------------------------------
;;; Generic ref for multiple types.
;;>> (ref x indexes...)
;;> A generic reference operation, initialized for some Scheme types and
;;> instances. Methods are predefined for lists, vectors, strings,
;;> objects, hash-tables, boxes, promises, parameters, and namespaces.
(defgeneric* ref (x . indexes))
;;>> (add-ref-method class op)
;;> Add a method to `ref' that will use `op' to reference objects of class
;;> `class'.
(define* (add-ref-method c op)
(add-method ref (method ([x c] . indexes) (op x . indexes))))
(add-ref-method <list> list-ref)
(add-ref-method <vector> vector-ref)
(add-ref-method <string> string-ref)
(add-ref-method <object> slot-ref)
(add-ref-method <hash-table> hash-table-get)
(add-ref-method <box> unbox)
(add-ref-method <promise> force)
(defmethod (ref [p <parameter>] . _) (p))
(defmethod (ref [n <namespace>] . args)
(parameterize ([current-namespace n])
(apply namespace-variable-value args)))
;;; ---------------------------------------------------------------------------
;;; Generic set-ref! for multiple types.
;;>> (put! x v indexes)
;;> A generic setter operation, initialized for some Scheme types and
;;> instances. The new value comes first so it is possible to add methods
;;> to specialize on it. Methods are predefined for lists, vectors,
;;> strings, objects, hash-tables, boxes, parameters, and namespaces.
(defgeneric* put! (x v . indexes))
;;>> (add-put!-method class op)
;;> Add a method to `put!' that will use `op' to change objects of class
;;> `class'.
(define* (add-put!-method c op)
(add-method put! (method ([x c] v . indexes) (op x v . indexes))))
;;>> (set-ref! x indexes... v)
;;> This syntax will just translate to `(put! x v indexes...)'. It makes
;;> it possible to make `(set! (ref ...) ...)' work with `put!'.
(defsyntax* (set-ref! stx)
(syntax-case stx ()
[(_ x i ...)
(let* ([ris (reverse (syntax->list #'(i ...)))]
[idxs (reverse (cdr ris))]
[val (car ris)])
(quasisyntax/loc stx
(put! x #,val #,@(datum->syntax-object #'(i ...) idxs #'(i ...)))))]))
(define (put!-arg typename args)
(if (or (null? args) (pair? (cdr args)))
(if (null? args)
(error 'put! "got no index for a ~a argument" typename)
(error 'put! "got more than one index for a ~a argument ~e"
typename args))
(car args)))
#|
(defmethod (put! [l <list>] x . i_)
(list-set! l (put!-arg '<list> i_) x))
|#
(defmethod (put! [v <vector>] x . i_)
(vector-set! v (put!-arg '<vector> i_) x))
(defmethod (put! [s <string>] [c <char>] . i_)
(string-set! s (put!-arg '<string> i_) c))
(defmethod (put! [o <object>] x . s_)
(slot-set! o (put!-arg '<object> s_) x))
(defmethod (put! [h <hash-table>] x . k_)
(if (null? k_)
(error 'put! "got no index for a <hash-table> argument")
(hash-table-put! h (car k_) x)))
(add-put!-method <box> set-unbox!)
(defmethod (put! [p <parameter>] x . _)
(if (null? _)
(p x)
(error 'put! "got extraneous indexes for a <parameter> argument")))
(defmethod (put! [n <namespace>] x . v_)
(if (null? v_)
(error 'put! "got no index for a <namespace> argument")
(parameterize ([current-namespace n])
(apply namespace-set-variable-value! (car v_) x
(if (null? (cdr v_)) '() (list (cadr v_)))))))
;;; ---------------------------------------------------------------------------
;;>>... Generic-based printing mechanism
;;>> *print-level*
;;>> *print-length*
;;> These parameters control how many levels deep a nested data object
;;> will print, and how many elements are printed at each level. `#f'
;;> means no limit. The effect is similar to the corresponding globals in
;;> Lisp. Only affects printing of container objects (like lists, vectors
;;> and structures).
(define* *print-level* (make-parameter 6))
(define* *print-length* (make-parameter 20))
;; grab the builtin write/display handlers
(define-values (mz:write mz:display)
(let ([p (open-output-bytes)])
(values (port-write-handler p) (port-display-handler p))))
;;>> (print-object obj esc? port)
;;> Prints `obj' on `port' using the above parameters -- the effect of
;;> `esc?' being true is to use a `write'-like printout rather than a
;;> `display'-like printout when it is false. Primitive Scheme values are
;;> printed normally, Swindle objects are printed using the un-`read'-able
;;> "#<...>" sequence unless a method that handles them is defined. For
;;> this printout, objects with a `name' slot are printed using that name
;;> (and their class's name).
;;>
;;> Warning: this is the method used for user-interaction output, errors
;;> etc. Make sure you only define reliable methods for it.
(defgeneric* print-object (object esc? port))
(defmethod (print-object o esc? port)
(mz:display "#" port)
(mz:display (class-name (class-of o)) port))
(defmethod (print-object [o <builtin>] esc? port)
((if esc? mz:write mz:display) o port))
(define printer:too-deep "#?#")
(define printer:too-long "...")
;; use a single implementation for both pairs and mpairs, punctuation
;; shorthands for pairs only
(defmethod (print-object [o <pair>] esc? port)
(let ([punct (and (pair? (cdr o)) (null? (cddr o))
(assq (car o)
'([quote "'"] [quasiquote "`"] [unquote ","]
[unquote-splicing ",@"]
[syntax "#'"] [quasisyntax "#`"] [unsyntax "#,"]
[unsyntax-splicing "#,@"])))])
(if punct
(begin (mz:display (cadr punct) port) (print-object (cadr o) esc? port))
(print-pair o esc? port "(" ")" pair? car cdr))))
(defmethod (print-object [o <mutable-pair>] esc? port)
(print-pair o esc? port "{" "}" mpair? mcar mcdr))
(define (print-pair p esc? port open close pair? car cdr)
(define level (*print-level*))
(if (eq? level 0)
(mz:display printer:too-deep port)
(begin
(mz:display open port)
(if (eq? (*print-length*) 0)
(mz:display printer:too-long port)
(parameterize ([*print-level* (and level (sub1 level))])
(print-object (car p) esc? port)
(do ([p (cdr p) (if (pair? p) (cdr p) '())]
[n (sub1 (or (*print-length*) 0)) (sub1 n)])
[(or (null? p)
(and (zero? n)
(begin (mz:display " " port)
(mz:display printer:too-long port)
#t)))]
(if (pair? p)
(begin (mz:display " " port) (print-object (car p) esc? port))
(begin (mz:display " . " port) (print-object p esc? port))))))
(mz:display close port))))
(defmethod (print-object [o <vector>] esc? port)
(define level (*print-level*))
(cond [(eq? level 0) (mz:display printer:too-deep port)]
[(zero? (vector-length o)) (mz:display "#()" port)]
[else (mz:display "#(" port)
(if (eq? (*print-length*) 0)
(mz:display printer:too-long port)
(parameterize ([*print-level* (and level (sub1 level))])
(print-object (vector-ref o 0) esc? port)
(let ([len (if (*print-length*)
(min (vector-length o) (*print-length*))
(vector-length o))])
(do ([i 1 (add1 i)]) [(>= i len)]
(mz:display " " port)
(print-object (vector-ref o i) esc? port))
(when (< len (vector-length o))
(mz:display " " port)
(mz:display printer:too-long port)))))
(mz:display ")" port)]))
;;>> (name-sans-<> name)
;;> Given a string or symbol for name, return a string where the outermost
;;> set of angle brackets have been stripped if they are present. This is
;;> handy if you are writing your own print-object methods.
(define <>-re #rx"^<(.*)>$")
(define* (name-sans-<> name)
(cond [(string? name) (regexp-replace <>-re name "\\1")]
[(symbol? name) (regexp-replace <>-re (symbol->string name) "\\1")]
[(eq? ??? name) "???"]
[else name]))
;; Take care of all <object>s with a `name' slot
(defmethod (print-object (o <object>) esc? port)
(let* ([c (class-of o)]
[cc (class-of c)]
[(name x) (name-sans-<> (slot-ref x 'name))])
(if (and (assq 'name (class-slots c)) (assq 'name (class-slots cc)))
(begin (mz:display "#<" port)
(mz:display (name c) port)
(mz:display ":" port)
(mz:display (name o) port)
(mz:display ">" port))
(call-next-method))))
;;>> (print-object-with-slots obj esc? port)
;;> This is a printer function that can be used for classes where the
;;> desired output shows slot values. Note that it is a simple function,
;;> which should be embedded in a method that is to be added to
;;> `print-object'.
(define* (print-object-with-slots o esc? port)
(define level (*print-level*))
(if (eq? level 0)
(mz:display printer:too-deep port)
(let ([class (class-of o)])
(mz:display "#<" port)
(mz:display (name-sans-<> (class-name class)) port)
(mz:display ":" port)
(parameterize ([*print-level* (and level (sub1 level))])
(do ([s (class-slots class) (cdr s)]
[n (or (*print-length*) -1) (sub1 n)])
[(or (null? s)
(and (zero? n)
(begin (mz:display " " port)
(mz:display printer:too-long port))))]
(let ([val (slot-ref o (caar s))])
(if (eq? ??? val)
(set! n (add1 n))
(begin (mz:display " " port)
(mz:display (caar s) port)
(mz:display "=" port)
(print-object val esc? port))))))
(mz:display ">" port))))
;; Add a hook to make <class> so it will initialize a printer if given
(defmethod :after (initialize [c <class>] initargs)
(let ([printer (or (getarg initargs :printer)
(and (getarg initargs :auto) #t))])
(when printer
(when (eq? #t printer) (set! printer print-object-with-slots))
(add-method print-object
(method ([x c] esc? port) (printer x esc? port))))))
;;>> (display-object obj [port])
;;>> (write-object obj [port])
;;> Used to display and write an object using `print-object'. Used as the
;;> corresponding output handler functions.
(define* (display-object obj &optional [port (current-output-port)])
(print-object obj #f port))
(define* (write-object obj &optional [port (current-output-port)])
(print-object obj #t port))
;;>> (object->string obj [esc? = #t])
;;> Convert the given `obj' to a string using its printed form.
(define* (object->string obj &optional [esc? #t])
(with-output-to-string
(thunk (print-object obj esc? (current-output-port)))))
;; Hack these to echo
(*echo-display-handler* display-object)
(*echo-write-handler* write-object)
;;>> (install-swindle-printer)
;;> In Racket, output is configurable on a per-port basis. Use this
;;> function to install Swindle's `display-object' and `write-object' on
;;> the current output and error ports whenever they are changed
;;> (`swindle' does that on startup). This makes it possible to see
;;> Swindle values in errors, when using `printf' etc.
(define* (install-swindle-printer)
(global-port-print-handler write-object)
(port-display-handler (current-output-port) display-object)
(port-display-handler (current-error-port) display-object)
(port-write-handler (current-output-port) write-object)
(port-write-handler (current-error-port) write-object))
;;; ---------------------------------------------------------------------------
;;>>... Simple matching
;;>> match-failure
;;> The result for a matcher function application that failed. You can
;;> return this value from a matcher function in a <matcher> so the next
;;> matching one will get invoked.
(define* match-failure "failure")
;;>> (matching? matcher value)
;;> The `matcher' argument is a value of any type, which is matched
;;> against the given `value'. For most values matching means being equal
;;> (using `equals?') to, but there are some exceptions: class objects
;;> are tested with `instance-of?', functions are used as predicates,
;;> literals are used with equals?, pairs are compared recursively and
;;> regexps are used with regexp-match.
(define* (matching? matcher value)
(cond [(class? matcher) (instance-of? value matcher)]
[(function? matcher) (matcher value)]
[(pair? matcher) (and (pair? value)
(matching? (car matcher) (car value))
(matching? (cdr matcher) (cdr value)))]
;; handle regexps - the code below relies on returning this result
[(regexp? matcher) (and (string? value)
(regexp-match matcher value))]
[else (equals? matcher value)]))
;;>> (let/match pattern value body ...)
;;> Match the `value' against the given `pattern', and evaluate the body
;;> on a success. It is an error for the match to fail. Variables that
;;> get bound in the matching process can be used in the body.
;;>
;;> The pattern specification has a complex syntax as follows:
;;> - simple values (not symbols) are compared with `matching?' above;
;;> - :x keywords are also used as literal values;
;;> - * is a wildcard that always succeeds;
;;> - ??? matches the `???' value;
;;> - (lambda ...) use the resulting closure value (for predicates);
;;> - (quote ...) use the contents as a simple value;
;;> - (quasiquote ...) same;
;;> - (V := P) assign the variable V to the value matched by P;
;;> - V for a variable name V that was not part of the
;;> pattern so far, this matches anything and binds V
;;> to the value -- the same as (V := *);
;;> - (! E) evaluate E, use the result as a literal value;
;;> - (!! E) evaluate E, continue matching only if it is true;
;;> - (V when E) same as (and V (!! E));
;;> - (and P ...) combine the matchers with and, can bind any
;;> variables in all parts;
;;> - (or P ...) combine the matchers with or, bound variables are
;;> only from the successful form;
;;> - (if A B C) same as (or (and A B) C);
;;> - (F => P) continue matching P with (F x) (where is x is the
;;> current matched object);
;;> - (V :: P ...) same as (and (! V) P...), useful for class forms
;;> like (<class> :: (foo => f) ...);
;;> - (make <class> ...) if the value is an instance of <class>, then
;;> continue by the `...' part which is a list of
;;> slot names and patterns -- a slot name is either
;;> :foo or 'foo, and the pattern will be matched
;;> against the contents of that slot in the original
;;> <class> instance;
;;> - ??? matches the unspecified value (`???' in tiny-clos)
;;> - (regexp R) convert R to a regexp and use that to match
;;> strings;
;;> - (regexp R P ...) like the above, but continue matching the result
;;> with `(P ...)' so it can bind variables to the
;;> result (something like `(regexp "a(x?)b" x y)'
;;> will bind `x' to the `regexp-match' result, and
;;> `y' to a match of the sub-regexp part);
;;> - (...) other lists - match the elements of a list
;;> recursively (can use a dot suffix for a "rest"
;;> arguments).
;;>
;;> Note that variable names match anything and bind the name to the result,
;;> except when the name was already seen -- where the previously bound
;;> value is used, allowing patterns where some parts should match the same
;;> value. (A name was `seen' if it was previously used in the pattern
;;> except on different branches of an `or' pattern.)
(defsyntax (make-matcher-form stx)
(define (re r)
;; Note: this inserts the _literal_ regexp in the code if it is a string.
(cond [(regexp? (syntax-e r)) r]
[(string? (syntax-e r)) (regexp (syntax-e r))]
[else #`(regexp #,r)]))
(define (loop x pattern vs body)
;; body always a delayed function that expects bindings
(syntax-case pattern (* ??? := ! !! when and or if => ::
make regexp quote quasiquote lambda)
[* ; wildcard
(body vs)]
[??? ; matches ???
#`(if (matching? ??? #,x) #,(body vs) match-failure)]
[(v := p) ; assign the variable V to the value matched by P
#`(let ([v #,x]) #,(loop #'v #'p (cons #'v vs) body))]
[v ; (V := *) if V is a symbol that was not already used
(and (identifier? #'v) (not (syntax-keyword? #'v))
(not (ormap (lambda (u) (bound-identifier=? #'v u)) vs)))
(loop x #'(v := *) vs body)]
[(! e) ; evaluate E and use it as a simple value
#`(if (matching? e x) #,(body vs) match-failure)]
[(!! e) ; evaluate E and succeed only if it is true
#`(if e #,(body vs) match-failure)]
[(p when e) ; => (and P (!! E))
#`(_ x (and p (!! e)) #,(body vs))]
;; and/or
[(and) (body vs)]
[(or) #'match-failure]
[(and p) (loop x #'p vs body)]
[(or p) (loop x #'p vs body)]
[(and p1 p2 ...) (loop x #'p1 vs
(lambda (vs) (loop x #'(and p2 ...) vs body)))]
[(or p1 p2 ...) #`(let ([tmp #,(loop x #'p1 vs body)])
(if (eq? tmp match-failure)
#,(loop x #'(or p2 ...) vs body)
tmp))]
[(if a b c) ; => (or (and A B) C)
(loop x #'(or (and a b) c) vs body)]
[(f => p) ; continue matching P with (F x)
#`(let ([v (f #,x)]) #,(loop #'v #'p vs body))]
[(v :: . p) ; => (and (! V) P ...), eg (<foo> :: (foo => f) ...)
(loop x #'(and (! v) . p) vs body)]
[(make class initarg+vals ...)
;; (make <class> :slotname p ...) - match on slots of the given class
#`(let ([obj #,x])
(if (instance-of? obj class)
#,(let loop1 ([av #'(initarg+vals ...)] [vs vs])
(syntax-case av (quote)
[(key p more ...) (syntax-keyword? #'key)
(let* ([s (symbol->string (syntax-e #'key))]
[s (datum->syntax-object
#'key
(string->symbol
(substring s 1 (string-length s)))
#'key)])
(loop #`(slot-ref obj '#,s) #'p vs
(lambda (vs) (loop1 #'(more ...) vs))))]
[('key p more ...)
(loop #'(slot-ref obj 'key) #'p vs
(lambda (vs) (loop1 #'(more ...) vs)))]
[() (body vs)]))
match-failure))]
[(regexp r) ; use R as a regexp (matching? handles it)
#`(if (matching? #,(re #'r) #,x) #,(body vs) match-failure)]
[(regexp r . p) ; => like the above, but match P... on result
#`(let ([m (matching? #,(re #'r) #,x)])
(if m #,(loop #'m #'p vs body) match-failure))]
;; literal lists
['v #`(if (matching? 'v #,x) #,(body vs) match-failure)]
[`v #`(if (matching? `v #,x) #,(body vs) match-failure)]
[(lambda as b ...)
#`(if (matching? (lambda as b ...) #,x) #,(body vs) match-failure)]
[(a . b) ; simple lists
#`(if (pair? #,x)
(let ([hd (car #,x)] [tl (cdr #,x)])
#,(loop #'hd #'a vs (lambda (vs) (loop #'tl #'b vs body))))
match-failure)]
;; other literals (null, keywords, non-symbols)
[() #`(if (null? #,x) #,(body vs) match-failure)]
[v #`(if (matching? v #,x) #,(body vs) match-failure)]))
(syntax-case stx ()
[(_ x pattern body) (loop #'x #'pattern '() (lambda (vs) #'body))]))
(defsubst* (let/match pattern value body ...)
(let* ([v value] [r (make-matcher-form v pattern (begin body ...))])
(if (eq? r match-failure)
(error 'let/match "value did not match pattern: ~e" v)
r)))
;;>> (matcher pattern body ...)
;;> This creates a matcher function, using the given `pattern' which will
;;> be matched with the list of given arguments on usage. If the given
;;> arguments fail to match on an application, an error will be raised.
(defsubst* (matcher pattern body ...)
(lambda args
(let ([r (make-matcher-form args pattern (begin body ...))])
(if (eq? r match-failure)
(error 'matcher "application values did not match pattern: ~e" v)
r))))
;; Matching similar to `cond'
;;>> (match x (pattern expr ...) ...)
;;> This is similar to a `cond' statement but each clause starts with a
;;> pattern, possibly binding variables for its body. It also handles
;;> `else' as a last clause.
(defsyntax match-internal
(syntax-rules (else)
[(_ x) (void)]
[(_ x (else body0 body ...)) (begin body0 body ...)]
[(_ x (pattern body0 body ...) clause ...)
(let ([m (make-matcher-form x pattern (begin body0 body ...))])
(if (eq? m match-failure) (match x clause ...) m))]))
(defsubst* (match x clause ...)
(let ([v x]) (match-internal v clause ...)))
;;>> <matcher>
;;> A class similar to a generic function, that holds matcher functions
;;> such as the ones created by the `matcher' macro. It has three slots:
;;> `name', `default' (either a default value or a function that is
;;> applied to the arguments to produce the default value), and `matchers'
;;> (a list of matcher functions).
(defentityclass* <matcher> (<generic>)
(name :initarg :name :initvalue '-anonymous-)
(default :initarg :default :initvalue #f)
(matchers :initarg :matchers :initvalue '()))
;; Set the entity's proc
(defmethod (initialize [matcher <matcher>] initargs)
(call-next-method)
(set-instance-proc!
matcher
(lambda args
(let loop ([matchers (slot-ref matcher 'matchers)])
(if (null? matchers)
(let ([default (slot-ref matcher 'default)])
(if (procedure? default)
(default . args)
(or default
(error (slot-ref matcher 'name) "no match found."))))
(let ([r (apply (car matchers) args)])
(if (eq? r match-failure)
(loop (cdr matchers))
r)))))))
;;; Add a matcher - normally at the end, with add-matcher0 at the beginning
(define (add-matcher matcher m)
(slot-set! matcher 'matchers
(append (slot-ref matcher 'matchers) (list m))))
(define (add-matcher0 matcher m)
(slot-set! matcher 'matchers
(cons m (slot-ref matcher 'matchers))))
(defsyntax (defmatcher-internal stx)
(syntax-case stx ()
[(_ adder name args body ...)
(with-syntax ([matcher-make (syntax/loc stx (matcher args body ...))])
(if (or
;; not enabled
(not (syntax-e
((syntax-local-value #'-defmethod-create-generics-))))
;; defined symbol or second module binding
(identifier-binding #'name)
;; local definition -- don't know which is first => no define
(eq? 'lexical (syntax-local-context)))
(syntax/loc stx (adder name matcher-make))
;; top-level or first module binding
(syntax/loc stx
(define name ; trick: try using exising generic
(let ([m (or (no-errors name) (make <matcher> :name 'name))])
(adder m matcher-make)
m)))))]))
;;>> (defmatcher (name pattern) body ...)
;;>> (defmatcher0 (name pattern) body ...)
;;> These macros define a matcher (if not defined yet), create a matcher
;;> function and add it to the matcher (either at the end (defmatcher) or
;;> at the beginning (defmatcher0)).
(defsyntax* (defmatcher stx)
(syntax-case stx ()
[(_ (name . args) body0 body ...) (identifier? #'name)
#'(defmatcher-internal add-matcher name args body0 body ...)]
[(_ name args body0 body ...) (identifier? #'name)
#'(defmatcher-internal add-matcher name args body0 body ...)]))
(defsyntax* (defmatcher0 stx)
(syntax-case stx ()
[(_ (name . args) body0 body ...) (identifier? #'name)
#'(defmatcher-internal add-matcher0 name args body0 body ...)]
[(_ name args body0 body ...) (identifier? #'name)
#'(defmatcher-internal add-matcher0 name args body0 body ...)]))
;;; ---------------------------------------------------------------------------
;;>>... An amb macro
;;> This is added just because it is too much fun to miss. To learn about
;;> `amb', look for it in the Help Desk, in the "Teach Yourself Scheme in
;;> Fixnum Days" on-line manual.
(define amb-fail (make-parameter #f))
(define (initialize-amb-fail)
(amb-fail (thunk (error 'amb "tree exhausted"))))
(initialize-amb-fail)
;;>> (amb expr ...)
;;> Execute forms in a nondeterministic way: each form is tried in
;;> sequence, and if one fails then evaluation continues with the next.
;;> `(amb)' fails immediately.
(defsubst* (amb expr ...)
(let ([prev-amb-fail (amb-fail)])
(let/ec sk
(let/cc fk
(amb-fail (thunk (amb-fail prev-amb-fail) (fk 'fail)))
(sk expr)) ...
(prev-amb-fail))))
;;>> (amb-assert cond)
;;> Asserts that `cond' is true, fails otherwise.
(define* (amb-assert bool) (unless bool ((amb-fail))))
;;>> (amb-collect expr)
;;> Evaluate expr, using amb-fail repeatedly until all options are
;;> exhausted and returns the list of all results.
(defsubst* (amb-collect e)
(let ([prev-amb-fail (amb-fail)]
[results '()])
(when (let/cc k
(amb-fail (thunk (k #f)))
(let ([v e]) (push! v results) (k #t)))
((amb-fail)))
(amb-fail prev-amb-fail)
(reverse results)))
;;; ---------------------------------------------------------------------------
;;>>... Very basic UI - works also in console mode
;;> The following defines some hacked UI functions that works using GRacket
;;> GUI if it is available, or the standard error and input ports otherwise.
;;> The check is done by looking for a GUI global binding.
;;>> *dialog-title*
;;> This parameter defines the title used for the hacked UI interface.
(define* *dialog-title* (make-parameter "Swindle Message"))
;;>> (message fmt-string arg ...)
;;> Like `printf' with a prefix title, or using a message dialog box.
(define* (message str . args)
(let ([msg (format str . args)])
(if (namespace-defined? 'message-box)
((namespace-variable-value 'message-box) (*dialog-title*) msg)
(echo :>e :s- "<<<" (*dialog-title*) ": " msg ">>>")))
(void))
(define (first-non-ws-char str idx)
(and (< idx (string-length str))
(let ([c (string-ref str idx)])
(if (memq c '(#\space #\tab #\newline))
(first-non-ws-char str (add1 idx))
c))))
(define (ui-question str args prompt positive-result msg-style
positive-char negative-char)
(let ([msg (apply format str args)])
(if (namespace-defined? 'message-box)
(eq? ((namespace-variable-value 'message-box)
(*dialog-title*) msg #f msg-style)
positive-result)
(begin (echo :>e :n- :s- (*dialog-title*) ">>> " msg " " prompt " ")
(let loop ()
(let ([inp (first-non-ws-char (read-line) 0)])
(cond [(char-ci=? inp positive-char) #t]
[(char-ci=? inp negative-char) #f]
[else (loop)])))))))
;;>> (ok/cancel? fmt-string arg ...)
;;>> (yes/no? fmt-string arg ...)
;;> These functions are similar to `message', but they are used to ask an
;;> "ok/cancel" or a "yes/no" question. They return a boolean.
(define* (ok/cancel? str . args)
(ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c))
(define* (yes/no? str . args)
(ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n))

48
pkgs/swindle/info.rkt
View File

@ -1,48 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
#lang info
(define collection "swindle")
(define mzscheme-launcher-names '("swindle"))
(define mzscheme-launcher-flags '(("-li" "swindle")))
(define scribblings '(("swindle.scrbl" ())))
;; This simple interface is not enough, use tool.rkt instead
;; (define drscheme-language-modules
;; '(("swindle.rkt" "swindle")
;; ("turbo.rkt" "swindle")
;; ("html.rkt" "swindle")))
;; (define drscheme-language-positions
;; '(("Swindle" "Full Swindle")
;; ("Swindle" "Swindle without CLOS")
;; ("Swindle" "HTML Swindle")))
;; (define drscheme-language-numbers
;; '((-900 0) (-900 1) (-900 2)))
;; (define drscheme-language-one-line-summaries
;; '("Scheme with Full Swindle extensions"
;; "Scheme with Swindle without the object system"
;; "Scheme with the HTML and Swindle extensions"))
;; (define drscheme-language-urls
;; '("http://www.barzilay.org/Swindle/"
;; "http://www.barzilay.org/Swindle/"
;; "http://www.barzilay.org/Swindle/"))
(define tools '(("tool.rkt")))
(define tool-names '("Swindle"))
(define tool-icons '(("swindle-icon.png" "swindle")))
(define tool-urls '("http://www.barzilay.org/Swindle/"))
(define deps '("scheme-lib"
"base"
"compatibility-lib"
"drracket-plugin-lib"
"gui-lib"
"net-lib"
"string-constants-lib"))
(define build-deps '("compatibility-doc"
"racket-doc"
"scribble-lib"))
(define pkg-desc "The implementation of the Swindle language")
(define pkg-authors '(eli))

2
pkgs/swindle/lang/reader.rkt
View File

@ -1,2 +0,0 @@
#lang s-exp syntax/module-reader
swindle

17
pkgs/swindle/main.rkt
View File

@ -1,17 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module combines all modules to form the Swindle language module.
;;>
;;> Note that it does not re-define `#%module-begin', so the language used
;;> for transformers is still the one defined by `turbo'.
#lang s-exp swindle/turbo
(require swindle/clos swindle/extra)
(provide (all-from swindle/turbo)
(all-from swindle/clos)
(all-from swindle/extra))
(current-prompt-read
(let ([old-prompt-read (current-prompt-read)])
(lambda () (display "=") (flush-output) (old-prompt-read))))
(install-swindle-printer)

1904
pkgs/swindle/misc.rkt
View File

File diff suppressed because it is too large Load Diff

265
pkgs/swindle/patterns.rkt
View File

@ -1,265 +0,0 @@
#lang mzscheme
(provide (all-from-except mzscheme
define-values
define
let-values
let*-values
letrec-values
let
let*
letrec
set!
set!-values
lambda))
(provide (rename define-values~ define-values)
(rename define~ define)
(rename let-values~ let-values)
(rename let*-values~ let*-values)
(rename letrec-values~ letrec-values)
(rename let~ let)
(rename let*~ let*)
(rename letrec~ letrec)
(rename set!~ set!)
(rename set!-values~ set!-values)
(rename lambda~ lambda))
(define-syntaxes (define-values~
define~
let-values~
let*-values~
letrec-values~
let~
let*~
letrec~
set!~
set!-values~
lambda~)
(let ()
(define (id->handlers id)
(and (identifier? id)
(syntax-local-value
(datum->syntax-object id
(string->symbol
(string-append "extended-arg-keyword:"
(symbol->string
(syntax-e id))))
id)
(lambda () #f))))
(define (flatten-extended-bindings/values stxs expr)
(define temps (generate-temporaries stxs))
(define (remove-false-2nd l)
(let loop ([l l] [r '()])
(if (null? l)
(reverse r)
(loop (cdr l) (if (cadar l) (cons (car l) r) r)))))
(let loop (;; tail: listof (cons extended-id, assigned-temp)
[tail (map cons (syntax->list stxs) temps)]
;; r: listof (list extended-ids new-temps convert-expr)
;; or (list extended-id same-temp #f)
[r '()]
;; #f if non-id scanned, otherwise #t or 'first on first pass
[simple? 'first]
;; vbinds: listof listof listof (vars expr)
[vbinds (list (list (list temps expr)))])
(if (null? tail)
(let ([r (reverse r)])
(if simple?
(if (eq? simple? 'first)
(values stxs expr)
(values (datum->syntax-object stxs (map car r) stxs)
(let loop ([vbs (reverse vbinds)])
(if (null? vbs)
(if (and (pair? r) (null? (cdr r)))
(quasisyntax/loc stxs #,(cadar r))
(quasisyntax/loc stxs (values #,@(map cadr r))))
(quasisyntax/loc stxs
(let-values #,(remove-false-2nd (car vbs))
#,(loop (cdr vbs))))))))
;; saw non-identifiers, so start another iteration
(loop (apply append (map (lambda (x)
(if (caddr x)
(map cons (car x) (cadr x))
(list (cons (car x) (cadr x)))))
r))
'() #t (cons (map cdr r) vbinds))))
(syntax-case (caar tail) ()
[var (identifier? #'var)
(loop (cdr tail) (cons (list (caar tail) (cdar tail) #f) r)
simple? vbinds)]
[(id . xs) (identifier? #'id)
(cond
[(id->handlers #'id) =>
(lambda (handlers)
(let ([bindings (syntax->list ((car handlers) #'xs))]
[new-expr ((cadr handlers) (cdar tail) #'xs)])
(unless (list? bindings)
(error 'extended-binding
"`~s->bindings' returned a non-list value: ~s"
(syntax-e #'id) bindings))
(loop (cdr tail)
(cons (list bindings (generate-temporaries bindings)
new-expr)
r)
#f vbinds)))]
[else (raise-syntax-error
'extended-binding
"got a form which is not an extended binding"
(caar tail) #'id)])]
[_ (raise-syntax-error
'extended-binding "bad binding" (caar tail))]))))
(define (_define-values stx)
(syntax-case stx ()
[(_ (var ...) expr)
(let-values ([(bindings expr)
(flatten-extended-bindings/values #'(var ...) #'expr)])
(quasisyntax/loc stx (define-values #,bindings #,expr)))]))
(define (_define stx)
(syntax-case stx (values)
[(_ (values x ...) expr)
(syntax/loc stx (define-values~ (x ...) expr))]
[(_ (id . xs) expr) (id->handlers #'id)
(syntax/loc stx (define-values~ ((id . xs)) expr))]
[(_ (id . xs) body0 body ...)
(syntax/loc stx (define-values~ (id) (lambda~ xs body0 body ...)))]
[(_ x expr)
(syntax/loc stx (define-values~ (x) expr))]))
(define (make-let-values let-form)
(lambda (stx)
(syntax-case stx ()
[(_ (binding ...) body0 body ...)
(quasisyntax/loc stx
(#,let-form
#,(map (lambda (binding)
(syntax-case binding ()
[((var ...) expr)
(let-values ([(bindings expr)
(flatten-extended-bindings/values
#'(var ...) #'expr)])
(quasisyntax/loc binding
(#,bindings #,expr)))]))
(syntax->list #'(binding ...)))
body0 body ...))])))
(define _let-values (make-let-values #'let-values))
(define _let*-values (make-let-values #'let*-values))
(define _letrec-values (make-let-values #'letrec-values))
(define (make-let let-form label?)
(lambda (stx)
(syntax-case stx ()
[(_ label ((var val) ...) body0 body ...)
(and label? (identifier? #'label))
(quasisyntax/loc stx
((letrec~ ([label (lambda~ (var ...) body0 body ...)]) label)
val ...))]
[(_ (binding ...) body0 body ...)
(quasisyntax/loc stx
(#,let-form #,(map (lambda (binding)
(syntax-case binding (values)
[((values x ...) expr) #'((x ...) expr)]
[(x expr) #'((x) expr)]))
(syntax->list #'(binding ...)))
body0 body ...))])))
(define _let (make-let #'let-values~ #t))
(define _let* (make-let #'let*-values~ #f))
(define _letrec (make-let #'letrec-values~ #f))
(define (_set! stx)
(syntax-case stx (values)
[(_ (values x ...) expr) (syntax/loc stx (set!-values~ (x ...) expr))]
[(_ x expr) (syntax/loc stx (set!-values~ (x) expr))]))
(define (_set!-values stx)
(syntax-case stx ()
[(_ (var ...) expr)
(let-values ([(bindings expr)
(flatten-extended-bindings/values #'(var ...) #'expr)])
(quasisyntax/loc stx
(set!-values #,bindings #,expr)))]))
(define (_lambda stx)
(syntax-case stx ()
[(_ vars body0 body ...)
(let loop ([vs #'vars] [newvars '()] [specials '()] [restarg '()])
(syntax-case vs ()
[((id xs ...) . rest) (identifier? #'id)
(let ([newvar (car (generate-temporaries #'(id)))])
(loop #'rest (cons newvar newvars)
(cons (list #'(id xs ...) newvar) specials)
restarg))]
[(id . rest) (identifier? #'id)
(loop #'rest (cons #'id newvars) specials restarg)]
[id (identifier? #'id)
(loop #'() newvars specials #'id)]
[() (let ([args (datum->syntax-object
#'vars (append (reverse newvars) restarg)
#'vars)])
(if (null? specials)
(quasisyntax/loc stx (lambda #,args body0 body ...))
(quasisyntax/loc stx
(lambda #,args
(let~ #,(reverse specials)
body0 body ...)))))]))]))
(values _define-values
_define
_let-values
_let*-values
_letrec-values
_let
_let*
_letrec
_set!
_set!-values
_lambda)))
;; These are used as procedures for the syntax level
(provide extended-arg-keyword:list extended-arg-keyword:vector)
(define-syntax extended-arg-keyword:list
(list (lambda (vars) vars)
(lambda (expr vars)
(quasisyntax/loc expr (apply values #,expr)))))
(define-syntax extended-arg-keyword:vector
(list (lambda (vars) vars)
(lambda (expr vars)
(quasisyntax/loc expr (apply values (vector->list #,expr))))))
;; quote turns implicit lists and vectors to explicit ones
(provide extended-arg-keyword:quote)
(define-syntax extended-arg-keyword:quote
(list (lambda (vars)
(define (do-vars vs)
(datum->syntax-object
vs (map (lambda (v)
(if (identifier? v) v (quasisyntax/loc v '#,v)))
(syntax->list vs))
vs))
(do-vars (syntax-case vars ()
[((v ...)) #'(v ...)] [(#(v ...)) #'(v ...)])))
(lambda (expr vars)
(syntax-case vars ()
[((v ...))
(quasisyntax/loc expr (apply values #,expr))]
[(#(v ...))
(quasisyntax/loc expr (apply values (vector->list #,expr)))]))))
;; (define (values a (list (vector b c) (vector d) (list)) e)
;; (values 1 (list (vector 2 3) (vector 4) (list)) 5))
;; (list a b c d e)
;; (let ([(values a (list (vector b c) (vector d) (list)) e)
;; (values 1 (list (vector 2 3) (vector 4) (list)) 5)])
;; (list a b c d e))
;; (let* ([(list x y) (list 1 2)] [(list x y) (list y x)]) (list x y))
;; (let ([(values a '(#(b c) #(d) ()) e)
;; (values 1 '(#(2 3) #(4) ()) 5)])
;; (list a b c d e))
;; (map (lambda ((list x y)) (list y x)) '((1 2) (3 4)))
;; (let loop ([(list str n) (list "foo" 10)])
;; (if (zero? n) str (loop (list (string-append str "!") (sub1 n)))))
;;
;; (module foo mzscheme
;; (provide (struct point (x y)) extended-arg-keyword:make-point)
;; (define-struct point (x y))
;; (define-syntax extended-arg-keyword:make-point
;; (list (lambda (vars) (syntax-case vars () ((x y) vars)))
;; (lambda (expr vars)
;; (quasisyntax/loc expr
;; (values (point-x #,expr) (point-y #,expr)))))))
;; (require foo)
;; (define a (make-point 1 2))
;; (let ([(make-point x y) a]) (+ x y))

157
pkgs/swindle/readme.txt
View File

@ -1,157 +0,0 @@
====< Swindle >=========================================================
This is the Swindle Reference Manual.
Swindle is a collection of modules that extend PLT Scheme with many
additional features. The main feature which started this project is a
CLOS-like object system based on Tiny-CLOS from Xerox, but there is a
lot more -- see the feature list below for a rough picture. Swindle is
now part of PLT Scheme.
====< Feature List >====================================================
The following is a high-level description of major features provided by
Swindle. For every feature, the file that provides it is specified, if
only a subset of the system is needed.
* Some basic syntax extensions, including lambda &-keywords, and
improved `define' and `let' forms. (Available separately using
"base.rkt".)
* Generic setters with `set!', additional useful mutation forms:
`pset!', `shift!', `rotate!', and some simple ones like `inc!', and
`push!'. (Available separately using "setf.rkt", where the names
`setf!' and `psetf!' are used to avoid changing the Scheme form.)
* Easy macro-defining macros -- simple syntax-rules macros with
`defsubst', and a generic `defmacro' utility, all with a local
`let...' form, and extended to easily create symbol macros.
("misc.rkt")
* A `collect' macro that provides very sophisticated list comprehensions
and much more. ("misc.rkt")
* An `echo' mechanism which is an alternative to using format strings,
and contains many useful features including a list iteration
construct, and is easy to extend. ("misc.rkt")
* A `regexp-case' syntax which is similar to a `case' on strings with
easy access to submatches. ("misc.rkt")
* A CLOS-like object system -- based on Tiny CLOS, but with many
extensions that bring it much closer to CLOS, and heavily optimized.
Some added features include singleton and struct classes, applicable
stand-alone methods, method-combination, and some MOP extensions.
(Available without syntax bindings in "tiny-clos.rkt")
* Good integration with the Scheme implementation: primitive values have
corresponding Swindle classes, and struct types can also be used as
type specializers. A Swindle class will be made when needed, and it
will reflect the struct hierarchy. In addition, structs can be
defined with a Swindle-line `defstruct' syntax which will also make it
possible to create these structs with `make' using keyword arguments.
("tiny-clos.rkt" and "extra.rkt")
* Many hairy macros that make the object system much more convenient
(CLOS has also a lot of macro code). Some of the macros (especially
`defclass') can be customized. ("clos.rkt")
* Useful generic functions, including `print-object' which is used to
display all objects. ("extra.rkt")
* A `match' mechanism with a generic-like interface. ("extra.rkt")
* The fun `amb' toy. ("extra.rkt")
* A language that can easily create HTML, where the result is
human-editable. ("html.rkt")
* Customizable syntax: easy to add customized languages to DrRacket.
("custom.rkt")
====< Reference Manual >================================================
Files marked with "module" provide a module by the same name, files
marked with "language module" modify the language and should be used as
an initial import for other modules. Most files (and especially all
language modules) are useful by themselves, even without using the whole
Swindle environment.
* base.rkt (language module)
Basic syntax extensions, mainly Lisp-like lambda argument &-keywords.
* setf.rkt (module)
Generic setters similar to `setf' in Lisp, and a few more useful
macros.
* misc.rkt (module)
Lots of useful functionality bits, including everything from
frequently useful Racket standard libraries (`list.rkt', `etc.rkt',
and `string.rkt').
* turbo.rkt (language module)
A module that packages functionality from `base', `setf' (overriding
`set!' with `setf!'), and `misc'.
* tiny-clos.rkt (module)
The core object system, based on Tiny CLOS from Xerox, but heavily
modified, optimized and extended.
* clos.rkt (module)
Convenient macro wrappers for "tiny-clos.rkt".
* extra.rkt (module)
Extra functionality on top of clos.
* swindle.rkt (language module)
The main Swindle environment module: packages `tiny-clos', `clos', and
`extra' on top of `turbo', and some more general definitions.
* info.rkt (module)
Compilation definitions.
* tool.rkt (module)
Setup for Swindle in DrRacket -- makes some languages available in
DrRacket, including custom Swindle-based languages.
* custom.rkt (module)
A sample file that demonstrates how to create a Swindle-based
customized language -- see the source for instructions.
* html.rkt (module)
A language for creating HTML.
* html-doc.txt
Documentation file for "html.rkt".
* doc.txt
Descriptions of user-level functions, macros, generic functions and
variables, in a format that help-desk can use. (Not included, an HTML
manual is created instead.)
* copying.txt
Full copyright text (LGPL).
====< Copyright Notice >================================================
Copyright (C) 1998-2014 Eli Barzilay (eli@barzilay.org)
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.
This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301 USA.
====< * >===============================================================

276
pkgs/swindle/setf.rkt
View File

@ -1,276 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module provides the forms `setf!', `psetf!', and `setf!-values' for
;;> generic setters, much like CL's `setf', and `psetf', and a form similar
;;> to Racket's `set!-values'. Note that when these are later re-exported
;;> (by `turbo'), they are renamed as `set!', `pset!', and `set!-values'
;;> (overriding the built-in `set!' and `set!-values'). Also, note that
;;> this just defines the basic functionality, the `misc' module defines
;;> many common setters.
#lang mzscheme
;;>> (setf! place value ...)
;;> Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'. The generated
;;> `set-foo!' identifier has the same syntax context as `foo', which
;;> means that to use this for some `foo' you need to define `set-foo!'
;;> either as a function or a syntax in the same definition context of
;;> `foo'. The nice feature that comes out of this and the syntax system
;;> is that examples like the following work as expected:
;;> (let ([foo mcar] [set-foo! set-mcar!]) (setf! (foo a) 11))
;;>
;;> `place' gets expanded before this processing is done so macros work
;;> properly. If the place is not a form, then this will just use the
;;> standard `set!'.
;;>
;;> Another extension of the original `set!' is that it allows changing
;;> several places in sequence -- `(setf! x a y b)' will set `x' to `a'
;;> and then set `y' to `b'.
;; Original idea thanks to Eric Kidd who stole it from Dylan
(provide setf!)
(define-syntax (setf! stx)
(define (set!-prefix id)
(datum->syntax-object
id
(string->symbol (string-append "set-" (symbol->string (syntax-e id)) "!"))
id id))
(syntax-case stx (setf!)
;; if the getter is a set!-transformer, make it do its thing
[(setf! getter . xs)
(and (identifier? #'getter)
(set!-transformer? (syntax-local-value #'getter (lambda () #f))))
((set!-transformer-procedure (syntax-local-value #'getter)) stx)]
[(setf! place val)
;; need to expand place first, in case it is itself a macro
(with-syntax ([place (local-expand
#'place 'expression
(append (list #'#%app #'#%top #'#%datum)
(map (lambda (s)
(datum->syntax-object #'place s #f))
'(#%app #%top #%datum))))])
(syntax-case #'place ()
[(getter args ...)
(if (identifier? #'getter)
(with-syntax ([setter (set!-prefix #'getter)])
(syntax/loc stx (setter args ... val)))
(raise-syntax-error #f "not an identifier" stx #'getter))]
[_ (syntax/loc stx (set! place val))]))]
[(setf! place val . more)
(let loop ([pvs #'(place val . more)] [r '()])
(syntax-case pvs ()
[(p v . more)
(loop #'more (cons (syntax/loc stx (setf! p v)) r))]
[() (quasisyntax/loc stx (begin #,@(reverse r)))]
[_ (raise-syntax-error #f "uneven number of forms" stx)]))]))
;;>> (psetf! place value ...)
;;> This is very similar to `setf!' above, except that the change to the
;;> places is done *simultaneously*. For example, `(setf! x y y x)'
;;> switches the values of the two variables.
;; This could have been expressed using `setf!-values', but that would lead to
;; an unnecessary creation of a values tuple.
(provide psetf!)
(define-syntax (psetf! stx)
(syntax-case stx ()
;; optimize common case
[(_ place val) (syntax/loc stx (setf! place val))]
[(_ more ...)
(let loop ([vars '()] [vals '()] [more (syntax->list #'(more ...))])
(cond
[(null? more)
(let ([vars (reverse vars)]
[vals (reverse vals)]
[tmps (generate-temporaries (map (lambda (x) 'x) vars))])
(quasisyntax/loc stx
(let #,(map (lambda (t v) #`(#,t #,v)) tmps vals)
#,@(map (lambda (v t) #`(setf! #,v #,t)) vars tmps))))]
[(null? (cdr more))
(raise-syntax-error #f "uneven number of forms" stx)]
[else (loop (cons (car more) vars) (cons (cadr more) vals)
(cddr more))]))]))
;;>> (setf!-values (place ...) expr)
;;> This is a version of `setf!', that works with multiple values. `expr'
;;> is expected to evaluate to the correct number of values, and these are
;;> then put into the specified places which can be an place suited to
;;> `setf!'. Note that no duplication of identifiers is checked, if an
;;> identifier appears more than once then it will have the last assigned
;;> value.
(provide setf!-values)
(define-syntax (setf!-values stx)
(syntax-case stx ()
;; optimize common case
[(_ (place) val) (syntax/loc stx (setf! place val))]
[(_ (place ...) values)
(with-syntax ([(temp ...) (datum->syntax-object
#'(place ...)
(generate-temporaries #'(place ...))
#'(place ...))])
(syntax/loc stx
(let-values ([(temp ...) values])
(setf! place temp) ...)))]))
;;>> (set-values! places ... values-expr)
;;>> (set-list! places ... list-expr)
;;>> (set-vector! places ... vector-expr)
;;> These are defined as special forms that use `setf!-values' to set the
;;> given places to the appropriate components of the third form. This
;;> allows foing the following:
;;> => (define (values a b c) (values 1 2 3))
;;> => (setf! (values a b c) (values 11 22 33))
;;> => (list a b c)
;;> (11 22 33)
;;> => (setf! (list a b c) (list 111 222 333))
;;> => (list a b c)
;;> (111 222 333)
;;> => (setf! (list a b c) (list 1111 2222 3333))
;;> => (list a b c)
;;> (1111 2222 3333)
;;> Furthermore, since the individual setting of each place is eventually
;;> done with `setf!', then this can be used recursively:
;;> => (set! (list a (vector b) (vector c c)) '(2 #(3) #(4 5)))
;;> => (list a b c)
;;> (2 3 5)
(provide set-values! set-list! set-vector!)
(define-syntaxes (set-values! set-list! set-vector!)
(let ([make-setter
(lambda (convert)
(lambda (stx)
(syntax-case stx ()
[(_ x y ...)
(let loop ([args (syntax->list #'(x y ...))] [as '()])
(if (null? (cdr args))
(quasisyntax/loc stx
(setf!-values #,(datum->syntax-object
#'(x y ...) (reverse as) #'(x y ...))
#,(convert (car args))))
(loop (cdr args) (cons (car args) as))))])))])
(values
;; set-values!
(make-setter (lambda (x) x))
;; set-list!
(make-setter (lambda (x) #`(apply values #,x)))
;; set-vector!
(make-setter (lambda (x) #`(apply values (vector->list #,x)))))))
(provide shift! rotate! inc! dec! push! pop!)
(define-syntaxes (shift! rotate! inc! dec! push! pop!)
(let* ([protect-indexes
(lambda (place body)
(syntax-case place ()
[(getter . xs)
(let ([bindings+expr
(let loop ([xs #'xs]
[bindings '()]
[expr (list #'getter)]
[all-ids? #t])
(syntax-case xs ()
[() (and (not all-ids?)
(cons (reverse bindings) (reverse expr)))]
[(x . xs)
(let ([new (datum->syntax-object
#'x (gensym) #'x)])
(loop #'xs
(cons (list new #'x) bindings)
(cons new expr)
(and (identifier? #'x) all-ids?)))]
[x (and (not (and all-ids? (identifier? #'x)))
(let ([new (datum->syntax-object
#'x (gensym) #'x)])
(cons (reverse (cons (list new #'x)
bindings))
(append (reverse expr) new))))]))])
(if bindings+expr
#`(let #,(car bindings+expr) #,(body (cdr bindings+expr)))
(body place)))]
[_ (body place)]))]
[protect-indexes-list
(lambda (places body)
(let loop ([ps places] [r '()])
(if (null? ps)
(body (reverse r))
(protect-indexes (car ps) (lambda (p)
(loop (cdr ps) (cons p r)))))))])
(values
;;>> (shift! place ... newvalue)
;;> This is similar to CL's `shiftf' -- it is roughly equivalent to
;;> (begin0 place1
;;> (psetf! place1 place2
;;> place2 place3
;;> ...
;;> placen newvalue))
;;> except that it avoids evaluating index subforms twice, for example:
;;> => (let ([foo (lambda (x) (printf ">>> ~s\n" x) x)]
;;> [a '(1)] [b '(2)])
;;> (list (shift! (car (foo a)) (car (foo b)) 3) a b))
;;> >>> (1)
;;> >>> (2)
;;> (1 (2) (3))
;; --- shift!
(lambda (stx)
(syntax-case stx ()
[(_ x y more ...)
(protect-indexes-list (syntax->list #'(x y more ...))
(lambda (vars)
(let loop ([vs vars] [r '()])
(if (null? (cdr vs))
(quasisyntax/loc stx
(let ([v #,(car vars)])
(psetf! #,@(datum->syntax-object
#'(x y more ...)
(reverse r)
#'(x y more ...)))
v))
(loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
;;>> (rotate! place ...)
;;> This is similar to CL's `rotatef' -- it is roughly equivalent to
;;> (psetf! place1 place2
;;> place2 place3
;;> ...
;;> placen place1)
;;> except that it avoids evaluating index subforms twice.
;; --- rotate!
(lambda (stx)
(syntax-case stx ()
[(_ x) #'(void)]
[(_ x xs ...)
(protect-indexes-list (syntax->list #'(x xs ...))
(lambda (vars)
(let loop ([vs vars] [r '()])
(if (null? (cdr vs))
(quasisyntax/loc stx
(psetf! #,@(datum->syntax-object
#'(x xs ...)
(reverse (list* (car vars) (car vs) r))
#'(x xs ...))))
(loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
;;>> (inc! place [delta])
;;>> (dec! place [delta])
;;>> (push! x place)
;;>> (pop! place)
;;> These are some simple usages of `setf!'. Note that they also avoid
;;> evaluating any indexes twice.
;; --- inc!
(lambda (stx)
(syntax-case stx ()
[(_ p) #'(_ p 1)]
[(_ p d) (protect-indexes #'p
(lambda (p) #`(setf! #,p (+ #,p d))))]))
;; --- dec!
(lambda (stx)
(syntax-case stx ()
[(_ p) #'(_ p 1)]
[(_ p d) (protect-indexes #'p
(lambda (p) #`(setf! #,p (- #,p d))))]))
;; --- push!
(lambda (stx)
(syntax-case stx ()
[(_ x p) (protect-indexes #'p
(lambda (p) #`(setf! #,p (cons x #,p))))]))
;; --- pop!
(lambda (stx)
(syntax-case stx ()
[(_ p) (protect-indexes #'p
(lambda (p)
#`(let ([p1 #,p])
(begin0 (car p1) (setf! #,p (cdr p1))))))])))))

BIN
pkgs/swindle/swindle-icon.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.4 KiB

BIN
pkgs/swindle/swindle-logo.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 12 KiB

147
pkgs/swindle/swindle.scrbl
View File

@ -1,147 +0,0 @@
#lang scribble/doc
@(require scribble/manual)
@title{Swindle}
@defmodulelang[swindle]
Swindle extends Racket with many additional features. The main
feature that started this project is a CLOS-like object system based
on Tiny-CLOS from Xerox, but there is a lot more.
Some documentation is available at
@link["http://barzilay.org/Swindle/"]{http://barzilay.org/Swindle/}.
@; @table-of-contents[]
@; ------------------------------
@section{Features}
The following is a high-level description of major features provided by
Swindle. For every feature, the file that provides it is specified, if
only a subset of the system is needed.
@itemize[
@item{Some basic syntax extensions, including lambda &-keywords, and
improved @racket[define] and @racket[let] forms. (Available
separately using @racket[swindle/base])}
@item{Generic setters with @racket[set!], additional useful mutation
forms: @racket[pset!], @racket[shift!], @racket[rotate!], and some
simple ones like @racket[inc!], and @racket[push!]. (Available
separately using @racket[swindle/setf], where the names
@racket[setf!] and @racket[psetf!] are used to avoid changing the
Racket form)}
@item{Easy macro-defining macros --- simple @racket[syntax-rules] macros with
@racket[defsubst], and a generic @racket[defmacro] utility, all with a local
@racket[let...] form, and extended to easily create symbol macros.
(@racket[swindle/misc])}
@item{A @racket[collect] macro that provides very sophisticated list
comprehensions and much more. (@racket[swindle/misc])}
@item{An @racket[echo] mechanism which is an alternative to using
format strings, and contains many useful features including a list
iteration construct, and is easy to extend.
(@racket[swindle/misc])}
@item{A @racket[regexp-case] syntax which is similar to a
@racket[case] on strings with easy access to submatches.
(@racket[swindle/misc])}
@item{A CLOS-like object system -- based on Tiny CLOS, but with many
extensions that bring it much closer to CLOS, and heavily optimized.
Some added features include singleton and struct classes, applicable
stand-alone methods, method-combination, and some MOP extensions.
(Available without syntax bindings in @racket[swindle/tiny-clos])}
@item{Good integration with the Racket implementation: primitive
values have corresponding Swindle classes, and struct types can also
be used as type specializers. A Swindle class will be made when
needed, and it will reflect the struct hierarchy. In addition,
structs can be defined with a Swindle-line @racket[defstruct] syntax which
will also make it possible to create these structs with
@racket[make] using keyword arguments. (@racket[swindle/tiny-clos]
and @racket[swindle/extra])}
@item{Many hairy macros that make the object system much more convenient
(CLOS has also a lot of macro code). Some of the macros (especially
@racket[defclass]) can be customized. (@racket[swindle/clos])}
@item{Useful generic functions, including @racket[print-object] which
is used to display all objects. (@racket[swindle/extra])}
@item{A @racket[match] mechanism with a generic-like interface.
(@racket[swindle/extra])}
@item{The fun @racket[amb] toy. (@racket[swindle/extra])}
@item{A language that can easily create HTML, where the result is
human-editable. (@racket[swindle/html])}
@item{Customizable syntax: easy to add customized languages to DrRacket.
(@racket[custom])}
]
@; ------------------------------
@section{Libraries}
Files marked with ``module'' provide a module by the same name, files
marked with "language module" modify the language and should be used
as an initial import for other modules. Most files (and especially
all language modules) are useful by themselves, even without using the
whole Swindle environment.
@itemize[
@item{@racket[swindle/base] (language module) ---
Basic syntax extensions, mainly Lisp-like lambda argument &-keywords.}
@item{@racket[swindle/setf] (module) ---
Generic setters similar to @racket[setf] in Lisp, and a few more useful
macros.}
@item{@racket[swindle/misc] (module) --- Lots of useful functionality
bits, including everything from frequently useful Racket legacy
libraries (@racketmodname[mzlib/list], @racketmodname[mzlib/etc],
and @racketmodname[mzlib/string]).}
@item{@racket[swindle/turbo] (language module) --- A module that
packages functionality from @racket[swindle/base],
@racket[swindle/setf] (overriding @racket[set!] with
@racket[setf!]), and @racket[swindle/misc].}
@item{@racket[swindle/tiny-clos] (module) ---
The core object system, based on Tiny CLOS from Xerox, but heavily
modified, optimized and extended.}
@item{@racket[swindle/clos] (module) --- Convenient macro wrappers for
@racket[swindle/tiny-clos].}
@item{@racket[swindle/extra] (module) --- Extra functionality on top
of @racket[swindle/clos].}
@item{@racket[swindle/swindle] (language module) --- The main Swindle
environment module: packages @racket[swindle/tiny-clos],
@racket[swindle/clos], and @racket[swindle/extra] on top of
@racket[swindle/turbo], and some more general definitions.}
@item{@racket[swindle/info] (module) ---
Compilation definitions.}
@item{@racket[swindle/tool] (module) ---
Setup for Swindle in DrRacket: makes some languages available in
DrRacket, including custom Swindle-based languages.}
@item{@racket[swindle/custom] (module) ---
A sample file that demonstrates how to create a Swindle-based
customized language; see the source for instructions.}
@item{@racket[swindle/html] (module) ---
A language for creating HTML.}
]

2327
pkgs/swindle/tiny-clos.rkt
View File

File diff suppressed because it is too large Load Diff

172
pkgs/swindle/tool.rkt
View File

@ -1,172 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;; Add the Swindle languages to DrRacket
#lang mzscheme
(require mzlib/unit
drscheme/tool
mzlib/class
mzlib/list
mred
net/sendurl
string-constants)
(provide tool@)
(define tool@
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
;; Swindle languages
(define (swindle-language module* name* entry-name* num* one-line* url*)
(class (drscheme:language:module-based-language->language-mixin
(drscheme:language:simple-module-based-language->module-based-language-mixin
(class* object%
(drscheme:language:simple-module-based-language<%>)
(define/public (get-language-numbers) `(-200 2000 ,num*))
(define/public (get-language-position)
(list (string-constant legacy-languages)
"Swindle" entry-name*))
(define/public (get-module) module*)
(define/public (get-one-line-summary) one-line*)
(define/public (get-language-url) url*)
(define/public (get-reader)
(lambda (src port)
(let ([v (read-syntax src port)])
(if (eof-object? v)
v
(namespace-syntax-introduce v)))))
(super-instantiate ()))))
(define/augment (capability-value key)
(cond
[(eq? key 'macro-stepper:enabled) #t]
[else (inner (drscheme:language:get-capability-default key)
capability-value key)]))
(define/override (use-namespace-require/copy?) #t)
(define/override (default-settings)
(drscheme:language:make-simple-settings
#t 'write 'mixed-fraction-e #f #t 'debug))
(define/override (get-language-name) name*)
(define/override (config-panel parent)
(let* ([make-panel
(lambda (msg contents)
(make-object message% msg parent)
(let ([p (instantiate vertical-panel% ()
(parent parent)
(style '(border))
(alignment '(left center)))])
(if (string? contents)
(make-object message% contents p)
(contents p))))]
[title-panel
(instantiate horizontal-panel% ()
(parent parent)
(alignment '(center center)))]
[title-pic
(make-object message%
(make-object bitmap%
(build-path (collection-path "swindle")
"swindle-logo.png"))
title-panel)]
[title (let ([p (instantiate vertical-panel% ()
(parent title-panel)
(alignment '(left center)))])
(make-object message% (format "Swindle") p)
(make-object message% (format "Setup") p)
p)]
[input-sensitive?
(make-panel (string-constant input-syntax)
(lambda (p)
(make-object check-box%
(string-constant case-sensitive-label)
p void)))]
[debugging
(make-panel
(string-constant dynamic-properties)
(lambda (p)
(instantiate radio-box% ()
(label #f)
(choices
`(,(string-constant no-debugging-or-profiling)
,(string-constant debugging)
,(string-constant debugging-and-profiling)))
(parent p)
(callback void))))])
(case-lambda
[()
(drscheme:language:make-simple-settings
(send input-sensitive? get-value)
'write 'mixed-fraction-e #f #t
(case (send debugging get-selection)
[(0) 'none]
[(1) 'debug]
[(2) 'debug/profile]))]
[(settings)
(send input-sensitive? set-value
(drscheme:language:simple-settings-case-sensitive
settings))
(send debugging set-selection
(case (drscheme:language:simple-settings-annotations
settings)
[(none) 0]
[(debug) 1]
[(debug/profile) 2]))])))
(define last-port #f)
(define/override (render-value/format value settings port width)
(unless (eq? port last-port)
(set! last-port port)
;; this is called with the value port, so copy the usual swindle
;; handlers to this port
(port-write-handler
port (port-write-handler (current-output-port)))
(port-display-handler
port (port-display-handler (current-output-port))))
;; then use them instead of the default pretty print
(write value port)
(newline port))
(super-instantiate ())))
(define (add-swindle-language name module entry-name num one-line url)
(drscheme:language-configuration:add-language
(make-object
((drscheme:language:get-default-mixin)
(swindle-language `(lib ,(string-append module ".rkt") "swindle")
name entry-name num one-line url)))))
(define phase1 void)
(define (phase2)
(for-each (lambda (args) (apply add-swindle-language `(,@args #f)))
'(("Swindle" "main" "Full Swindle" 0
"Full Swindle extensions")
("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1
"Swindle without the object system")
("Swindle Syntax" "base" "Basic syntax only" 2
"Basic Swindle syntax: keyword-arguments etc")))
(parameterize ([current-directory (collection-path "swindle")])
(define counter 100)
(define (do-customize file)
(when (regexp-match? #rx"\\.rkt$" file)
(with-input-from-file file
(lambda ()
(let ([l (read-line)])
(when (regexp-match? #rx"^;+ *CustomSwindle *$" l)
(let ([file (regexp-replace #rx"\\.rkt$" file "")]
[name #f] [dname #f] [one-line #f] [url #f])
(let loop ([l (read-line)])
(cond
[(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
=> (lambda (m)
(let ([sym (string->symbol (cadr m))]
[val (caddr m)])
(case sym
[(|Name|) (set! name val)]
[(|DialogName|) (set! dname val)]
[(|OneLine|) (set! one-line val)]
[(|URL|) (set! url val)])
(loop (read-line))))]))
(unless name (set! name file))
(unless dname (set! dname name))
(unless one-line
(set! one-line
(string-append "Customized Swindle: " name)))
(set! counter (add1 counter))
(add-swindle-language
name file dname counter one-line url))))))))
(for-each do-customize
(sort (map path->string (directory-list)) string<?))))
))

42
pkgs/swindle/turbo.rkt
View File

@ -1,42 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module combines the `base', `setf', and `misc', modules to create a
;;> new language module. Use this module to get most of Swindle's
;;> functionality which is unrelated to the object system.
#lang s-exp swindle/base
(require swindle/setf swindle/misc)
(provide (all-from-except swindle/base set! set!-values #%module-begin)
(rename module-begin~ #%module-begin)
(all-from-except swindle/setf setf! psetf!)
;;>> (set! place value ...) [*syntax*]
;;>> (pset! place value ...) [*syntax*]
;;>> (set!-values (place ...) expr) [*syntax*]
;;> This module renames `setf!', `psetf!', and `setf!-values' from the
;;> `setf' module as `set!', `pset!' and `set!-values' so the built-in
;;> `set!' and `set!-values' syntaxes are overridden.
(rename setf! set!) (rename psetf! pset!)
(rename setf!-values set!-values)
(all-from swindle/misc))
;;>> #%module-begin
;;> `turbo' is a language module -- it redefines `#%module-begin' to load
;;> itself for syntax definitions.
(defsyntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object stx
(list (quote-syntax require-for-syntax)
'swindle/turbo))
(cdr e))
stx)
(raise-syntax-error #f "bad syntax" stx)))
;; This doesn't work anymore (from 203.4)
;; (syntax-rules ()
;; [(_ . body)
;; (#%plain-module-begin
;; (require-for-syntax swindle/turbo) . body)])
)