From 3d0e2ad5cda930693e57d547f3691aff8bf977ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 1 Dec 2014 10:15:33 -0500 Subject: [PATCH] Split `picturing-programs` and `swindle` from the main repository. They are available at: https://github.com/racket/picturing-programs https://github.com/racket/swindle --- pkgs/main-distribution/info.rkt | 2 - pkgs/picturing-programs/LICENSE.txt | 11 - pkgs/picturing-programs/info.rkt | 16 - .../picturing-programs/.gitignore | 1 - .../picturing-programs/HISTORY.txt | 15 - .../picturing-programs/info.rkt | 11 - .../picturing-programs/main.rkt | 22 - .../picturing-programs.scrbl | 543 ---- .../private/book-pictures.rkt | 16 - .../picturing-programs/private/io-stuff.rkt | 30 - .../picturing-programs/private/map-image.rkt | 579 ---- .../private/pictures/bloch.png | Bin 34185 -> 0 bytes .../private/pictures/calendar.png | Bin 339 -> 0 bytes .../private/pictures/mad_hacker.png | Bin 2475 -> 0 bytes .../private/pictures/qbook.png | Bin 941 -> 0 bytes .../private/pictures/schemelogo.png | Bin 4107 -> 0 bytes .../private/pictures/small_hieroglyphics.png | Bin 3945 -> 0 bytes .../private/pictures/stick-figure.png | Bin 370 -> 0 bytes .../picturing-programs/private/tiles.rkt | 205 -- .../picturing-programs/racket.css | 188 -- .../picturing-programs/scheme.css | 166 -- .../tests/map-image-bsl-tests.rkt | 513 ---- .../tests/map-image-isl-tests.rkt | 89 - .../tests/rotating-triangle.rkt | 44 - .../tests/test-docs-complete.rkt | 7 - .../teachpack/picturing-programs.rkt | 3 - pkgs/swindle/LICENSE.txt | 11 - pkgs/swindle/base.rkt | 594 ----- pkgs/swindle/clos.rkt | 732 ------ pkgs/swindle/custom.rkt | 80 - pkgs/swindle/extra.rkt | 969 ------- pkgs/swindle/info.rkt | 48 - pkgs/swindle/lang/reader.rkt | 2 - pkgs/swindle/main.rkt | 17 - pkgs/swindle/misc.rkt | 1904 -------------- pkgs/swindle/patterns.rkt | 265 -- pkgs/swindle/readme.txt | 157 -- pkgs/swindle/setf.rkt | 276 -- pkgs/swindle/swindle-icon.png | Bin 2486 -> 0 bytes pkgs/swindle/swindle-logo.png | Bin 12785 -> 0 bytes pkgs/swindle/swindle.scrbl | 147 -- pkgs/swindle/tiny-clos.rkt | 2327 ----------------- pkgs/swindle/tool.rkt | 172 -- pkgs/swindle/turbo.rkt | 42 - 44 files changed, 10204 deletions(-) delete mode 100644 pkgs/picturing-programs/LICENSE.txt delete mode 100644 pkgs/picturing-programs/info.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/.gitignore delete mode 100644 pkgs/picturing-programs/picturing-programs/HISTORY.txt delete mode 100644 pkgs/picturing-programs/picturing-programs/info.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/main.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/picturing-programs.scrbl delete mode 100644 pkgs/picturing-programs/picturing-programs/private/book-pictures.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/private/io-stuff.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/private/map-image.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/bloch.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/calendar.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/mad_hacker.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/qbook.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/schemelogo.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/small_hieroglyphics.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/pictures/stick-figure.png delete mode 100644 pkgs/picturing-programs/picturing-programs/private/tiles.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/racket.css delete mode 100644 pkgs/picturing-programs/picturing-programs/scheme.css delete mode 100644 pkgs/picturing-programs/picturing-programs/tests/map-image-bsl-tests.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/tests/map-image-isl-tests.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/tests/rotating-triangle.rkt delete mode 100644 pkgs/picturing-programs/picturing-programs/tests/test-docs-complete.rkt delete mode 100644 pkgs/picturing-programs/teachpack/picturing-programs.rkt delete mode 100644 pkgs/swindle/LICENSE.txt delete mode 100644 pkgs/swindle/base.rkt delete mode 100644 pkgs/swindle/clos.rkt delete mode 100644 pkgs/swindle/custom.rkt delete mode 100644 pkgs/swindle/extra.rkt delete mode 100644 pkgs/swindle/info.rkt delete mode 100644 pkgs/swindle/lang/reader.rkt delete mode 100644 pkgs/swindle/main.rkt delete mode 100644 pkgs/swindle/misc.rkt delete mode 100644 pkgs/swindle/patterns.rkt delete mode 100644 pkgs/swindle/readme.txt delete mode 100644 pkgs/swindle/setf.rkt delete mode 100644 pkgs/swindle/swindle-icon.png delete mode 100644 pkgs/swindle/swindle-logo.png delete mode 100644 pkgs/swindle/swindle.scrbl delete mode 100644 pkgs/swindle/tiny-clos.rkt delete mode 100644 pkgs/swindle/tool.rkt delete mode 100644 pkgs/swindle/turbo.rkt diff --git a/pkgs/main-distribution/info.rkt b/pkgs/main-distribution/info.rkt index 66ba9f3363..c31950a1ec 100644 --- a/pkgs/main-distribution/info.rkt +++ b/pkgs/main-distribution/info.rkt @@ -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" diff --git a/pkgs/picturing-programs/LICENSE.txt b/pkgs/picturing-programs/LICENSE.txt deleted file mode 100644 index 9fa2843583..0000000000 --- a/pkgs/picturing-programs/LICENSE.txt +++ /dev/null @@ -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. diff --git a/pkgs/picturing-programs/info.rkt b/pkgs/picturing-programs/info.rkt deleted file mode 100644 index 4b908d8230..0000000000 --- a/pkgs/picturing-programs/info.rkt +++ /dev/null @@ -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)) diff --git a/pkgs/picturing-programs/picturing-programs/.gitignore b/pkgs/picturing-programs/picturing-programs/.gitignore deleted file mode 100644 index b3a5267117..0000000000 --- a/pkgs/picturing-programs/picturing-programs/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*.css diff --git a/pkgs/picturing-programs/picturing-programs/HISTORY.txt b/pkgs/picturing-programs/picturing-programs/HISTORY.txt deleted file mode 100644 index 75d8a53f2b..0000000000 --- a/pkgs/picturing-programs/picturing-programs/HISTORY.txt +++ /dev/null @@ -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 diff --git a/pkgs/picturing-programs/picturing-programs/info.rkt b/pkgs/picturing-programs/picturing-programs/info.rkt deleted file mode 100644 index 1db4b56680..0000000000 --- a/pkgs/picturing-programs/picturing-programs/info.rkt +++ /dev/null @@ -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"))) diff --git a/pkgs/picturing-programs/picturing-programs/main.rkt b/pkgs/picturing-programs/picturing-programs/main.rkt deleted file mode 100644 index 0b70d29c7b..0000000000 --- a/pkgs/picturing-programs/picturing-programs/main.rkt +++ /dev/null @@ -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) diff --git a/pkgs/picturing-programs/picturing-programs/picturing-programs.scrbl b/pkgs/picturing-programs/picturing-programs/picturing-programs.scrbl deleted file mode 100644 index d44dd6ea25..0000000000 --- a/pkgs/picturing-programs/picturing-programs/picturing-programs.scrbl +++ /dev/null @@ -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} diff --git a/pkgs/picturing-programs/picturing-programs/private/book-pictures.rkt b/pkgs/picturing-programs/picturing-programs/private/book-pictures.rkt deleted file mode 100644 index 4c02ec462b..0000000000 --- a/pkgs/picturing-programs/picturing-programs/private/book-pictures.rkt +++ /dev/null @@ -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")) diff --git a/pkgs/picturing-programs/picturing-programs/private/io-stuff.rkt b/pkgs/picturing-programs/picturing-programs/private/io-stuff.rkt deleted file mode 100644 index 5996b855a7..0000000000 --- a/pkgs/picturing-programs/picturing-programs/private/io-stuff.rkt +++ /dev/null @@ -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)))) diff --git a/pkgs/picturing-programs/picturing-programs/private/map-image.rkt b/pkgs/picturing-programs/picturing-programs/private/map-image.rkt deleted file mode 100644 index 1486de4429..0000000000 --- a/pkgs/picturing-programs/picturing-programs/private/map-image.rkt +++ /dev/null @@ -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 diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/bloch.png b/pkgs/picturing-programs/picturing-programs/private/pictures/bloch.png deleted file mode 100644 index 0a1690be1173d714aa9eeb2e57af5bf7b3c83110..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 34185 zcmeFXW0WRAvo6}UZQHhO+qU~{PMg!VZQGo-ZQGo-yU*->&b{~dUhAHJU#^wKsEEv` za#cJLQ4vZClJGD%FhD>+@X}IZD*yKS|2hB)RYyR8&d&Uw3h|u(mS? z0`knRN%K%sUB?)C>7foG1Dw+n<;-P0B9MrSRiZ-`a1#FxLPxTrA|io`EDzQfHeYHe z3__sdQV|nVmIRjs6RRgm_izL`tLALl5xlK-)9lT5n-Mtu?Co(>06Jqg9v{D>0wN=G zQTg1;!RjZD!UDk;0?|eSC5=ZgEur9jfA{YH)2f&gu$O1=?OFYe@e+iA-s0z#MM+k5 zN0a8CH)=aTy%q!ng}T^O___hSy6^t{bq7WoLM1gp0sajNWYz`cP6HbdR@cQxl9Cc|ex2T%79SrnTn1^X z6P1!3G+pA@*Gw=I`sets6i^Zp(BoNLFBgwc4M=NGE1~a(7T%jpz~rdkqwnKkgGjNC zDye+5mp;@sbiiZu@7S>d!NBtts1s>!N@}A^BxcYSEq%WIm48M z4vXu~CtMB-bH|D4&2IC{*6TN37?>z`^jn5?Rh`zhZWF`fz{=oogdY{(qqBxXN`+h= z-_p|7=c|qfw?78$p66|onzaT!?q3pL)4FYroNPNCAHP&pA9_CMYiba`J=a!NcIM~b z%BwD&JzkP>bIWFPp9K8B4~{1V4ST%5O6%%=t~dYe^x%35a&fWoeHtGfj?OnUDCYg~ zdE*iIwl^`k|L|b&^8*&9(U%fa(=$m;Zm!M_Dnt<#SC`ipmDLTe2nS{w0iJ63C1(PX9G2Qf(yXQ214wc$%9h6+WbKTD+T%s{TF!a9X9~d-w0@9lb7cQx$hDi z2-F9NkO`=$$TW`$$neiMmtbHBIZz4(*%T=eH9aZq=p-;Y9rO}AGgK!Zj06^h0m&Xw zsnln5P#)YO6UKwp-+SXQ$pb|pmTv{KNkyqrR}-9ZLFRqZ3>g?a=#e8zGEa%Wo_xbr z-F@2K{ZgNylmke)5Lh9MT!GS8pM7<{-3imc2*y0|Fnj(;MjrS9rR)KZNC9<7E0)k! zmC*SK2>~*yUQfY)h>(eZu)&1EiiNNNeRz6(glq8#y2gUp;TE3YyU5%_Akac83Hnm_ z_gHVSl|?&eGR-LV5`R#dp@~E6LoP#hjhR5g{ltY(^VI#GPXk!X^M*(kDUK9$Mz%~aSl<>abmw$!?%N%Rgr zs#&Dj$5B;AR5XjXOE%30%q7g*#;7N9(q0n%Yw9(Wbs7}LHLaC80*oilG{!ZS)qS~s z#bgHR#J#)2>&6IA)6@{z8(%}@(CJ%lOP{FsJiW(4kOf-|niQ3cWR8$htjfbq4NOnd zSz$1q>NRdz54X0qC^x@3Y}$HEe+P)RnieOOHATP*st}t-r&b&JzVfRdb4|T ze(tTnNcGD@PF_?W&7 z!&6Sl(kX_aS0_uv8ta&Mu2oKBCr`QAj;z|R32nF2>T;io)M^^srcT*MZeDtT-5z1& zZnb!}35{1QEcCRXGt!Dz*&&esxEx8HI`=0Lls(wu%(z@;Gn(n!^pbefpN;Hi6~V`P z!1(+7%{H2E1`BRZ@kA2D06w1du2Osx?oOLHd%vD;<#sd?ZDW(;r2QE1H8VV?j%QvK zhdUJ|pRoKA4h ztd*L@6baFQjk(`4q-G)Rgm(Su`vL6Yy87eKeu2vjPKd*~j;N;Sse>*{HZ?6xEgMv& zSxqg!mU>Chs_1HW>6XcHhER|D6l#{tav0(Guyk9i8Ff#I&7#Q>X5e$qwm{{XT2foS zjaP2JYi7Z0+I4CD5`?ssl&5sIbRuwm+j}3V8U6a++9Y^Ne|a)!>%M(wn{|A$H=MiV zJc|R90;`172KxvTW1P_OF_Io!C^)_^Kro))FR51GpkLsiA$_-@8|oOrB;%7^P@K`3 zPqCSzmcx}t)OI5krEGGk8S3{k`LBGEwvPqkC7Q_k#zE%jc=+V(nyB^iY;Etn5=V5Ta1)iB*Wu zt{-xsVPiMY%Mfwa2t`>0kLk3Hs6`4_hA+CXr} z2kjd1t&N^Ilh~t@Rq|BQWyUd{Ir%)PKE|k)PqU?@S7R3Gr8g+0-k?HWzLTL}j!{`# zCr~k8tzDZ^eqBsj^dQ`pp9W+&JAx>H)Nje9p^FTpiJ)7-T&3>g|W7nLyD zUqpv%zj#t!suB?*2z&MLy^`IlPs9$Wj~D6LFK05daVvSfh))t{9Je(m8hG;5cl~TV zMEmf^yX@t8Z@gNSba8*QmMyk+cD0w$x9C5QHWu3rI!@&ox$Ddf3@@X6W#2CM0yaNR zMKcJ=Bx7TAV%dESKFy7M9zv$fIBx`hddF;wv2K|#KJ#=%d^P}b$X5lUPJDm67{Pxz zNS3z0$zKjR<-ILt=3I0-S;$3ajW#Qsyv|Hb|9(cyTxl?V@Uc7?`tX#$gldhtY>t(^ z&(@C0!D2!cbUPl%U`94($Q3-`{gAW$4eSU7it&Rm{ZWGsUOqRpEPk8(!^0Zh6X~Jo zrXXXGgMx}aZOmozL$n5WS{!o3hQJ#-{#VNEoE3W{EX?Ay{Rc=my?!J;5Jlo2`y;hh z(*kJ8%kh{x+A|oNIhvR=c-lMtV~0RMe1e`%#-_IB03s7}OKS&ylH0C7Bt+I`{3M#} z@=WqhqUKiCQr<4+s@@7}rrx%u+-4+#0x*1@JpUBfn*)rAJniiqTzNeCN&Z_e&%fjU zy39yI^xq-?TYeHPc_kuIM;CJx)?iIS(}PFI=Gv=0L)#8sH7bL=62K`;qTZ$K+ez7V!~>k*=AkfTIvxP-_tP} z&UBq!U0u8-UHbqJLLDXMdL(8fYUFqcq=e)|l`A|`0G{M%W&`-ke+6PUKYqI}e3$F9 z0+7*Phx)hPtLwNKK?{kA_PUX6smG2CVWw|4`sTb7p`mX8hAdi)$Vix>;n2S&h4dwV zmkS$BdgCe4oWV&L6#Gv8k`1HZfxU^uO7)@qwelfI87+Yh0TlcuMqw56GK-BL!Vp5% zvg6B%C`fdXe#Il9K+S_siJ6o@R@P!6P$WO7FvANCAT=G6<4aNuC25kvV&O@PPYRwL znRDVMQ{!O9jMWwc@Gww<=4FYFl$yG*I-k+;K`5X!sT?jOC9)(fxGX9SZPD3TP;kK0 zfTkp;CdG$J_s2JqF)~-2pCu<}4;@{BaS10Wkx?MWg7M@|6fCr}aZLb)+N1NfU2P#~ zA_Nql0tKZ}CW-({IDx#vOmbi*qk%#Zks#f1i!ekD7Q15631m^8G==)Sl5Pe0geeIb zvCOH##EuX-x3kr11%(ZhGih=0z)P0xosr=M1O2#_!vQ1^1R&dytjI`mL%GgHmB@sp0U*>SUzLQRQbu zj01t8z;r}VYdZ%};AUlp$$ZadouN_nfq^-z(FuXEi9sX`l*VhDWlSIIw%u$11NJ6L z5`l$OV)}T!$i+W>n9=eBUAY#t1+s) z&4WkK)OZ9DGXu(0SSY}v1IE-^ul`3yP5DZ%czocpfq%kAjbOEu@-a#9WsQ-6;4_3n z(*6o6Ov;NZlc9jJ5n*%9k{1QSqD8{#eS?xihJ!pEqqqo%{VijeJ70)WoK}#Ni<6)D z4a`>2A+3U^-3}6 zgi$EBqfpvAJrzCdcr=UR#&M%jP$eAu+(I&%55h6Yu^Tfl3 zB@%*#= zy^5guXV>=R}oC8TD=2T%6JlLdjWIptJvQ=gXu;z5Ogm!+8ddA0L-nW$kfL`V8G z3w#5h^eBA0aT<7PoQRb8#(gLy zAXF&GnfW8U00ayO6X0F*zt}+H1K?CrEkFzL8UmFL>fvewnL(cV1cTEphy&gkgSYVXwH?b6X+$GSM9rmd`2U5;<_Xp~ck3S9@Y z2%$JaDd$SZ?*r!{=ceUmr({P>K}d-j52*v;E!Wd?r{H17%*zN(h|c{%AX0)^5T5#!e;W^YTU-!ZfPNrm2HKoX^x#^8RXi^iuN4a zCS4l`EbKK*GQ8A`B2c{un(90N@?~72M0AwAY}nGQ%m}(;4nQTM0Rbc7g3!G0KTKjz zH5Y{jgVqfyA5vxt1cN4I93Xw-{08o0AfPw^4#E1$0Ek~w$}iR@xzh6JMaTqiDBwcYuJ%lBX!54wd>a@ct0P1&lvB*5jub``w8Ek&7NM3ep+o>J~;*+?aA#}h~?q}cWK!iI3_hUsI@jR zwUs3~va-50w=$t3w;`i9q9d>-*j%VyQSX2vATb^d8J93K0iCe~)Jlc*zxIR{R|yKkzr$49GTEVxTdY6`Akjt{urSNlrVHw=n*X?t&V~?I84&DI78^ zOCa^&{(`npX3&g6Ttv*@2>6GgV#mUhkor}PEZp&P>sn>y&$27;j22t7l~1ao!e$A1^O~>?Z}nw285vu2bpJ3F z740_n?LQn7-^Kau3d+_!jgi@@wV4&6#O;bo@!@~|xLTE4s>umiwa3-{ku{S;N{t_% zG!=#d$rvgT7rhN&P(lOXNU+2OKtVzN?t?~i3KRfY?n6F7{^ubQjxa0A0w#fo=D^9= z+WokIC4_(tK#X)H}CEX%)=5^iQkyf0(m&E(52V!mjP% zg%~$78+mk4_RFd3AgN$rZ1b0vkAWw`Vgx6~f2vDs%ZsWItd`i(0Bq=XHBX|!+eL++ zzP>rv_|ri0HWG9RK_ja3`LNb&kPIDWYA`hF7rk6KI6HxLGSz88ffR`@f#iFFdNOT} z!9kxSPngz|LV@mkdN^jlsBrkdTleZbeK@iLF=5Y~#LS0BB_W3-Un#`jLOnN&?e58n zCFdFoe^(f%d;YninvIrvsn#-7Ga*uQ&sOw~wv;KJEES?P^zfaFDvHUB>1a&&mXL4B zOGf)9Z@VLG#5IF^OojuXJ++`e0?;1a3YyTKnp5%%4&F=GU;b zB$M3~eKr;JCN>pGOO^jJF~J%t{4M3rXh^9952j~bK0Rc49PiQuwcaOAfZ)VI%tC}gMU7UGB?Z~K6kOs?dko?V*@)c?mz6n5WNzGasA?K~IM9Q_ z>196hJ`BMf$hJVrmnfQp0(y-K@-KrO<6FJlW6#!O=cYHMZuiK!f#p!osaemO#L22< zYfgh`?oeoDQE6pTY-d+q?3iC%RhC~yUROk1RnbWxQ;ARS#x2jTjgL>x&yUW}&khd{ zjuhKHpu_Iw`NZDlvdn2EXtpCyn{+6Q3%ZyR*)SD2Pzrv2OS- zFE)~sq2i(b9jsV*Dt4e6H0Qjdo!~Iu|2%JCQNREpJOiQZ*BVivFuu=FpL$*^d4uWB{p|P?R@I9%5r*= zy#7)c{$|}HU4W)nhY_=cMuUMEjc-QGkPXy$_n$srpdVHW9rgPr4R3A=&`rT&6*O3LktUj{21aTP8@= z|G=gPgwY51@)*{eZ=U3!^Kv-Sf;Y^);z2nonXLtj$D5~v(GcVxVcuonx!Bm4$;b)W zmE#t(+ewfijmtwPd@_OJAByHQ9r$9MVQ~m>uucq*YD_Qdar7zEjwy3;&k=J@(6X;l zPYm*H4P((Pjn9cZNwOaM%~I@1>NR1QUNeBM#~<+)Yy2~Sq3&|MNtflAsVDB z#+41A3u=MDN$`qOm^?_+g`Jq4q@e{)tov8Ek!L#gYbyj+klj0pH8PcBA?|KQ3OI0T zd2B(aQiAE!2dmjlvH?w?*K5?k;AiC~dRG=I0|*)t)Z~G=SHZDPMC6|LE(0OyRwj*x z2C2gdnao6b6m?rw3$uOlELSz&ttrqly-ae&ukCV+t8qstIV?(c!BCasu>1 z-M0CUXJ|--Bly*11Ux#c9T{G-DelC$T1Im92&LiIbQW(Jjr5|j(9Dh%Z&P_~R(^9@ zQ+ZN+a3*WFP=63KEy-o{AM_(rQ;X`t(ofRn#H1eJ=B%tJFT3VHacTB)$%Ft^sd7gj z89NM}duIGshD;ja;F3dNm{-_G$oxRqwEd$f&rmNVqlV8y5o2lQZct!MyY%tW25z*# z0EwZ}Q1JFXg0piov_12bRHU)elCqJvpcDu$+@m4yhlYluVju?zDpqQu&0UW5Wv0>D zNR<7F-_Oxa^KhJract@X?>gv~A^7=a_?QK{QRAk|p^KvvC%6-7I39GIntG1AznWZs zo@RVqpEfPx9I*w}xU{J8DpB%kCU{$NwCP2b9ZFeLKRG+FHiMYY$FeSIc(l%Ra4NZV zF05$2aN9$`xdPlj`RKOrq64B*I>Nf5r~yd%(1=e!`<}lx#3UiX!e2u|Ad4-@QOmia zj~@8Z+8M*bKp6nUN#mA-@dXX%ELR}NZB%ipRH?a8k+6LZ!m@k(bPO?r#0^;KS4+Q* z7;OzD2aOmf+vRf`lnun>>=bOI+T+k^c09U}x>8c8r`CrQo=?f%BNjzq7DTa;9V%kq zv!c=Nc2Y|!`Y9iz4x$k`*hYVG(>nIg^xp(g^8sDBg2R9$&9Vu}QqL=st zeE$l+1R8eII<~4$t)^yg4qk7_I8c-4(vi2^9z-+^Ci+z4J(=Odr&PP8=+(g2#4OXn zp}VR1*K;VtJU6h+=~@jL4TE`k^7aqFZ=#k{ zpe6x}Db@3^P{R?2lO6zLqQuY)GE(oMpElixq6rOK2CvGfME}bWHG+vyjA&JS@EvPGKDy8NLz$_G+4;wS>&f|ID7<1MWj(11Gjlfv|JRD< zTfON^%t&KNrbzi)5xDB|!G2HoH;jTJcpVcb-Qw=Zve3%3*t7y7L@MxPq%iNsjG7JH zAz~?LdRsg1`W3Lp1Euf20}c29H!71^t&*oYsds}|vJ z!w`Swb>DPPb3bZ$YgbdIG+`;9T_s}7E15Z!!G(l@XYQDZ_xF2|k^Q8p z6S&XV(10P_88Sm=`c9Tuvn7AWaOL5#K zXnGMK_8lywjccJ32qKsbyt22D{srKyB|^H(O1kP2L6i(@5Qnx3@UCm2ahJPE{ykME z>tZj4u9gCH2tGPjADv5oyekNkgY<4B8J>J}&%_wqrEPlQ^Q&iag-$XxOE1XvI$s2@ z*BKmRMhI0y-57-vEaCKvgfqIDCK?6d^#*R-%3mvfNTT_rM zIo?z11J9S@5XRA$&?CV}hT4Y$S4PZd@`CIAt*=K?nCKGho89+W^MqdXbzRh5jbcRh zOLyP3aI2c#9^Z4X8nnhhy?42`*M(p3#XIF?c<$!ya1;nR@9W*1t zGxL438f(j1gi7b;m1lQ$w-(Nj#)hTFriBNWrr3?6EHpv_boBIW6wy-SaX1pEer2dc z@o@SMQVELzJ{0EmH#%WpNu{A<=|X}e(2u#7*;>=0Ai5Z~>gXkXI>14&-q+P*aCS7Q z&lR7&Tg5u>+uC_w#_M{BYm^?1G-lON$P*&8JW9n@0AA#@l=f^T#RN6L4 z4F`mp9j=e-6C@W?C6(2WKl<0AwRys|PsC}!@|2BE7r#W=dvJNbPcuYky%7a&)*x#D zP1c(!?+c+DD0>U~3cKRb7?u#%My2LqYl|!*zV^)rL3qSeYZ=sC8#ch0j+BE!h_3O` zby*QnHMQYI#Kka%9Ql*&jXF8s@Z4Z7NTU zOKht@i<%Nty7SP9XNt0O0b1FM#HPKG9m#E;HV?#&>) z_yYOxLW%S}RJcTdxF-g$6K8%Sca6 zE6Bx$kBUeX1hDwO2^j9j>F$pPE)HSG9%RSzR>?Rdbo@A+_Uc}L z)aGokx)+z%WVZ(6D8{@Lm%JvZd>V60!Fv=G6&klSvm|=7twKLE#lkg)Q{20Rm74=q zI=8Gs;_a~qK(H|5fp%Z6yO@EAG;-zTYWD5P zIwT=;@sUJ{7BkoH$x(#ixSw<)oOoOC$YeJDu&5av!raY^4XT|>n&=U6ue2fIdsUQm z{^XyvRiKU)Jp=%~Jrouj7z%&)Ms#=Hy{#Xll`ZBG#`*a;-3)#eD89`4`Z0BT`@_M! zncF?hFu7QQb?`>&5q@_A-UmZ(;#~Rta|E9b^cL%SB>y?K#Fd;GnXzA}?Bx3BSE2`c z1`lYbghIqg=>LvIarmT z{?@xSu)4UhZKB=4v+^=~smgeZFfj09#zCFs^KeoA5dGwb8UcXv*lkNx&(^mtk1e6$||R+v0_&3v@ub#zjmJb4=0i^!_a zD49w4vb=R&-o4oS^IYM}x$&&$P=&>8+@34NxPnIrGr($y@myXc~*3loouJZ^D4{1 z@X__OP!QK=Vy2}R%@jw6q+I@}M}rUkuRL&+pNM}g7Z?>6UXyyygP-Dd@$W4w8N!l| zt3N#p(G8f3EgA*dRK;>snc%eB7ytadO*``Y*|ipH_9utak+I_P zS1zar&x^kOE~|bUcst-0^Jd>%lFNF~Mn)bn;=U;s!Tnzl_YB~0Z(VeE<$!^2M0{>) zZBcS-o_};_g}?v;FAS?|>Zoez&5B7#O6iTMXbp{MEz7bO87PgO8j8L`!&*+bB4xh{0@UU#MO9<;b_5nGzc${K6Y53FL4HMAos_pCXu$gr^MrgzwHJ0Rc zvqgc0t|KsgycD#Y)VhgtcDFRQ{lk!%({8pRNF;j=hBcRacn{M-E`#Ds#|BgB6 zHaoK{aK`I-yu`4UqSK}f8HdK{U@1aK{;p#t+3BTa%dKNAZ1?cc3PR=Hy7BDJqwws_ z5bMq0?k(V8QS0uV8%xnTazWrOF=NrGfZ^?4%9C2E<77QEliDYqXy~+_e%tm%j+n0m z6%aO1JaL5H5GmtzAVLu(Ytq2?QVg8FNj=pjnXH)<1 zYis$kh4W>K6U>mjP-;5F`1SBSo}2uv%A%B1GdzMMEUzP211GngW*Nq?_u|hsIUDy?i^8D7B(YfjkkZfRlJN!>uMwE!-K@mFY@`+~nW#lL-0 z|C4(iKem5|0z&$BCms)XPnkX`e{{=>!ghN@h&qe7)rH*(=m$m8APw)!^cbsC59e0`i- zMSW9&hHgZ%_(?~i2hfW?o(6F8Xq~5HQvo9jnVOUrSHC)f@_YTV^_6NfV8H0TSuu#k z$bGhONDb>79?_Z{5m{Bz6gMv(y4J*_V@&er*P_kP~R$>!xsi-8HBOnz|-1@q|%?RoyXxJ=oP zd+@DFn~_=>t2&Jz{$3uBRVn>=~2@ZArf5Wb82@;agzug{!x6^kJX-a55yBe!H$qm=j+3s&^V8i{Vzn$vcSo*%TrB9Inp-E zgv-UT;|53A;N6ptgbqKm=f}43+_qg8> zDKmITBAo20$X?P0+Q2Ks?hwETBL*DrshyD<6Sn(7@J~yDzbhlVgFe0a_2KpD)pcP} zN$u5nRYB*XS|VawI${H38*_7IjPfa+0%cSAKE_Ig`f2(;zdbADgoO?KdbN@%kM4g4 zL#HWV-^?s^MeX1GLpw5YYSW zKg+664IO9vdR>i=fv?2U1ph6Jzms_P2PbWkX$gjPB#O1wTRD=s+hV!9pFZXw9sDnE z2UISmCzAu*U`+aW!nM)9>1R6Hc%PwPZwv!l&8gy+}5E%g-aO(Gv&-JtT zQ@GVA{YF7ozr>;oM}LWP;cQq>zHi`gWmsd|(o&6onORg9RTNa0lT}rd)D={KSivk@&(T^_x12@x{i|l48I<+>1GZ?bmm})#GAG zgL}bwNUDy}5u99%;F^EJa~NC-+4j6ZVPy|sQRZCMNZxu_RaReBQc+7)RY}lXRa#k5h8#aDr^T_N0Y%eqi75@U z$;V`6#a9yYLneIxEk^n8mnf7Zuual4@dZgegy2!jJ8-7BbRh64Y>kT`5RLjjO{oWe z@E?z_m;7Nkls%cYK7A?=hs7>8$5nS32Jo=;d$=C&2Kq)jn(|U51Q>)v^hNys1oL&i zzpdci67uV30@0ZfWZpXT; z3b>W&I6}V!N__hgKxRWukvDrVqR*!ofvg&vSUVr@ zz!{@x$I-j3@nzZYZhDv_G_4^#QSjHs@#bXx>uv$$w>MVfb@YsK|A=sZDtdGWf5ZUP z8PVN~NVlU;@C9&w++2Pbd!jx%x!PQ3t+Rj(oVo1S*L)acJeBav;%joMe12Y^=}>h; zjS26hX`4q4W(~>~0{7}rRwuCo=eNftent|kicHa%mbRrC5k&V|AGJ}U- zu27>ZM!k6Hs<1=Go%=+@WQmm+oImqSKN5q<6cSa|;=(}8i;C3!NQw@J*I-4z_Y)^jO#3DJ`3%5&@1 z#0aErK<~5;ars-gFi}ilqnb_1KUzq1+@tchnQ-DyCT-c-P?6xH7sj0!oie8 zXZ)~2u26}NyK8V^Q(sm$gcONa)uS!zR#s5QXfL;+t*mrZQ~Q+GzLSJcX&K>3JdJH$ zKDM)uAx;Remg<;mXCo19z;kMt z(;FO*#;V=qR{nFDo<65GC7?WTxnEoW?<<i=va)sXGU;ifqHq^C$*_2F-bEp!i?gh1iW$vGzmZy)vKT8umiAjcIgB-tjVp< z&Tu8i@oPw&<`;I`xxqEBTwc=BmfLUTH~R%&NQldGv*VMq!)xyq7XJJx?lOU^WjhVSP$0B%# z>0JIx@`;ST0@PEk4+|Ihr=9y9uy+v74G=N}6z&u>geiECPav!vp0iw4A!t3exVOFi z^RMIPXA~bql?Y1}e|Gd)+uHU9dV@$qhERPT&#!&D>*Pzbw9_-Z<3n46Q>)85YEw!J zOHvyv!bIY$?0xDzY(fMXm`U=o^@)kn;uqhrk-fN)vzVFRG77K+qu4O{9kMOC87v6- z@$X;e`5qH|uJ%a|5FAp=QYsr(c<|}9#W1kf(9Z*+pT9J@w9Lj2ne|v?g;0;1 z?ChT4n~(71mr+5pxwM(rpk@JrAJs@{Q%Y%4m`z5IMN*uXT8tm^GZ+aBspGls(XT`b z(f+o`hmRaL+o>`~3v*=+s<+{~1i97OJMA~Upr)DRpsY|h(NYOp4EYV@ zEmU9XfU18G~1Pg|Sflu#cIx2cIWtO%3H zAnA3Ad1+T( z30n{)JT1zp`XOW0qXA=F>?UYa_np&2CMI_6U4aEBIBv@=G?_A&DaXlfZh)AWm}odO z&RTW-569~m!G4*VqE^3cL>7Uall3!s@=fh65R!!O{st#7iqL_4RxCJ<9179Wy}x8^ zXlA%`QO#P3qn+m%7CJnYxO9)npVu*opgF>%4L2t{r56lgG7J(lxMpULXnsyiDx8b) z>}sFPb2CI!5_tsIy4lEn@yR|t1qaTO%cBjcX}+VokDTB9fcs-1&~7hp+CwN-H%tKw zOy=I&fTdP_E@2b9zqEs9?ix2J`>wQ;Fhe0*E(|3hi9K0Swp$Z|hJSw5R~~)d zU4wo+01qKMtRUDeolNb)h}ek=6iECQpb){Q?Yl9tJd)^I$EJ1AqXZ?D))03OF6>T? zZS8Fh>&WfQsI1PI@Ycr0=ElYreIvYrLpK@BmX$5no$x~Az!~j3NH+t?V(?lJFT~_Y z5E}`4QR;Oq5DIyl0neP=Qd2clT~RSy9~9wT8eiKKqwiB$)Rvr4c`E}G49}+e*-GET z^2hX$?ZG0X{ACYr$OSvz1UdP-qFo9CneZ7G$*GmKs~oA^lVwf&Vuuk8sWxVGW-s` z7=#;1Rm5I$S{cRD%KA?88h?ktlvt^KPI(_OD!x|KZ8ygCiwk?}Y7R(}|2T%lc4f>i z{zF?^y??%cL`hcM?OHJ4_YNXUh5*ATEV$~lq%DW*^Ka=AAGoB%36r7_V<;0d$JYl z)4ybAbE?nzG`Rg+%i7M*0#)YwS)8%)hZSOt#D3lO4ZS!R3tkBX(d7kmh3nx+mdf^=Dkr7o`l7E}MUS$Usz0QeGhTb~UUu_Dtr%)m|*GrB{bmE-1%>r12@v`=2F$4lIiQ%vLAxMAE9;I) zOA8~6=-?794amT67Nu47fYT-23xerhT$vgXAU^Ba*H#@W>rS?JQJqUhVn=6V0mFi( z$)PiinE-c4$bmzZO=G_H~q9Zm%#&?8g%Fz=pz}nwTkMk_w<84{T zh9AbR=005UUlcSH38-+_sBbn?R$JAfj4|IH?w(lnBWhzU;|TP<{+^v5B)%j5v<9;~ z4l454{_K~Qsq_zA=bP_|T+wEnZ+CHvE+_Wfecmn17lGSvO1XJ;#E?u?h)h(7s1#x8 z(vI91TNoAc=S(m0;mJ+Mup7lJscvIk*=fuSL=)6`dbZl1>@hgkd!#SSYOi!^BS4@R zH^1A9=xtC?pepXqJN-+lD@swJP1JLvS+Avhg5U@L{`sag|5sZCgTk%MU5M*5$IM&P zY`Rq0jmWa(9mPe!r^iq`X;4tVjd^mvYv8zJTJ>OFlKJb#-BAW;tvQ(ynzVXai3l#K zr>c{CBt8VKGA%QF&gpjd*HEdUAH(-6*5{MW zr*VC9YfVKwH!Vl+Pfxz9zqUQJ>8sWo;4n6$^jh^vw-k4x7I57)ugUG#{rAWM1nHcv zu;m!}0-P#-%Fi8xm7Hl{drQY~Ue9n?$iAqfG#e@jKv2BVehNh00h8iMMcE)J#vdk2 z9|eyz`Wm}(LtJ8azyghQ4F$rWK-L!t&VojhDkUPk8XzIWqUFK>la&yqK%CT+a~&h^ zhTeSqb8K7Fr7MP4z3tl2R^jo}+WpwxgD2Bj7d0P7m~Z`p4#PhMUv7O@8fjakUmZD5 z&3HP~KjPDJJ(qX7AqeMIlYQ;C>wjUqxStU@4XO+FzXAMzq zuVeMM`m3(@?q6uzK2#+FO*0Y^=T^$ie7< zn9{qiuzLq*KQ6knfIhu#YeXn6Xt5RUuoR8bZF~f5w(Yp?+_9PcNNXF93!O0 z6%~pxG%CBen4X_6LnHzMER#io0R*kYxOU~$ z<)zoxmfl`le062!<b zn3vL884K+VQ68349mfW1E9%R*)G&{2n3O6GX%`*awrA^|iJ_`O;ei4{!_F;p-L3b> z2fyCFgxp$ua<=u-@qHi9pZ;>T@AE+S>-Oebhxd+c5ue%2ovqw*yY=Yp&f2T3hp)8N z{x;J0`SRT7<@uGXOUQ2zkf#rj-|l>SczxyGCCLYX*Uo>sGVnx!*A_VOCgHn6taNhLw)I?uLK3>MK@q zu&t%cnL{PRdxU4J3$OPbnLfCAsFcx8%N#3V50~dHw;kUpU^2*fh`MARi^k!|uvi2N z1qH=m;i1ShG%(`vNF_y_q!@n<`G0E3%EWrx%y!o<_SDU_A6ag%nX21go6j7pKiIar zv#6Fee63b3M&YSpsD#|TRV3PZVVj1)mpW5pyYT~)I2m4A%&uo`cze!4L9eBtc1 zuH*O5w!XhS`TElNH&S(TPu0Jl9eOp=b-8Bu=dnIy zc;M?`FL1eiWZ!t1=u83Qd_~^%hCSC$?D?gm`j@Ul4||Ti8E^kOe->GufGr$(bszcT zF7o)Q0sTx?&@3Zm6uQMUaZ?TeYCW97q4YAzk-;FjZMkN{ZOaCS<#tN9%7aN%TD|LZ3NMc&%ygvr~sp zBqkpI#!*9wP5wBKNN&uYUWu zH1XnG*W=E*dkqIZpX&xLpZdH0Y;C-Gc=yy+(O?mMteiVnRdlUx$JP4sTg?^E2akW5 z>3%

f>Z5a&r>-bs2ehQSuq^?OEjZXm4|)z?Ik9`@ z@aEzD`Tcu@jV1UxiCD6C(&EbL2?ETfSbrNo2V*ZgBTH?iquUA_%ES%%478IG#m90t zC8dg$F}$7srl)R7NI8)a+fK#YZmHidVl$~2h;{@aonFY5A>z|1q%6=29-oOLWJ<)s z!m?O6CLLA2ncG;sJ<8iU-rMR@f77e0ohtU%&7kb~$^u4;!|MtS^ck`z|Eew2Jg6dyc?0-Gp{Krt; zvw`Ek_18Y=I=oz8alWz$R*J5joN8g_A%4a|L3%kYww#&B!)yxoGIumpw=vQ%QI%`0 zu4v!8WxBqyf15Bb%DW^p`~W4bm4&`tRsQ6__STHJ%IMJRjWwkdRDp<&=a9(7Tw19> z29Hf)FwtBtkwVDQ4xni$Y7Jw!`;nO1MMD6b-h{|TJAXf>uAe|E5k1? zoc?lq=FR0X$vu$QkC2xSkrxk;+ZR7AO+D;xegSEv`RMcZ`d6JzAA3)|Xs*9|Xz!&x zTV~1&fXkVD@|gnC+&=N$#vS*XcHU{&_WDc>ve=2tw7x!j{PjfJo5}9KXL>%uKQVuL zWpMym8bp@Qew^-nHGJaf>0`fkAHH*P|H9ENla)nd`}4YYGOPJ1P*uY8t+bdjMj|68 z%-ccF-PX|7SToe!uD|}!$(_YV1*E6vPVK`dQA3?-d8p%rVLb`|7x-C?WKW_H^-4*myj1Xk+=7e*T1}*AAa25^0=q@QOog%O*MaZ zG<`hN`Khn{Y5kEunrj~(tD4_YGE%^8r=r`aIb)ldQ`@+YTPweew|p3>LoT!-S9(58 zG$0rHzD)N)PraXLe?Q*&Zma|9@3FSOMq8f`)III3dDvNftzqZV(Xy%iqMkBBb6#3w zL0VG@3b+&#BSnN5bW(tewU(8EilwfizrE4P16#WfY;7oE_wOw{TUl7eN~xqL?#>Py z-O9UNySGn7Z{kqfw-ptTF&rj=C8D!83xr$pWiW(TA|;tZ&!Et9NR(`tM@$}_SHLE- z2}~{?hmDU3vg4!&-5ESCxo14m_;UKx>-p{vR|X{y_WU}JJpKL{!*9!A2k+<4J|Aj- zaH{rB{h{AaHU8Dt{<5R#&(``+{T;~Yz%R!RoG%iM7l}Hk_ydWXT8Npas96(btd~89 zk&Au6<-_RFujiY-PPTuU==?n10mrYCy{prwp}x+X1}=Z}*ZtO0^PuD4mAdV-hYH6k zxSd6)mV)%gg4EjlwEesk5Q~TupAqftWT|0gsAQn@Q&OOFNA>om?ZUz8vTI#6=c)>u zO9{J4k-Sjb#hUW*U4@mHl=+4u+sJ4U1bPXd~>1e>y=^2r1*6Kc{GpQn+3o8 zYj)u8>HfdZ_x;}6bg!ZMd1n)H{w#7~44D{Q9UefY$KLd`UERNXW?S*OeBMwVd!b_U zOB0gV%thk^#y7Bm@!+(QKhsbHYzGM(80}0%hOihK;Z{ICULl-avwXl zeLL?`^Zx#woH|iveu8WFX7a__9VfW>W-+6qyeJQo#se-q3cr}gFBS1iL=r9-Vmt<) z09-&Xkn1>n8b`#~T%OMtQ=>O|xLT?4a>8y69>3Fl2*%{w$@X`%-JciFtS+DXc6oT^ z%JA3a5vcdGXI_tYzZ>s;bFSl;#zXh&4z7;&f6pWLkcCNP=>jq}_OP*bY;!>yjo8bl zUp=t%_R+ng#jFly_RVA4kc$Jz^&w>D6teLBcJ)l}>Qs*e%4plGp%Z@$)IaPva-(^_ zq)t{Y)Ra#gD1r^3vy9rh8B<@Fy`3DDhYHCf#9$MAgIrBuNPF7oXs?sm#>_oiv!ggG zd`nJP126kj0qz(p`2aEMVeiqdVrl~yH+^iMC?mFzn#-Z01!9(HOCG;e%*yBghYRS1 zM9Gp&A})!|qk_eV!IoK=Ab&eMV?}00$jvi#cYBUL8*F$p-u7;y^W#*{`{|w!GrgZK zoc_8vge;GKTN?g*ybGYb=xe@Hci>jdzCXK9tWKO+JwNsBOCj~5mfP0QUKX>wZf8*P;EuY4_ zz#XCOSLOzg#dFA|QDkX&^}^tX(VoZPFLei=w$}j{Xs8#xr|vY?Le1>i(J5e`WKxdf zP_@|Hio~c>Oyb<0vR)x|cVbAdi1^o;6UZz;IW2)Q-33PTZlndg_Cb5~jpn`AoA+Nh zx^=c@`-S5bLkCKFc8EH+3tG3b5A$i25}sgN0i#d=tAGrK zl1QYb(3n|Fwj{Q|DgfIftke`1jxVNA$r)jO)@h-RL$%wlb{&3vy6(5`+BavKKaY2P zn?8-q^n)oPvjfQd;L2=2vM{tV)qlUadb*-;et+rBV|y+is+ieRK3}!(W<%{jNkQ?Z z&2B$Ezw+LQ=JAN~ zcDLxkkanv@aDTk*+F0wDo~PsD_>6jmiX%{S6>Vxwr%7Vg2vu?fTa4w&ND?_ss&LqU zaJt}k9j`q~Xks~oL95G13@A%&-X;&GI+xeV<)j|LM_%pI$x(@%^JSU)??R_bc-soEd*-Z4fN~l|kL* zVdK^Dw#`1nO1pZkOLwZz2)$;?Dmkv_Yv{E#xv`~b;Z-@Yg-O9#;a(LFLxo>Zs`TF|lf8Rd) zH(1|+o_cQQl`A_>@BZV$BIMKu%Om=tL~?|yIzM)lRx` zLG|59>sGJwY@hnheBZ^fw&hOE#$d}_t8%%=uy(wqPt9f57uDw{W=8tpO4Dod;tJvd znsTGtxb+tt-cNpOShHcGZMAZtY+o5LPbe5|Je*cQkcpc`N~Q?tXa#(|L}--DO)9lf zivY23r9^>*ES6D0FAm8_Sr8%_gD<84m#WgVtSFyeCG+jA#b2D7{NR-RFK1>yJU#XG z&5dv19^Sh3Q|5iL!#E zWi@ABMsIB>f^|!M;f$CvNNX5j;T}%({Pye$3|3IQcV6HA>GkceA8h_+bNrpvzW2|K zKALZRw9s*`PkzG6JJq9Fu*qjElGPsLs9rSHrW!R%Tg24b-1w@Tcyv-|PJBQ{v~O`r zNE*sT(3rP9-TrvB|H_E&e3#_ijZvtzvpPWspQPvE6{2R5l)_aoxN45TAQtJRQiDQi zRvWB(1Xo4^G&~WBFCxJx;FuU?Oqqf$QLvyxHIu9G^#$l;l!1kPaB}jk^{MwER>$63 z9QxbEMJT{Oy?pt*`{$tsfA{iv2=E$zyS(tqWZQ*y(b*Q>w5aL4O?k0HGsee{@^BME zd>^e!S(dWZp%`G)_0ww?v}}D%9wj++Ud35&Ro}DsyuCR5n~mwu@1NcIuUmh;vGioM z|LN(0n|8x`r(nUtoHeo6d)2^Y+A5iCQM7Ofy-IeMoM{zNiV{(nocM~|_}C!V#87vj z6X$=lCOb;ctUfiMyFAgl*{?n`pc@cV+Ih`-E^*h-FAFBNMgGObi? zP?}rx2)2X(sl*Wwn4BgS8^`C9A(fzEJ6^*VQRs|%Qd22B2?AXC?WKv=PENkDc>JA} zkqZ(7XS)~9~$Z}*N$KBSB-G01{vk8jX4wiM!Nuachquw z%yOw$(T2}gR3x+#@<+v3V^eMmv3P*j#K?&j~{G2 zSsS=9p+D0rva1PG2J)hfe{NX6+@+W_3&! z78x7jo)GSlpA;P9cNklksG(OI*|oyPf>u7+ETrosEVYs&)9?fus4RT0N+48=#0sHQ zAylcwdXo~t5)*k+GFM1sup1f7CLW&zTtG4$0ZA%nLQTRo7H7oxRJAT{V z`FOtfS7&EF++K$E^y>}#hZpBQzqj$jtCzlcdF!qDu6v`#(-w9ME~^!v-AyT;k>J{K z`CX&}Woc|1A;*f%wBRx=gzRZ8N!ye`$qpoB1eArll!Uop(}HPvv8yB6CVf zd2MCj=9GD@opZWJaCShl(8`+7QRb{%yOA?#m`uQyrbPIm`{rbi4-rRn=+JCW20=9C9Q_(>|TZuWk#^iQ#?l8MdSrR5e z2g!XQ=f20^EgD8-j>8uJ?q6SCuwB{|UOu z;R%VT$Y}rYNPlFYr}wj+V%*)2goOAB1#FpA0Lj8r2#*7<%idR;8pPm{0)18&yU7H^j)`2>@=|z%?$mTR}W}ZJO-II;>@22OE2{9)v zBr74MgPPULDd=G4i!k99S}wI9s4~H&Cf%zsF9?(7>$wNfkQ2%-OQ+>0QF0Ti;*qh( z5LF3YR#v&NF4e*+SCjHJ&FB_Rm8jma&p|sM+b5@yiV~}{BI&jH`AI?Pama)ypTzj! z;^GW|5*+H|?dKX19qjAxe(=bP2ami&rV*rakyIrUsHJR`n4^^njB>t8#1gXjJf=*@ zR>G3oOrh2xIGkp&mpT8@Fhu0BT_k&KyUQEkOkSW9}y;`J@I6f7ulgSKn$7WklqSQ( zcT$Qijk)a1FkViywlceoR3WR%#6){i3S;pFQG8q;wF>U=SW{sfu`HR@fUZZ!C8J!^ z!@Y{r!y5{d1jGtXQ?X-5ugdhCa2ITTl$KFLug(MKQkEW7mKj%HoSmN@Q<|Szn3oz8 z8R+JA(8+19o5vw!fQy^Qf&B*&s8An)2@Z$llm?Sdh;%nsWSn3UI*M|QY02ia6kTkbHacD( zohS(m!ysPbAcI6Z$G%+Vt-N#^X^gYkFG^x9h(8=MxkNOCEWC4}wI-LyZM4jyH$N1WX>C$|eC9nMMFyfDxTb<_K8`Xx9*qmykph zM@YyleiNBd&Ez%mMFfG6K&Dgz7ZSc4>3M+OR65sXm^8^I43gt2P74d$kRC=YNaU2H z<@+CzRAd?&3T%XOTT_W3Gul>zW=97$x;W#VT=>XfO+Cx2{c`rPN@bNqv z;O80|?Ct64L~I5V%NNPTpchCbI)@6016;&PE~FBO1<(j(e8=mJzy*xIP)y?ro7sFk zm06D`movBxYyparxZu{;j-eYVgky- zJaGvqMtWp*kXwP%i!lfUKFA&K=hjnNc3W?H(mC*Ed*9z?PkwY_{f{Fj;JS0+=J#7y z{<*aN@u`h}oId^W)|tOJ*;{zmqPI*ZoX>mctc?r4ck*ww#5erAGF9t4gVcx+$M@rEtgoaY*!_T90l7sx+ z{k)xn0)1%=DsbV6A-F$t*{v@$4)K4qqn03`;yNUw;)0jsiO4J-p_$o$C1WUzIy$=% z%pMOKxqzfnFbneH^U@+43epD+@?NE|A~_-_#49b}SZS1hhVPM*5O-e$B6bg=Io5xW zSas1Nd+m7phwJmdTbNvb{;GqwSr@#1UbMxOfukF14=%ek; z*Cu+_4T9}1^}LccD5xJ-H!rja7TP73X1dpHSY*1osPz@$eEu{mRGIRo_ASoiiIo#igP*W&i;C$T<60ubwL0;Y-PI2*( zd?Al36g=DClLcHLk0>l6lobZAnasoi7oLO##TX$HF%&AkMkkc3xdI85%_maWO$1sk zkx~O_SX``BK^O1{1|7e?COw{a>%%+Uu;uN^NIar z%#;W>z{a$Z^ZU6K*5=$X1$IDEug2w^9WiZ;n64}gzH)h`-y~LXNJZ(<;YimY@1v

;8su(VLoyxv(2I))EB@^lpgIHk8+IO)wkK(=M z!FT6-Zg-AP}z32eNb0EiGoF)q-y(i4_v1P62h7 z%phT#>s1CBlTU^|Es${_j{uf~3nY<9#sDrN1&br101*fVj|giPk4U9AusK+;#?_ci z;8IbTRFDx~ksAyCGBv_o!>u>)YWWRWCwmpEHr~9RvZNtxn(3Q*$~*@%K+LgAY6pcF zeo>eV6AQxuJ3pA5>Os%+F<_I0rNLrM2sPJ*SL&_7h4%bU00 za^J&?C*}ssJ!a|5a0j`mB0j=DEZ8$QGodIyEi*L+>G-%zKtp3?WqCfKshm!%h(I3V z;*0a*{qzFdh1Icko#6KNMmWmnIRs+Q-WPlW`~?zmTW1HAMWZmu3a#9+H@285R`Tgw zs4R}Pqa|^uh-VuzIK%>IV8mn#sbn^uEv5;<0joG1K{J6=MWfdVgd`lcC^;b@I?NSQ zl!&d$&PfT%NksCRi>NgzT4vdx8YifVQ`aZYtD9DJI6J@0&Mq2f6}DoNZKQN!f-^PM zy^W9|E<(Y=*bpx%32KblD=9@XvYZ4(9#V{#u+&Xihw2q$bX2t6${x3JmxqmywwK4c zG{fEc(LRe(%H%L`1^LN2nF(Oq;F_2i85SN?RGe2*nAucagsaYjUPQ0WHVJVy1!byN zTT_^H>+^*cK02K`WMWU1%ta>_!#^N&^i6iGi9{tRP#-<>21~KSG zD5Xo4Z0O-Efn&E`k&3U-N#t4~PedWp>tSw!!J0;`DlJKljq(<->nlr>lcK#M0uN;; z_)uz7yS1cFdA*fYG9bdt>ae52GE04&t_-Cu594HcNs2=V@lN=-qq5R4ZZ49R=B2NV zmzJWiu?HAgu9})qd4<0mgOrwdwoy|?_4olDX>-D2?+~A~w=LOii<4c8)4lew4y~Fe z71K*fGHYszb90j`D+|)o;}er&LqY>d_&PeirZ^)?!@*W(ho72g0j9G9206Rw!sf!o ziyJTOdmixu;*gsw;(3I#n`>uZm$Ajb;xnu2F;Hm1vw$EVkN8qHJaqUMtx=@V@PLa% z&XKBxbiU)H2BDHC(FnokaD`-O-a-)tx)Ot4Ln4+H7bX{>6QMU1<;I2}57v|>n&kv7 zw~CKVA2U;i6!nU_STioEkD1p+N^QrdaB}<`qMYj@j*?S+7&$@sB+t6&W8`!{PA-av zM%6_glvhMBvOUeX#4&NnqLnyiY#y_5Z=V@GHQlmoZ=D)84R)y~M%#vmT8t)%*(`6w zmOHjfElh<)X<2?kVoXAOG`$&1Zp0L(gkv(pwT!B%4spAJIAGy7mZd+udui>|0=5~C z*t^FoB*e|f2k{&t8=V75M4~x%tiX{QcDZoHbf_;Ph2tH}2$_lvA(FCy0^p$W$Rq}l zBW80Y9LK)KJhB6sl+NYhStiT0Q zNi3m>B@_W42V5{1G^m%_+(g>baG{%~{*Y5$&{%HQ&lS)x{Z?*O;*> z+Qw9Bacot3aCJr~1i37YQl4Itglfo-tIi0Qk;=Mc6q^{|D<>`X$j{lWV=dgrSLV*I z_T9gF;`)V|h3WQ}AD$cNH*9RqPEPf;wQCF}3782owXV9hpb=Zvh{fdR=T=o#pfgg1 zbbNJg!g!l})XZ7xS53AH#pDu;lK%N8zlXa$J~J*f8W4vL9&kB!%-zky*Yl|B5ttim zo2sE1!8btNeO7uI|HFmNCrQ;@C?$Xfa>s$jv2Q$Q_aGVgJ{GqbtguSMlgb!0XyN#( zG~hyQVlr`F9tUuZ#ph1jx6e*JxVrT8!TQ^GmM@)XTkV%znKo?>NQ|_?y1WQz4Qh51 zIw7zkCx%>`Uzi$NTa?^Tl3H7s)MpW!q!fFvcD!4?JZ4=Ovuv&OU)~r2D7UXJUBA4z zxjwP7I5IagxO#H3r^gIFOJfj0i-3l}RdR#s$0hf2sz$Ia4Fi+D)SvbPGB zj_c5ge)d80&d!%5RmGcEFZIsNAYOdY#Rv3)gc5Vu*$L=CHgSY(!n3VT7(9w&Ab9qP z8iXUM6l@^k_-vBcu~E3=upt41&ZAM-WFnnFVK#%<d{uRQ5tmOYDa%Yw z387G{POc8mPItWb^v07{&)>N^zi2ld@8I7#Ke0L2GC!z-B)@!We56BBUz~`=WQbUG zMcENFTuFIBJcnAvXVuM3cAVdw>hICa+S_kkU0GY~8}3oPcK_U+?bQn#Gw0T(XUBSm zdt0U_`Z{d}m|6s4MlH6oiCkaNSk4pD%CnO&DUsyT?0z+OK*Jfgh#+Qq)T8Zk_rr+K zKK|XWe)BXeA>!@d|3=nsLmY8F=I!U|=IsocarfT0|6qJ#f>y5s6O1R~Br>5)A*M1& zDytJtdON)lo+?ZF8fvGF4s4vCiD^pSK#SuP3N_L-|Hs7vX?A1-Q%1+t4kjI|y>(K7( zd}E&-PsmRF$G^X+Xl_2@7x3Z%r^AQc{E)%EenE$ixB#8fvWkw*ZmC=bAruSDRs$B_ z;NSvck!nS-V2S8ZQ=sCCRU#<8z=g)8?H-i`nYDX#kxH+C4lh&ku!L%;f+tVSEG~`B z&JEnTb@q+duU)ycI6u?<`2N`^uWg?>IeLD5;?zvf%TL2%NLd(KfHKm&Hl>$3s*0!Y^>ThR;RYsPpr<5^>i4z zY&xr1USD74*sZV$Q(apOlVM3hKr5%=M7w;cTRURpFAbQcx^>jLqS#QM&p!I_lTZIz zT3tFmKlAA66Ld|@i%!Q5I=LTq^6>BuJnZD=?u9&Z%H*g z@Nn1m_U7xa-gYXPm1aaI zhx*`P(i2jxYJPva_TkO*Lp|nK?r*>G%1!%d*Th)YJ5L{Oo}PoUa&`Ok`r6FM@phPi z_-ukg!f2=|Y^Xw)7p9e?Q!8^5Oq{x6PWcsK^7ZZqDxB-hL=o59HqcPQLyqA7n7%g}ukzJ;ZW_-fUv?p+gB2 zS|tJs3RlX4Bmyn~1=b>^5V$}pIrd-`v1MABR3n82{J$J~jY*qH6=p;Q zU~-aMRl**tS}SI1rL2pm7xgmk&5NgRZJ%9Pob2c@KYDayV5q&j*LwNd#=x-6XqHl_ zbz)(2k4+6jb3}WrqIkK%(MzdwbZ!|@t9RG(kh=l-ky;d&gW1+`|Oi1zWF*n zHPzT|`+jE!PoYF7CLVEhJ$S?=AUG1xc=`l^UR*tVy^(?YA)`Dz`C<`_2r{*t&S4I+})NFs>cqXwX|02Dw2i`~x_YmEjflfi;vT`Fm5vrbOiJG zU-{FAzkC1Pw?26P>ASyp^~Tk6BZD1NBfZ1z#;I;gtBgmjE+N;H@Q8JJiIMciN~>C= z6|=fbnhuj%E8(id?5*|1JJ&Cr+g#HdRF}86`UX4nR(1ba7ffwhi$ox9HW~Tdt#Vpp z5w<8*g0JY6F`vB}%bRXtcPohV{ko-zPJCTyd|c%3{_tC1VeRS(jEMf%&d!5ZUQbF( zM;8|%UfAR5697bSjFC93F3X68}@J8%;2^kbDRjNQW5C~ua#YL`{fKtHh z!b8X-zKkc+N6@N{fssY-WpyG9`_}ti{!2SLQ@E7pL@!sUtGh zn36GVWzDwp=6mJcdd|dPE7HexWqtMAot?+Oc<+#h-?{6zzxr{9E0VJL0%vDur(@26 zsE8vjUQlJckSI6rfTOOS?mqr5o<9Dlu){7csK`iTYpd35Mu0#73g`tYE{TbUe&pCd zUc^!vl}dwSZ`IwS`y2~}ge~O4Y|a+2q$&xGP1WjEo!z#XdHcxt;QWcHjm?$UUVm`q z+F9Uo`O4YziTBsN15IakNUFkku^a(>hvp^MMxUsytvb?%9K0Vgf(<(EHTlC&d6aW!X5LSJc- z4af<08*jK(usG2k;Oi_`i2=%&KkdZj7B?~lU+?T(x%((FEeoE*=Mm4LP$(xC&qK~0 zenH{xK7oM79~B8HgbWTl=HYYH)#H$}D-wlba0Li3a=T4>_Xq|@ds2%biGYh-C)@2r z(2^X&Q8^yM04jL4(F2o5r*WD)``eb+Ps}XZr{~5_EZHBwcIWijh5!EW{jEzU-+c1$ z?AGe?@>F}f!C;V$P4snlw~#5=o3}3a^|vo9&fI@=8-Ok>&$79UshJ6lPTAhsy0x{{ zKR7TtKGNP}(^^%%BQ{HyO01yd=0}zn#R@5yK0VvYY8X{8w|dQEGTK6ye6m}*VsFn( zMm088e82PKC;$GQr!{$pCw%h5&Zj@@q~?{3j879uHbHr-nf1L(kpM=e*MY4^Ox59huYy^ z$7hDP0($T9&hwWx3@w_Ct@Y(oi{LT`M*7C4Mtg^Pz;|B1bHijZSu7SXTCMG7wN4Dv zyvE37aq60hg~Y~O4z6Hv$hg$4pV06v&9$rDhE5f2cGxWCVe@knzWec;PyY4QgZ~qW4WDu-9d;{Q$P#R?b z1)344M&GJ2v}x5Q6%-e(MFWxn5Zq^b#wZO+ty!-zYhc8ZsCY0pKu}otvg!f?wV|WW zy0v{;WsscQT)6Y-+AD9}zxCh>d<7P3XBJPaPF=Zm-e}V(bQ1Vo9eu6ib0b3&gYX1& z4R#va3@aNeUiKTUw>0CO7MJPPpDlzf#HZgT= zpyh;3Cul6abZWYzO&NeZ_TDd_{QZ-Eyz`q64taRB58FTae&?M({0;H^!PnmT^@x22 z@!X#9@JJU|PY>T9XU_n4zYtIVFjyS(3iLpRy7~me+SwEN>?{88MFil0iVIu-kkO{o zSd<`^XBAfjlG#1^5AsNDQd`*aSaljDktUAz9 zEv_~#H_Zd-(cafSF*m_e2u_?lv3hQ8Yx}}m@4of&tGC~L`r!1LrK#EB`lgCYS2owy z=P9%%9-j`LkVYqg{i&<3tga~!3lAzO&PV5_sbp+SQD$PeZ)sKxtv0_+PPK>$6Ya8I zJr}&JP03oC=#_Dr=f?W(-nhK~$bpFy^Z(x2`Riw&me$loCZ_ueMp{;!o0FN65F1gLpXKU& zC=ltDmKdFq5So_}lMxqOUzDa{H>qhgRvz|5x5nNgX_rz4&EhVjSTE-+&5u5L^7!zv zBXIw}`{+|(!BuGX9C3Q|X-x^BO-t1B`fC@S8?HxMZ7a)AYa z0BLv!MgWwf?v5mK@kY7>+;JI=BE1U5gsf03a9$01Bki?on(|bO8z!U1OWkY_l3# zOlqUCq_Q#~BpiA^bTz2no_+zLQLzExQG1U#JA3&iW#y*ip-F76wWn`>W##PIle3cp z6C+)qg0TUcQp8A(2`R`*iVgF3IkX4q=2VuK8HV&qj6lVP1O#|E!CaG@7RD!6adD*p zVzEnO<28*Nxb1xW+VK`Ovx!NlI=N*3??3(;@dAP)lYYLl^Xbmc@WR@Q$2`y9y!*{h zJAeQ5)1xlOY+cl%_F314Hfx~{`vEIRvKg(oSHJ}b)0oR|yJ0KbX zH!n9TAT^|Vuqr~a)^YHfSSy8!t2AkWg|XeL)N4sBdR}p1SWL{}V{XswJ+RyJpH=ms zps*-^RJaEc6%-M7z}dqqAQYaKLvG$LIl0|_@bbv$;KJOPNhh}GL`FFqgHFkgN2Nsu z#sqt%L;A!CAkArer&Dd7PHDbeV(sHXA^LV1RshwV|(4a~ZJ1%0wrzBbm;reG`i z)OVh|{P5A87Z2`O zuBnYr&qRhtxcDFsxVnQH;kMm;gFK<71%yI8t5Wb2AvvLv1^Wbr`-OxfLnGXgfncj4 zpa1g7XX7(d@4o+ZsNXi+V=~GpwdhzzU0!J_3X>IuPDW+L1p_9yX2k>)C5P1JCp1^1 zsWtg(R-;8oY?YF13Yt+uZq*9aavq-0c=zFhdygLHC_C-QgPD)Pxm*4;N_s_qYU0FlCu;0}$=vkmZEG|ftyML%hKp2E)U^v9? z`sXkH90-A0s+X;83X1RziQcW- zfcZbFHws_@7hvS!ALJPj?B*AMc2tC^MMKm7UkP*zSakB)RGczCpyiK)+z z#FZpg=Eas~MwVsAmSshiXGGNH$2ViLganM7UT>4p+vT)DGk>g0)uQDobm54mg8A zb`iYf$`;Qrh1K6&`?`qE6_>ABuc z4b>*a@o{K&V?MDe8(W@%!{p#9GVx{Uw3<8tp`3>;6A&>bKCx9o?o`uTlr#mOXfjA% zd*kunKL0E%F*!IP`B#7ZD-_gM-gvTS-+p~-`$U*t>u0>h%vl`sdo_ z$sd3GQYWWhS{s}0Rhs#ARxwUQa-3F2tuLTAmC_rF=yhlwu2jjWmy&CE_;Ra=eB3Mo zE*wG$aJh1M{ktFjm6o3u7#;iPFTZh&g-?C~R?TW_|MSP6!NZQBVZ;kB{`yaU`PR{} zzm7~wKj7jSpOJgS1L@=y;Dd@f>gf-naOnMibJ@NBpSggP{xkj;00030{{sL^L<2Tc SG5Fd50000zz`*b-fq}tl1_Oh5!JJ)zHb4o^0*}aI1_o|n5N2eU zHAey{c+%6wF(l&f+v&Yr4GKIhwI%ayels4tW>)@c&5B0BOK)z!HQ{>6DA?!Cp~u|r zar(x_wUWtu;yERh+-Ke>{$JOT*!TbT$L)`U-+r(stQHDmFjo~|5M5*%z#zEjdpkR0g5s9F fecP6DCzY+SeSctyMj@*-&{GVau6{1-oD!M<%D#4K diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/mad_hacker.png b/pkgs/picturing-programs/picturing-programs/private/pictures/mad_hacker.png deleted file mode 100644 index bca2e7670ed7390141fd82170ffd338342cc8e32..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2475 zcmd5;`#%#3AKu)SJ7caR%M@W8wuR)lY}kfom}_h^_q*o0wHOC;d1-A4;mkxsDN;wB zB)XkflsZDnB}Eina0;2@{V(3<^Ld`<*XM`t_xU_rqK}8Nf}R2Z08qwxVn};#{Xg!L z-c!nJ`5pj3YMtoikKNtf)ix*jyW17U5IacjT|4uU6l!l6IVwFjoE9c0CEr|3!`RzU z(FTo;jc}N8Lu13AZzh`>&Lcg%%geZkfcoSN)^mwKW1no_#&qxRCkp~e0)c>@$U1cl zl}f>dhJ`^On!mzyAu0;jqo^%p_jk;K5J&3+dU|gDL3n3m$+a8#7#lbQ>`lO!qA*7> zL@Q^ElbK;_ON$3Nv#CjFprK+D+IGZP8-+xh;<(AdZUZ7Fj}=){lK*S$RkU|X2+7;l znc(M3gqV2R`S=}Fms2yeKi_*>$jf%X5%8&P3d&$gjGdPoDkPKrwTP!GEA2^(bF{ZN zG_!cc$fgI*=gGFj{J6jvB41Ws z1#^hk2LXd~3u>yXB`>RyjxOcglQVbDk_Z?yfyhn{I&NcRpe#p^jixdSYszzePBxuA z%U9FXla-bVNXw4Q=YBX{LM8_Z8boLt8|y&P;_MZ5^%xZ$tJ9IBGmnRH;h9NzTd2BX zLPFeNBt=bCgAf=JRbJQD*5*nKJ)#aoTB9$nzT^=sbaY{?Y?>!MMpg>QJjF4^REGqH zHcBKUsEi#HTvAe^q@)Nl(6zQS4@La~wV@RA8eR%H0S+)DB$LkMm|NRAK$M3Q6JPdur6gxYr8A<^Q71fC0RY)99LB{z`vQNAX~z$Sg1&?`g+;$a zlfY#pzsaPM@rz1FL-B~nOZ=sS-k<*z_9R~xUOzC}z)NZuWFmRE=K8Q#$jeQIH^OM} zbKLXzUT?(q(*|u(+!x2G?=`&SJl)(Gsj;=~kBKgNoi+4ST03ELx4g(J(>`q= zD*0YX6r$w3q35PoDaf|0;H~_|1OjdkdFAe<>iT%w*i3hA=V8}$afhRS^6QW9P|8)j z_Gd1P5!l_DwZ+z!2KF2Yx=x)cF3h>#x#pS30toLeX`~(iWAFIliyEif19Mxq?ZR#@ z^JU7AAB*oa9}iD4lO7+n;B!c;bF+f*ctPk25gXzfLMYR!$Yivch=o~cd0WGO-_B^S zTsqh5zCB8e#$FpH|MNHMlJHFG52NMk(!~d#GW~YHEj~mqwYbQ>$a`j?@?cPZEMHV@ zHO@@?qh80rKXE#gAf313T&uL;p6+O>^!eFFYuwf`&PH1IguBbj)s-+Svr8TK4qrZa zQ*duRi21xuq%kh4jGHb|{GizRbqx6p4-!aICx#Ky*#17YQCE*(U^Mtj<$;0BDBgB;nbbMU3Uco@ZI=AvFFPX>JR8BxDe!!FL4_vbJs!B#QT)eMce{S zcZeR?=?kbJEh|%)5xO?DaJ8?-A%6$L=~p+G{hfRWx3x3t5*XN7t1zB>vrlrfzMhf0 zSTJ;~I>qp&_+jn=O_wnsx4AD|#MX_D`0UqfTIY0TByy`y>eInc6_)NZcQ@aKdR$t|*uS@4($7!3P6815JF~ra_2c^Y8^39)Z;?p%<*y|Cu#n-7 zVy91iB83KTO>ixz7IS`}Y#J&yEqr}^I!I1G8?3rM_E~|FD}kx&H!M@HyQ!Vw8Mqo` z{qjY`A9T%5-+p!@1v=}8gArdXZH@07(*OFkgLNPAPc2w6*dCHy-kBsoAey-2Pv#Z|-+Qx8kxr+2%&q>gX}Ja~>j!RpNZk;$2{&V$+n`OT`Ybb+zhqdOM-;j#W3)pG{v;e6l_Zeef;;+gZ<@X-w-@*=bR>nO~lwK~69B@R;;rB6XEKsKuPCz?Jf2J|XrRp-6leW-o5*as*%F4>!1ySvhW$aic4h^I2USMdNG)(3ONmBRTKx_+OK diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/qbook.png b/pkgs/picturing-programs/picturing-programs/private/pictures/qbook.png deleted file mode 100644 index aefaadeccdb252af83d864939fffea676aec504b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 941 zcmV;e15*5nP)aN~RW6fges!mR$rAoVw6@4y&-9A&5h2BS>` zkfCg~#QfeG+l8M;8LFV)Sq4DyyoH2v#!j>h^h(hW!28r%48}Ntm&0iCEOz4vGB#mo z=ZU6tkUe7oV4mLq0H@Qh>-?RBG}DCn9Yj+^iq74eK?1iBB91~tMsc?n=8Jo`hX{Lj zYiNy8H*HuQ(Zn_AJ;B~GO@J^}mRbD>)8sOr@pyVl8`4tV+{M5xqN$r`FJ1InO2I?O z)by&;AqlO87pK<%Dyry7r#3eBGjbkL zNKc*U?I3AV<=~RfQs=r%u$+ zQ$vQ%CN&3#gSY_^z}04DvD+MDKZsJrc9~4YukHha z;^}p+(T=jNg>Xl`iQi2V20$iNfGsf@g&cXR9I>T|kk{G~qj>B`K~8x^)k<%k-_|_0 z3Mphy=2~FS7Xvi`L{mY8_-!?-Kr(~d?Ir|v+8Jcg%weXEb-{2ay3IuF4UnH%o0-MckRamL&)9- zHckf*W3K*)WG7nIYj;U1I?;s7d|s~%bT{yb;Esy`(pPQW)Gum`xFScv$XJiSJrDGC z(aT&twwtF`0*D=9ON!XyYKvUYb5s!U{P5fT>d(Kw8=vw&9V?!xG|=VhOnGfc8QYfzKk`DZ?irY87aVS0j=li@S(%NrF P00000NkvXXu0mjfg7LZ` diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/schemelogo.png b/pkgs/picturing-programs/picturing-programs/private/pictures/schemelogo.png deleted file mode 100644 index 1374f7fbd386974684ed2f2ad312c9ddabee34db..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4107 zcmV+m5cKbfP)KAa zT{fKV>9SpQv65CwwpyiZE)~K?chyEIiqbOsyr!u=yT^9+@BH5L%=>x2&+qv?w|U<4 zdjUwf455%q0016eBBFb`Qo_O)Q&evP2I`;<`ryc5iiOm`KtCAO`f+b$jh1+<=%zA{ z4Lc20*OQy;9R@pCqqiHe@gmeA0A_($H%`tjILF9280Qp;P=YufXJ$MD#l$iZTZn?` zG{l8?oH#j`;~XRBD>x@J9DD07B+RZRu2i!#Mzk2R~{?sQ~)n04E3^wLbdD zT4Ce{aqLXn5ed_D1yH^%ll7SZsOAF<<;i64_R3^K`_P!%0nT%oQc?2z^}?_^fKNTk z=ltH3P=^>0h^pf>wX}7~lMJR9Ql=RhPd7C)x3HRFV>{E%e)gQX4vtRF^IfP^SDKr< zhli(^w~w!{-vWRCfWU=xdQkA9kdRO`i^WSKBBPc@M>ArWEEYR9E}oN+kjUln1;Qke zSRzeMNli=7$ozI$*76nED_7;LUbA-H`VF~x`5QNF-m-Q3j)I-LcJJA{Z~uXVhYAlL zIeM(aiYzHo=|{NmxlZMrc)1R>goT;qB+EBeEi)>ui)_+uBW4EJ8QS&FYPBz!y>Mwj0TtZMIr(*Do;NWwXa? zFK_?WgO3Ye9JMYAF3u@wDy=UIE#GtIQl<8}oC_ z95FpA%5&M2Ac>U45m4MXVj-82_K7_Ae;bc0RrIHYiY7N@zyS%mi+}=D5Tc6!UZ3jXHD zM%sUQj;2%4Ddd27q>ce;5Qu*HsGfnIab@&~|7q}AYY#_ zY%)-hbl_imC}F3L zmkCf+=NX1kL{Y@3HAWq6H5t%p#%bJY$Y^ZMgc@rTX+-0Sh`?1A;a={&EEg`jA_B@T ztL&R%B`$SEtB%%a#)YUPbsOVSE!G-ENQiIW|D1EV=Rz`*JM(h3|D5mP{l5P@|FH`( zWT0EdtU{ghu2-8=2Qj@-nGeF@7`gI!?%U~1CD56QA#Z!{#~3oPGb|Ao zHf_fPjSepsdZ5#6Lg%wKyy*BJo;Kj`KyR)@SWJZ^aV+g~o2N0O^{t6`HDn0jG!W=xNA&^h zxZSh~;`c+>_jvlW4IUnMc={?Kgi9yk;Bbgwd#Ig+Du;(>A&jv*Y-1?4!kzGNSbpv8 zop}HK$23l)>>_oVIzpJe)J~?boGQiC=~>X4%B?Y#tuelVF#KbT-`TB_WjeGw4VIk{ zK?e{1Y4z&|%$Wl`f8Gt0oBM(=_Xu%Kai^Ie`>95%hPRYZ+u=4Vow4W!V;kZW2^b56 zI7klNh6f`@TS0_77Kyr1AB!>L#sRl(b;I1f+l4pZY-3t(D(;-34iaP!RZo?(hVp56 zCO%%YP05A~A{eYN=2|pQpKA*u0Dem1nn>U9;lPzEu>M{_uYbl2-ethAr0FiF>T?CA zlFk$oHXE;xOhTZ(xEsXAnN+_d{MVU*1`d?dUT*9Vd)aV$5M3kst2ohx|z}3;ev2{faVv!m~ zOz)f=u*m@V`C>ZBiF(z^Y5tHyS{Yb|5e-nxD3K-^CQpKKbc}`P(gcFkT46S>O~Ahg z4*KOVqFyFW1RgyC+ppXR%gQ8}&hI<$;K2jTn|Gb=e4&C7&Qwsv5{yWby?p}Sn`OX; z@N6qg){+oBv-Ff-0wYqCk|M)Qnk2)_oC&@g(B9dJwzm7o&c4QB=cs1F?CqXS4h}_9 zngmSWz6qH0TRnUOW2N3B)l8xLGCa3**q$&wYeu;D&O1_IWM<0!M(N70s;cl^R~Nqh z_Abt!Z{e`BGp@HGuqU^h$`!Je{q?)dqk<(qGC_Uu`lI&~Dm!A%URPEih(P9^Ys1Y9Ntz-N67 zd@L~LwTU>!+4LU)qjpCPB?23bax*z|1{gL>9!ro{)C=xEpmSf3ACE5&9l}32=Fp+P zqpGSAE-qDcr2Xs21v<9NRo& z2KEtT=dN9JrV@F1MR0Y^r8}ZlQY2UU^fBO9BYd!IwUPB=W~$;87|tjYQ&lr)Fiz8* zTMX2$q(Dl~lqmpbiS*NI@rrAiPF{aTJ)~|55Z-f+I?jJ+KOJpM-iYdk29%bTqNF6B zW@bs#Su{F(`v^J}#1#3#H^7Y5{?YIYO18r2`PSY%?E^INVJ8XH$_KYmFA39GSP1b3 zdfD2F?^qL0SQ`%saGPqSE^^!%s+ro)dm9N`J%2t*D=V?Rpn&U~Y&Pn2Oqh^FcT5D) zVdyX~EM5^NIpXaf!#eCQ1~H{9czfbjAm>{@^RkB5#eH zBCV-ZZhGn!muYbb@*D@EmjC_dglgu(`&>&4E}uS)D{sGzi)?P^8T_mQag4zaP<(9&tsP*Ycjza2h|1Dqj88Kjv3k10+Fh$h92T0&G%B~(6@Nmo;+PDKJiOwrNM z8x8RH^@W?;QY=|zpc}DDtt3fb2GZiHdkv~ui)v%4U~pfGO@12Wq@|%SCI)4bC!>l1 zM9_MwjuQKoR2fx7OE>U8i~xDcPtosSi3^a@A}i#LJaOQnht z4L#BnZz7A|w=_+ZXs}P_`M6jDXj4W(310)eDncIz2vJyO= z`{J633a4}&6F{wGtMGLF9X|W3FIKbNd#{r_ttMnMbmIF-id%2%j6TkKQk^dOT0MeI zJK*OV4b6v(5aco$!NXpM)^QND{T!fW@DM71@*m)c)y_k)Y}{K|GIK7LE?x&O24BP3 zBG<=81RMF?E`7As+rZe?Ot(YzHUlhBI(}>gN0-4rWD9(}!{NQiAKo7=gVzThST%Pc zR=Rs)#mB3$a`^^$`I_J*`UjoxSsxGo4XFqc5TX|28-7-{Fmdu1WiKFA>h!VoQu=}; zOAuhl#k#O8_=Tpycf)2X6@J`m2)tgqjV|P~f0W73?2!_&wZt-Z!>9wQ-BEp9iEEZ` zo1S%Lq{7&}MF%&;)=2^M<~r4XTyOhN#@ohG|MUL`009600{}B=Xv8L$<^KQx002ov JPDHLkV1mm2&9VRh diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/small_hieroglyphics.png b/pkgs/picturing-programs/picturing-programs/private/pictures/small_hieroglyphics.png deleted file mode 100644 index 047693c63bbe4d1578a87a42d69addbe4444d2d4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3945 zcmV-v50>zWP)F&MVgik(^F zXdK)~c5JWp^x}tNS+bG6f86)(dry*`q?=io1Lj%p$GzvAdwzV+xflKdsqW7`fu?DD zg{4{QR==U~X`1ag7P20;q(WzhfjKfQxeP@O(dJ!A1`BEiwTVMZ<*0ryA z__Uc#BS+s6KVGi~C^^3J?K?@zXd9A?+iTiJ0-(j9>0)0rfiTHZUQ4RfS2ih^aV<;AXySv9rfCle`*f0}y{6Dg`cjmK9^ag=7mw@iceSptg$;dv8 z3Ni{iK!DJb8CRn5Jbc<*VMirC9baJl>InuH0eRx)<147yt=@xQgQB{@I%K+iiurO%aM>i^r*M<0KbH?X6l+d7%TBK>O>x0GhBItR3{re>Ve(~eitC%015|fP0=$!9Y0i-D;4e^c; z$fjl`#2H}I$Z_Um2Qg*CoJ(llX~OmFLlzzY$KYxs%eg$sOqr2$5!w#7^6B`3OhQls zHOMDZON?KCQ<~VF`K%0Yl}bPjnwm7tM)5K_wZvwHQ04Nj414u^hu?tgm*yj%>nh@~ zZO`c2w1-4OQ34Ibj+I$lFG}zPFm`K^O9LIC=cP8!_C_4cA)^Su;`$OJ=OPUD*fBk= z73qrxr2hbTy>|HX)UAF~!LUujt{skIrf(3-xx13(#`_(Buu;n#Mk;*3GO3i&BA5pf z!x0k0?ehC~e=E!_nJII=Uu7;`sK^EIcvgTrQ`2sw2O>GR!;ug4ZI*L+nw60GOlV@T z#}7SzP}>|%;{)7@X=Qbd>3cgw!+sh1HjM(KlUe@$?KTp(vP8pv`l15kh!wIN(Z{Qy zkYHMBu_E+{Fy|y;uk9g`<&v{y83F9jWNYSJZ%~>H0BVp&**s@X3b-0mHkf!&WO6<) z&A`%d{8S5LGrG$WouRbe(n>NTmUlmjhW(6OFaeUDC*J8L-WfIr3)>oT*e;0WwnAQ7 zE5bct2F*$bN+8Fb`7CF9BaF@HBrbO`HlvfA-Qaw`%9Wd`+95B{aSHC0WU_Fht&$Wd z-WjkzR)aE2CNpKmW|mo8FS4A=bGA2PqBgI1FSFswqVY~IDWipHlle;n9rQ&5X6Cg+ zW#V!d+@!Xq3rn-8h>+sM#}>_{HPTv9*zvJOscB1?xpYC;zX^`=S6t6a1Y3~LcOMGdwg+GOngj$qm{wYW znKh`xBrNIY(n8ZC7usBdk4|Yq0p>k-oOU{VH3WF?dqoyZOArb&wd+^xvsP2 zt-ZRPBER~VEVamjl8MV*rVxUekqd1kXE%8FH}~l}mOWMVq&(x%0Hyfa`{H>T#y zRj@R-Y2<{a9ok%3U1M@SU%P>$HbRXcwo+)a1p~WqoS1gnp5sp!m>IQ^CEZzBm+ZEJ zBh_2aY)xlzYVJ{Xr>YdQ3fy;pbDz;E&6RzjMEKAlH`5?OowFFVCl*-2ve6FJo@{g~ z&j%k(Gx5Nnx&ReS+M2eXe=;S)oe)@&ri@74cG;M+DN6TxKLhVxSgSE zcV(=dOBeWL>b`BGPED(gOx)jK{OSo3x3c^6>O?9RaoQ)pYYzqKiv~nQQpEL9c8AgI z4rwjxUIl#{D4{nVb2GjDN)$}II)434CZ@BD&FDnKe%Y+C29TQ8x9K|MCz&Y|4f|zL zTB{Wx;YepcJ~ zAWf@{6{)-=uPLJm)JBIRif2b74Kynuv!)ZB(a7%%uwwe~-=R4!pA;F4<q3C8a9fpxY%(=1(rn6T;e(IvN}Ikj zpQSw%lwkb&J2A6aBPw&N=Qe$B$yGkN5u8&(G3&5~42}AZ0X3Au8=T znJF`P!fKOQ4(}5P@Nuz9)6NaqdizF6I?>pSZgx3+j82Ib!kzgn$$nKhj)`#}Wp_vh zY>isrePkd=Vq7P2xrOAc4GAh~;{JvVt$k5}L84*5#O_i-W>%C;hr{8z|M~Y1_99yk ziFcNWce+E<$bi*75?Sra&6F9we2feTq3+CQNey)q@7y5X8I(Oa^t`EQ-8?>F$Mg89 z7H)KU7jx*-F zv5YN{UE#Q{j(0r(9pC?1opZanntT;kr$F0W8t9Oq2|aIj@zo&RzBQs@zv;{e9crog zZSJ5s3uUWWBk}ZWKl->%|JzSlKKWBeh5h{0?OU@aR)fOH^gIitR=H;m!VK(!);=Kc zZ1SOL+8$I?F3!Usnx^eNp8W%_Z`~lf)mh^tjh*7%O>|*K?|sj1^E#7FOxa*`D$g`9 zabEy5XGp9(LSa!=v!)hR3b3*?OZ)Oan-$6y``W+BxPZ4Mx_xU*I|ZV|(MW^Xdo;H# ztm?(;s3tQxyCsK!8Ksjy1U}|KrVkQe*%aWw8q#EPq0|B_$veqRnR7>Bu*U{uM!_)m zT+AXw5j_^?j%}dhlpN!^m_A5=t*?Ja?)Y94PcxOzb>;@M4rQnowJhR2?*Ysb@_!P1`GvfA~Vj-=0OD_rBWyT%L2{ z7d^0AYmD;vhx;CrdmhR*9pCrx?Ejg$X9<|OdwZ{L^&8Xf4>A=ygf5@_>9Y?Lz6|D` zcbvk~EKhPdUJZq?HeUA*zrmASjw7eudf{Wqe=+pGw-9^~X3c8P00000NkvXXu0mjf DCe5F) diff --git a/pkgs/picturing-programs/picturing-programs/private/pictures/stick-figure.png b/pkgs/picturing-programs/picturing-programs/private/pictures/stick-figure.png deleted file mode 100644 index a8fe293b12d2c62cfb9a1a8c42cbb7e13b835387..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 370 zcmV-&0ge8NP)yxCAvv>=mK8FlX#9=wrnG`35-Ns z$=^c6qSP5*Gg!xbTI%h=ry(z3hqRpB_;Ir0VvZW3uqPp&i z*Ben@5XuT1xdlgz&e^L}OIYX9e#~4=0JAK#iVD~+Q4SK(r z*3^<@D6MfZEvXd+5Qbw%!?2i^)Z)1BO;i*6dTO30bC`~cwW)ng%<>C70Ju0@ku)>8 QvH$=807*qoM6N<$g2)%6@&Et; diff --git a/pkgs/picturing-programs/picturing-programs/private/tiles.rkt b/pkgs/picturing-programs/picturing-programs/private/tiles.rkt deleted file mode 100644 index d9d592fbc9..0000000000 --- a/pkgs/picturing-programs/picturing-programs/private/tiles.rkt +++ /dev/null @@ -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 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 as first argument, given \"hello\"") -(check-error (reflect-main-diag #t) - "reflect-main-diag: expected as first argument, given #t") -(check-error (reflect-other-diag #f) - "reflect-other-diag: expected as first argument, given #f") -(check-error (flip-main 'blue) - "flip-main: expected as first argument, given 'blue") -(check-error (flip-other "snark") - "flip-other: expected as first argument, given \"snark\"") -(check-error (crop-left pic:hacker 50) - "crop-left: expected as second argument, given 50") -(check-error (crop-right pic:bloch 100) - "crop-right: expected as second argument, given 100") -(check-error (crop-top pic:book 56) - "crop-top: expected as second argument, given 56") -(check-error (crop-bottom pic:hacker 56) - "crop-bottom: expected as second argument, given 56") -(check-error (crop-left pic:hacker -3) - "crop-left: expected as second argument, given -3") -(check-error (crop-top pic:book 3.2) - "crop-top: expected as second argument, given 3.2") -(check-error (crop-bottom pic:book pic:book) - "crop-bottom: expected as second argument, given (object:image% ...)") ; was "" in *SL, but "(object:image% ...)" in racket/base -(check-error (rotate-cw 17) - "rotate-cw: expected as first argument, given 17") -(check-error (rotate-ccw #t) - "rotate-ccw: expected as first argument, given #t") -(check-error (rotate-180 "goodbye") - "rotate-180: expected as first argument, given \"goodbye\"") -(test) ; need this if not using *SL testing -) diff --git a/pkgs/picturing-programs/picturing-programs/racket.css b/pkgs/picturing-programs/picturing-programs/racket.css deleted file mode 100644 index 0644698eb6..0000000000 --- a/pkgs/picturing-programs/picturing-programs/racket.css +++ /dev/null @@ -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; -} diff --git a/pkgs/picturing-programs/picturing-programs/scheme.css b/pkgs/picturing-programs/picturing-programs/scheme.css deleted file mode 100644 index 333029e5bb..0000000000 --- a/pkgs/picturing-programs/picturing-programs/scheme.css +++ /dev/null @@ -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; -} diff --git a/pkgs/picturing-programs/picturing-programs/tests/map-image-bsl-tests.rkt b/pkgs/picturing-programs/picturing-programs/tests/map-image-bsl-tests.rkt deleted file mode 100644 index 37e3e34745..0000000000 --- a/pkgs/picturing-programs/picturing-programs/tests/map-image-bsl-tests.rkt +++ /dev/null @@ -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)) diff --git a/pkgs/picturing-programs/picturing-programs/tests/map-image-isl-tests.rkt b/pkgs/picturing-programs/picturing-programs/tests/map-image-isl-tests.rkt deleted file mode 100644 index 47ec0e82d3..0000000000 --- a/pkgs/picturing-programs/picturing-programs/tests/map-image-isl-tests.rkt +++ /dev/null @@ -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." diff --git a/pkgs/picturing-programs/picturing-programs/tests/rotating-triangle.rkt b/pkgs/picturing-programs/picturing-programs/tests/rotating-triangle.rkt deleted file mode 100644 index 1d836d1d30..0000000000 --- a/pkgs/picturing-programs/picturing-programs/tests/rotating-triangle.rkt +++ /dev/null @@ -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)" diff --git a/pkgs/picturing-programs/picturing-programs/tests/test-docs-complete.rkt b/pkgs/picturing-programs/picturing-programs/tests/test-docs-complete.rkt deleted file mode 100644 index b205961e8a..0000000000 --- a/pkgs/picturing-programs/picturing-programs/tests/test-docs-complete.rkt +++ /dev/null @@ -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)) diff --git a/pkgs/picturing-programs/teachpack/picturing-programs.rkt b/pkgs/picturing-programs/teachpack/picturing-programs.rkt deleted file mode 100644 index 7e1afffcac..0000000000 --- a/pkgs/picturing-programs/teachpack/picturing-programs.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/base -(require picturing-programs) -(provide (all-from-out picturing-programs)) diff --git a/pkgs/swindle/LICENSE.txt b/pkgs/swindle/LICENSE.txt deleted file mode 100644 index c6d5a00966..0000000000 --- a/pkgs/swindle/LICENSE.txt +++ /dev/null @@ -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. diff --git a/pkgs/swindle/base.rkt b/pkgs/swindle/base.rkt deleted file mode 100644 index 4f24d3ed0c..0000000000 --- a/pkgs/swindle/base.rkt +++ /dev/null @@ -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 -;;> # -;;> => (plus 5) -;;> # -;;> => ((plus 5) 6) -;;> # -;;> => (((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) -;;> # -(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 ) -;;> (Note: do not use more keywords after the !) -;;> -;;> 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)))]))) diff --git a/pkgs/swindle/clos.rkt b/pkgs/swindle/clos.rkt deleted file mode 100644 index 4d23210321..0000000000 --- a/pkgs/swindle/clos.rkt +++ /dev/null @@ -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 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 #' 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 #' 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, 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 and 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 )]) -;;> (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 ]) 1) -;;> (defmethod (foo [x ]) 2) -;;> 3) -;;> (define (f) -;;> (defmethod (foo [x ]) 1) -;;> (defmethod (foo [x ]) 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 ]) 1) -;;> (defmethod (foo [x ]) 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*) diff --git a/pkgs/swindle/custom.rkt b/pkgs/swindle/custom.rkt deleted file mode 100644 index 7aa5e1cb12..0000000000 --- a/pkgs/swindle/custom.rkt +++ /dev/null @@ -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))) diff --git a/pkgs/swindle/extra.rkt b/pkgs/swindle/extra.rkt deleted file mode 100644 index bbd7f08705..0000000000 --- a/pkgs/swindle/extra.rkt +++ /dev/null @@ -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 '()) - -(add-method initialize (method ([s ] 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 ([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 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 `'. 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 () x y) -;;> => -;;> # -;;> => (defmethod (bar [x ]) (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) -;;> (#) -;;> => (defstruct (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 () z) -;;> => (foo-x (make :z 3 :y 2 :x 1)) -;;> 1 -;;> => (foo3-z (make :z 3 :y 2 :x 2)) -;;> 3 -;;> -;;> The `' 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 ] [x ]) - (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 ) ] - [(eq? from ) ] - [else #f])]) - (when from* (add-as-method from* to . ops)))) - args)) - `((, , ,string-copy) - (, , ,string->immutable-string) - (, , ,string->symbol) - (, , ,symbol->string) - (, , ,string->keyword) - (, , ,keyword->string) - (, , ,exact->inexact) - (, , ,inexact->exact) - (, , ,number->string) - (, , ,string->number) - (, , ,string) - (, , ,char->integer) - (, , ,integer->char) - (, , ,string->list) - (, , ,list->string) - (, , ,vector->list) - (, , ,list->vector) - (, , ,inexact->exact ,round) - (, , ,inexact->exact ,round) - (, , ,struct->vector) - (, , ,regexp) - (, , ,object-name) - (, , ,bytes-copy) - (, , ,bytes->immutable-bytes) - (, , ,bytes->list) - (, , ,list->bytes) - (, , ,byte-regexp) - (, , ,object-name) - (, , ,string->bytes/utf-8) - (, , ,bytes->string/utf-8) - (, , ,string->path) - (, , ,path->string) - (, , ,bytes->path) - (, , ,path->bytes) - ;; Some weird combinations - (, , ,string->number ,symbol->string) - (, , ,string->symbol ,number->string) - (, , ,vector->list ,struct->vector) - (, , ,string->number ,bytes->string/utf-8) - (, , ,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 ] [y ]) - ;; check this first in all cases - (or (equal? x y) (call-next-method))) - -(defmethod (equals? [x ] [y ]) - ;; 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 +) -(add-add-method append) -(add-add-method string-append) -(add-add-method symbol-append) -(add-add-method compose) - -(defmethod (add [v ] . 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 length) -(add-len-method string-length) -(add-len-method 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-ref) -(add-ref-method vector-ref) -(add-ref-method string-ref) -(add-ref-method slot-ref) -(add-ref-method hash-table-get) -(add-ref-method unbox) -(add-ref-method force) -(defmethod (ref [p ] . _) (p)) -(defmethod (ref [n ] . 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 ] x . i_) - (list-set! l (put!-arg ' i_) x)) -|# -(defmethod (put! [v ] x . i_) - (vector-set! v (put!-arg ' i_) x)) -(defmethod (put! [s ] [c ] . i_) - (string-set! s (put!-arg ' i_) c)) -(defmethod (put! [o ] x . s_) - (slot-set! o (put!-arg ' s_) x)) -(defmethod (put! [h ] x . k_) - (if (null? k_) - (error 'put! "got no index for a argument") - (hash-table-put! h (car k_) x))) -(add-put!-method set-unbox!) -(defmethod (put! [p ] x . _) - (if (null? _) - (p x) - (error 'put! "got extraneous indexes for a argument"))) -(defmethod (put! [n ] x . v_) - (if (null? v_) - (error 'put! "got no index for a 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 ] 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 ] 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 ] 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 ] 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 s with a `name' slot -(defmethod (print-object (o ) 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 so it will initialize a printer if given -(defmethod :after (initialize [c ] 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 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 ( :: (foo => f) ...); -;;> - (make ...) if the value is an instance of , 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 -;;> 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 => f) ...) - (loop x #'(and (! v) . p) vs body)] - [(make class initarg+vals ...) - ;; (make :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 ...))) - -;;>> -;;> 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* () - (name :initarg :name :initvalue '-anonymous-) - (default :initarg :default :initvalue #f) - (matchers :initarg :matchers :initvalue '())) - -;; Set the entity's proc -(defmethod (initialize [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 :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)) diff --git a/pkgs/swindle/info.rkt b/pkgs/swindle/info.rkt deleted file mode 100644 index dce0767e03..0000000000 --- a/pkgs/swindle/info.rkt +++ /dev/null @@ -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)) diff --git a/pkgs/swindle/lang/reader.rkt b/pkgs/swindle/lang/reader.rkt deleted file mode 100644 index c5337ba7a0..0000000000 --- a/pkgs/swindle/lang/reader.rkt +++ /dev/null @@ -1,2 +0,0 @@ -#lang s-exp syntax/module-reader -swindle diff --git a/pkgs/swindle/main.rkt b/pkgs/swindle/main.rkt deleted file mode 100644 index 0cdc6ce237..0000000000 --- a/pkgs/swindle/main.rkt +++ /dev/null @@ -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) diff --git a/pkgs/swindle/misc.rkt b/pkgs/swindle/misc.rkt deleted file mode 100644 index a3c0459e70..0000000000 --- a/pkgs/swindle/misc.rkt +++ /dev/null @@ -1,1904 +0,0 @@ -;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) - -;;> A lot of miscellaneous functionality that is needed for Swindle, or -;;> useful by itself. - -#lang s-exp swindle/base - -(require mzlib/list) (provide (all-from mzlib/list)) -(require mzlib/etc) (provide (all-from mzlib/etc)) -(require mzlib/string) (provide (all-from mzlib/string)) - -;; these are needed to make regexp-case work in scheme/base too -(require (rename scheme/base base-else else) (rename scheme/base base-=> =>)) - -;; ---------------------------------------------------------------------------- -;;>>... Convenient syntax definitions - -;;>> (define* ...) -;;> Like `define', except that the defined identifier is automatically -;;> `provide'd. Doesn't provide the identifier if outside of a module -;;> context. -(provide define*) -(define-syntax (define* stx) - (syntax-case stx () - [(_ x . xs) - (memq (syntax-local-context) '(module module-begin)) - (let ([name (let loop ([x #'x]) - (syntax-case x () [(x . xs) (loop #'x)] [_ x]))]) - (if name - #`(begin (provide #,name) (define x . xs)) - #`(define x . xs)))] - [(_ x . xs) #`(define x . xs)])) -;;>> (make-provide-syntax orig-def-syntax provide-def-syntax) -;;> Creates `provide-def-syntax' as a syntax that is the same as -;;> `orig-def-syntax' together with an automatic `provide' form for the -;;> defined symbol, which should be either the first argument or the first -;;> identifier in a list (it does not work for recursive nesting). The -;;> `provide' form is added only if the form appears at a module -;;> top-level. The convention when this is used is to use a "*" suffix -;;> for the second identifier. -(provide make-provide-syntax) -(define-syntax make-provide-syntax - (syntax-rules () - [(_ form form*) - (define-syntax (form* stx) - (syntax-case stx () - [(_ (id . as) . r) - (memq (syntax-local-context) '(module module-begin)) - #'(begin (provide id) (form (id . as) . r))] - [(_ id . r) - (memq (syntax-local-context) '(module module-begin)) - #'(begin (provide id) (form id . r))] - [(_ . r) #'(form . r)]))])) -;;>> (define-syntax* ...) -;;> Defined as the auto-provide form of `define-syntax'. -(provide define-syntax*) -(make-provide-syntax define-syntax define-syntax*) - -;;>> (defsyntax ...) -;;>> (defsyntax* ...) -;;>> (letsyntax (local-syntaxes ...) ...) -;;> These are just shorthands for `define-syntax', `define-syntax*', and -;;> `let-syntax'. This naming scheme is consistent with other definitions -;;> in this module (and the rest of Swindle). -(define-syntax* defsyntax - (syntax-rules () [(_ . args) (define-syntax . args)])) -(make-provide-syntax defsyntax defsyntax*) (provide defsyntax*) -(define-syntax* letsyntax - (syntax-rules () [(_ . args) (let-syntax . args)])) - -;;>> (defsubst name body) -;;>> (defsubst* name body) -;;>> (letsubst ([name body] ...) letbody ...) -;;> These are convenient ways of defining simple pattern transformer -;;> syntaxes (simple meaning they're much like inlined functions). In -;;> each of these forms, the `name' can be either a `(name arg ...)' which -;;> will define a simple macro or an identifier which will define a -;;> symbol-macro. For example: -;;> => (defsubst (my-if cond then else) -;;> (if (and cond (not (eq? 0 cond))) then else)) -;;> => (my-if 1 (echo 2) (echo 3)) -;;> 2 -;;> => (my-if 0 (echo 2) (echo 3)) -;;> 3 -;;> => (define x (list 1 2 3)) -;;> => (defsubst car-x (car x)) -;;> => car-x -;;> 1 -;;> => (set! car-x 11) -;;> => x -;;> (11 2 3) -;;> Actually, if a `(name arg ...)' is used, then the body can have more -;;> pattern/expansions following -- but since this form translates to a -;;> usage of `syntax-rules', the `name' identifier should normally be `_' -;;> in subsequent patterns. For example: -;;> => (defsubst (my-if cond then else) -;;> (if (and cond (not (eq? 0 cond))) then else) -;;> (_ cond then) -;;> (and cond (not (eq? 0 cond)) then)) -;;> => (my-if 0 1) -;;> #f -;;> Finally, note that since these are just patterns that get handled by -;;> syntax-rules, all the usual pattern stuff applies, like using `...'. - -(defsyntax defsubst-process - (syntax-rules () - [(_ name (acc ...)) (define-syntax name (syntax-rules () acc ...))] - [(_ name (acc ...) n+a subst . more) - (defsubst-process name (acc ... (n+a subst)) . more)])) -(defsyntax* defsubst - (syntax-rules () - [(_ (name . args) subst) - (define-syntax name - (syntax-rules () [(name . args) subst]))] - [(_ (name . args) subst . more) - (defsubst-process name () (name . args) subst . more)] - [(_ name subst) - (define-syntax (name stx) - (syntax-case stx () ; syntax-rules won't handle identifier expansion - ;; doesn't matter here, but see `letsubst' for an explanation on `___' - [(___ . args) (syntax/loc stx (subst . args))] - [___ (syntax/loc stx subst)]))])) -(make-provide-syntax defsubst defsubst*) (provide defsubst*) - -;; a let version of the above -(defsyntax* (letsubst stx) - (syntax-case stx () - [(_ ([name body] ...) letbody ...) - (quasisyntax/loc stx - (let-syntax - #,(map - (lambda (name body) - ;; use `___' in the following, if we use `name', then it would - ;; not be possible to make an X subst that expand to something - ;; with the previous X, so (let ([x 1]) (letsubst ([x x]) x)) - ;; will loop forever instead of returning 1. - (syntax-case name () - [(name . args) - (quasisyntax/loc body - (name (syntax-rules () [(___ . args) #,body])))] - [name (identifier? #'name) - (quasisyntax/loc body - (name - (lambda (stx) - (syntax-case stx () - [(___ . args) (syntax/loc stx (#,body . args))] - [___ (syntax/loc stx #,body)]))))])) - (syntax-e #'(name ...)) (syntax-e #'(body ...))) - letbody ...))])) - -;;>> (defmacro name body) -;;>> (defmacro* name body) -;;>> (letmacro ([name body] ...) letbody ...) -;;> These are just like Racket's define-macro (from mzlib/defmacro) with -;;> two major extensions: -;;> * If `name' is a simple identifier then a symbol-macro is defined (as -;;> with `defsubst' above). -;;> * A `letmacro' form for local macros is provided. - -(require (for-syntax (submod compatibility/defmacro dmhelp))) -(provide defmacro letmacro) -(define-syntaxes (defmacro letmacro) - (let () - (define (syntax-null? x) - (or (null? x) (and (syntax? x) (null? (syntax-e x))))) - (define (syntax-pair? x) - (or (pair? x) (and (syntax? x) (pair? (syntax-e x))))) - (define (syntax-car x) (if (pair? x) (car x) (car (syntax-e x)))) - (define (syntax-cdr x) (if (pair? x) (cdr x) (cdr (syntax-e x)))) - (define (check-args stx name args) - (unless (identifier? name) - (raise-syntax-error - #f "expected an identifier for the macro name" stx name)) - (let loop ([args args]) - (cond [(syntax-null? args) 'ok] - [(identifier? args) 'ok] - [(syntax-pair? args) - (unless (identifier? (syntax-car args)) - (raise-syntax-error - #f "expected an identifier for a macro argument" - stx (syntax-car args))) - (loop (syntax-cdr args))] - [else - (raise-syntax-error - #f "not a valid argument sequence after the macro name" - stx)]))) - (values - (lambda (stx) ; defmacro - (syntax-case stx () - [(_ (name . args) body0 body ...) - (begin - (check-args stx #'name #'args) - #'(define-syntax name - (let ([p (lambda args body0 body ...)]) - (lambda (stx) - (let ([l (syntax->list stx)]) - (unless (and l (procedure-arity-includes? - p (sub1 (length l)))) - (raise-syntax-error #f "bad form" stx)) - (let ([ht (make-hash-table)]) - (datum->syntax-object - stx - (dm-subst - ht (apply p (cdr (dm-syntax->datum stx ht)))) - stx)))))))] - [(_ name body) (identifier? #'name) - #'(define-syntax name - (lambda (stx) - (syntax-case stx () - [(_ . xs) (quasisyntax/loc stx - (#,(datum->syntax-object stx body stx) . xs))] - [_ (datum->syntax-object stx body stx)])))])) - (lambda (stx) ; letmacro - (syntax-case stx () - [(_ ([name body] ...) letbody ...) - (quasisyntax/loc stx - (let-syntax - #,(map - (lambda (name body) - (if (identifier? name) - (quasisyntax/loc body - (#,name - (lambda (stx) - (syntax-case stx () - [(_1 . xs) - (quasisyntax/loc stx - (#,(datum->syntax-object stx body stx) - . xs))] - [_1 (datum->syntax-object stx #,body stx)])))) - (syntax-case name () - [(name . args) - (begin - (check-args stx #'name #'args) - (quasisyntax/loc body - (name - (let ([p (lambda args #,body)]) - (lambda (stx) - (let ([l (syntax->list stx)]) - (unless - (and l (procedure-arity-includes? - p (sub1 (length l)))) - (raise-syntax-error #f "bad form" stx)) - (let ([ht (make-hash-table)]) - (datum->syntax-object - stx - (dm-subst - ht (apply p (cdr (dm-syntax->datum - stx ht)))) - stx))))))))]))) - (syntax-e #'(name ...)) (syntax-e #'(body ...))) - letbody ...))]))))) -(make-provide-syntax defmacro defmacro*) (provide defmacro*) - -;; ---------------------------------------------------------------------------- -;;>>... Controlling syntax - -;;>> (define-syntax-parameter name default) -;;>> (define-syntax-parameter* name default) -;;> Creates a `syntax parameter'. Syntax parameters are things that you -;;> can use just like normal parameters, but they are syntax transformers, -;;> and the information they store can be used by other syntax -;;> transformers. The purpose of having them around is to parameterize -;;> the way syntax transformation is used -- so they should be used as -;;> global option changes, not for frequent side effect: they change their -;;> value at syntax expansion time. Note that using it stores the literal -;;> syntax that is passed to them -- there is no way to evaluate the given -;;> argument, for example, if some parameter expects a boolean -- then -;;> `(not #t)' will not work! The syntax parameter itself is invoked -;;> wither with no arguments to retrieve its value, or with an argument to -;;> set it. Retrieving or setting the value in this way is meaningful -;;> only in an interactive context since using it in a function just -;;> expands to the current value: -;;> => (define-syntax-parameter -foo- 1) -;;> => (-foo-) -;;> 1 -;;> => (define (foo) (-foo-)) -;;> => (-foo- 2) -;;> => (-foo-) -;;> 2 -;;> => (foo) -;;> 1 -(defsyntax* define-syntax-parameter - (syntax-rules () - [(_ name default) - (define-syntax name - (let ([p (make-parameter #'default)]) - (lambda stx - (if (null? stx) - (p) ; when the value is used in other transformers - (syntax-case (car stx) () - [(_ new) (begin (p #'new) #'(void))] - [(_) (p)])))))])) -(make-provide-syntax define-syntax-parameter define-syntax-parameter*) -(provide define-syntax-parameter*) - -;; ---------------------------------------------------------------------------- -;;>>... Setters and more list accessors - -;;>> (set-caar! place x) -;;>> (set-cadr! place x) -;;>> (set-cdar! place x) -;;>> (set-cddr! place x) -;;>> (set-caaar! place x) -;;>> (set-caadr! place x) -;;>> (set-cadar! place x) -;;>> (set-caddr! place x) -;;>> (set-cdaar! place x) -;;>> (set-cdadr! place x) -;;>> (set-cddar! place x) -;;>> (set-cdddr! place x) -;;>> (set-caaaar! place x) -;;>> (set-caaadr! place x) -;;>> (set-caadar! place x) -;;>> (set-caaddr! place x) -;;>> (set-cadaar! place x) -;;>> (set-cadadr! place x) -;;>> (set-caddar! place x) -;;>> (set-cadddr! place x) -;;>> (set-cdaaar! place x) -;;>> (set-cdaadr! place x) -;;>> (set-cdadar! place x) -;;>> (set-cdaddr! place x) -;;>> (set-cddaar! place x) -;;>> (set-cddadr! place x) -;;>> (set-cdddar! place x) -;;>> (set-cddddr! place x) -;;> These are all defined so it is possible to use `setf!' from "setf.rkt" -;;> with these standard and library-provided functions. -#| -(define* set-caar! (lambda (p v) (set-car! (car p) v))) -(define* set-cadr! (lambda (p v) (set-car! (cdr p) v))) -(define* set-cdar! (lambda (p v) (set-cdr! (car p) v))) -(define* set-cddr! (lambda (p v) (set-cdr! (cdr p) v))) -(define* set-caaar! (lambda (p v) (set-car! (caar p) v))) -(define* set-caadr! (lambda (p v) (set-car! (cadr p) v))) -(define* set-cadar! (lambda (p v) (set-car! (cdar p) v))) -(define* set-caddr! (lambda (p v) (set-car! (cddr p) v))) -(define* set-cdaar! (lambda (p v) (set-cdr! (caar p) v))) -(define* set-cdadr! (lambda (p v) (set-cdr! (cadr p) v))) -(define* set-cddar! (lambda (p v) (set-cdr! (cdar p) v))) -(define* set-cdddr! (lambda (p v) (set-cdr! (cddr p) v))) -(define* set-caaaar! (lambda (p v) (set-car! (caaar p) v))) -(define* set-caaadr! (lambda (p v) (set-car! (caadr p) v))) -(define* set-caadar! (lambda (p v) (set-car! (cadar p) v))) -(define* set-caaddr! (lambda (p v) (set-car! (caddr p) v))) -(define* set-cadaar! (lambda (p v) (set-car! (cdaar p) v))) -(define* set-cadadr! (lambda (p v) (set-car! (cdadr p) v))) -(define* set-caddar! (lambda (p v) (set-car! (cddar p) v))) -(define* set-cadddr! (lambda (p v) (set-car! (cdddr p) v))) -(define* set-cdaaar! (lambda (p v) (set-cdr! (caaar p) v))) -(define* set-cdaadr! (lambda (p v) (set-cdr! (caadr p) v))) -(define* set-cdadar! (lambda (p v) (set-cdr! (cadar p) v))) -(define* set-cdaddr! (lambda (p v) (set-cdr! (caddr p) v))) -(define* set-cddaar! (lambda (p v) (set-cdr! (cdaar p) v))) -(define* set-cddadr! (lambda (p v) (set-cdr! (cdadr p) v))) -(define* set-cdddar! (lambda (p v) (set-cdr! (cddar p) v))) -(define* set-cddddr! (lambda (p v) (set-cdr! (cdddr p) v))) -|# - -;;>> (1st list) -;;>> (2nd list) -;;>> (3rd list) -;;>> (4th list) -;;>> (5th list) -;;>> (6th list) -;;>> (7th list) -;;>> (8th list) -;;> Quick list accessors -- no checking is done, which makes these -;;> slightly faster than the bindings provided by mzlib/list. -(define* 1st car) -(define* 2nd cadr) -(define* 3rd caddr) -(define* 4th cadddr) -(define* 5th (lambda (x) (car (cddddr x)))) -(define* 6th (lambda (x) (cadr (cddddr x)))) -(define* 7th (lambda (x) (caddr (cddddr x)))) -(define* 8th (lambda (x) (cadddr (cddddr x)))) - -;;>> (set-1st! list x) -;;>> (set-2nd! list x) -;;>> (set-3rd! list x) -;;>> (set-4th! list x) -;;>> (set-5th! list x) -;;>> (set-6th! list x) -;;>> (set-7th! list x) -;;>> (set-8th! list x) -;;> Setter functions for the above. -#| -(define* set-1st! set-car!) -(define* set-2nd! set-cadr!) -(define* set-3rd! set-caddr!) -(define* set-4th! set-cadddr!) -(define* set-5th! (lambda (p v) (set-car! (cddddr p) v))) -(define* set-6th! (lambda (p v) (set-car! (cdr (cddddr p)) v))) -(define* set-7th! (lambda (p v) (set-car! (cddr (cddddr p)) v))) -(define* set-8th! (lambda (p v) (set-car! (cdddr (cddddr p)) v))) -|# - -;;>> (head pair) -;;>> (tail pair) -;;>> (set-head! pair x) -;;>> (set-tail! pair x) -;;> Synonyms for `first', `rest', `set-first!', `set-rest!'. -(define* head first) -(define* tail rest) -;(define* set-head! set-first!) -;(define* set-tail! set-rest!) - -;;>> (set-second! list x) -;;>> (set-third! list x) -;;>> (set-fourth! list x) -;;>> (set-fifth! list x) -;;>> (set-sixth! list x) -;;>> (set-seventh! list x) -;;>> (set-eighth! list x) -;;> Defined to allow `setf!' with these mzlib/list functions. Note that -;;> there is no error checking (unlike the accessor functions which are -;;> provided by mzlib/list). -#| -(define* set-second! set-2nd!) -(define* set-third! set-3rd!) -(define* set-fourth! set-4th!) -(define* set-fifth! set-5th!) -(define* set-sixth! set-6th!) -(define* set-seventh! set-7th!) -(define* set-eighth! set-8th!) -|# - -;;>> (nth list n) -;;>> (nthcdr list n) -;;> Functions for pulling out the nth element and the nth tail of a list. -;;> Note the argument order which is unlike the one in CL. -(define* nth list-ref) -(define* (nthcdr l n) - (if (zero? n) l (nthcdr (cdr l) (- n 1)))) - -;;>> (list-set! list n x) -;;>> (set-nth! list n x) -;;> A function to set the nth element of a list, also provided as -;;> `set-nth!' to allow using `setf!' with `nth'. -#| -(define* (list-set! lst index new) - (set-car! (nthcdr lst index) new)) -(define* set-nth! list-set!) -|# - -;;>> (set-list-ref! list n x) -;;>> (set-vector-ref! vector n x) -;;>> (set-string-ref! string n x) -;;> These are defined as `list-set!', `vector-set!', and `string-set!', so -;;> the accessors can be used with `setf!'. -; (define* set-list-ref! list-set!) -(define* set-vector-ref! vector-set!) -(define* set-string-ref! string-set!) - -;;>> (last list) -;;>> (set-last! list x) -;;> Accessing a list's last element, and modifying it. -(define* (last l) - (car (last-pair l))) -#| -(define* (set-last! l x) - (set-car! (last-pair l) x)) -|# - -;;>> (set-unbox! box x) -;;> Allow using `setf!' with `unbox'. Note: this is an alias for -;;> `set-box!' which is an inconsistent name with other Scheme `set-foo!' -;;> functions -- the result is that you can also do `(setf! (box foo) x)' -;;> and bogusly get the same effect. -(define* set-unbox! set-box!) - -;;>> (set-hash-table-get! table key [default] value) -;;> This is defined to be able to `setf!' into a `hash-table-get' -;;> accessor. The form that `setf!' assembles always puts the new value -;;> last, but it is still useful to have a default thunk which results in -;;> an optional argument in an unusual place (and this argument is ignored -;;> by this, which is why it is defined as a macro). For example: -;;> => (define t (make-hash-table)) -;;> => (inc! (hash-table-get t 'foo)) -;;> hash-table-get: no value found for key: foo -;;> => (inc! (hash-table-get t 'foo (thunk 0))) -;;> => (hash-table-get t 'foo) -;;> 1 -(defsubst* - (set-hash-table-get! table key value) (hash-table-put! table key value) - (_ table key thunk value) (hash-table-put! table key value)) - -;; ---------------------------------------------------------------------------- -;;>>... Utilities - -;;>> (eprintf fmt-string args ...) -;;> Same as `printf' but it uses `current-error-port'. -(define* (eprintf . args) - (apply fprintf (current-error-port) args)) - -;;>> concat -;;> A shorter alias for `string-append'. -(define* concat string-append) - -;;>> (symbol-append sym ...) -;;> Self explanatory. -(define* (symbol-append . symbols) - (string->symbol (apply string-append (map symbol->string symbols)))) - -;;>> (maptree func tree) -;;> Applies given function to a tree made of cons cells, and return the -;;> results tree with the same shape. -(define* (maptree f x) - (let loop ([x x]) - (cond [(list? x) (map loop x)] - [(pair? x) (cons (loop (car x)) (loop (cdr x)))] - [else (f x)]))) - -;;>> (map! func list ...) -;;> Same as `map' -- but destructively modifies the first list to hold the -;;> results of applying the function. Assumes all lists have the same -;;> length. -#| -(define* (map! f l . rest) - (if (null? rest) - (let loop ([xs l]) - (if (null? xs) l (begin (set-car! xs (f (car xs))) (loop (cdr xs))))) - (let loop ([xs l] [ls rest]) - (if (null? xs) l (begin (set-car! xs (apply f (car xs) (map car ls))) - (loop (cdr xs) (map cdr ls))))))) -|# - -;;>> (maptree! func tree) -;;> Same as `maptree' -- but destructively modifies the list to hold the -;;> results of applying the function. -#| -(define* (maptree! f x) - (if (pair? x) - (begin (let loop ([x x]) - (defsubst (do-part get set) - (let ([y (get x)]) - (cond [(pair? y) (loop y)] - [(not (null? y)) (set x (f y))]))) - (do-part car set-car!) - (do-part cdr set-cdr!)) - x) - (f x))) ; can't be destructive here -|# - -;;>> (mappend func list ...) -;;>> (mappend! func list ...) -;;> Common idiom for doing a `(map func list ...)' and appending the -;;> results. `mappend!' uses `append!'. -(define* (mappend f . ls) - (apply append (apply map f ls))) -#| -(define* (mappend! f . ls) - (apply append! (apply map f ls))) -|# - -;;>> (mapply func list-of-lists) -;;> Apply the given `func' on every list in `list-of-lists' and return the -;;> results list. -(define* (mapply f ls) - (map (lambda (args) (apply f args)) ls)) - -;;>> (negate predicate?) -;;> Returns a negated predicate function. -(define* (negate pred?) - (lambda x (not (pred? . x)))) - -;;>> (position-of x list) -;;> Finds `x' in `list' and returns its index. -(define* (position-of x lst) - (let loop ([i 0] [l lst]) - (cond [(null? l) #f] - [(eq? x (car l)) i] - [else (loop (add1 i) (cdr l))]))) - -;;>> (find-if predicate? list) -;;> Find and return an element of `list' which satisfies `predicate?', or -;;> #f if none found. -(define* (find-if pred? l) - (let loop ([l l]) - (cond [(null? l) #f] - [(pred? (car l)) (car l)] - [else (loop (cdr l))]))) - -;;>> (some predicate? list ...) -;;>> (every predicate? list ...) -;;> Similar to Racket's `ormap' and `andmap', except that when multiple -;;> lists are given, the check stops as soon as the shortest list ends. - -(define* (some pred? l . rest) ; taken from slib/comlist.scm, - (cond [(null? rest) ; modified to check only up to the - (let mapf ([l l]) ; length of the shortest list. - (and (not (null? l)) - (or (pred? (car l)) (mapf (cdr l)))))] - [else (let mapf ([l l] [rest rest]) - (and (not (or (null? l) (memq '() rest))) - (or (apply pred? (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))])) - -(define* (every pred? l . rest) ; taken from slib/comlist.scm - (cond [(null? rest) ; modified to check only up to the - (let mapf ([l l]) ; length of the shortest list. - (or (null? l) - (and (pred? (car l)) (mapf (cdr l)))))] - [else (let mapf ([l l] [rest rest]) - (or (null? l) (if (memq '() rest) #t #f) - (and (apply pred? (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))])) - -;;>> (with-output-to-string thunk) -;;> Run `thunk' collecting generated output into a string. -(define* (with-output-to-string thunk) - (let ([str (open-output-string)]) - (parameterize ([current-output-port str]) (thunk)) - (get-output-string str))) - -;;>> (1+ x) -;;>> (1- x) -;;> Synonyms for `add1' and `sub1'. -(define* 1+ add1) -(define* 1- sub1) - -;; ---------------------------------------------------------------------------- -;;>>... Multi-dimensional hash-tables -;; Using lists of `eq?' keys, based on Racket's hash tables (MzScheme doesn't -;; have custom hashes). Use weak hash-tables so no space is redundantly -;; wasted. - -;;>> (make-l-hash-table) -;;>> (l-hash-table-get table keys [failure-thunk]) -;;>> (l-hash-table-put! table keys value) -;;>> (set-l-hash-table-get! table key [default] value) -;;> These functions are similar to Racket's hash-table functions, except -;;> that they work with a list of keys (compared with `eq?'). If it was -;;> possible to use a custom equality hash-table, then then would use -;;> something like -;;> (lambda (x y) (and (= (length x) (length y)) (andmap eq? x y))). -;;> The implementation uses a hash-table of hash-tables, all of them weak, -;;> since it is supposed to be used for memoization. -;;> -;;> `set-l-hash-table-get!' is defined to work with `setf!'. - -;; Internal values, used below. -(define *nothing* (list "*")) -(define (return-nothing) *nothing*) - -(defsubst l-hash-vector-length 10) - -(define* (make-l-hash-table) - (make-vector (add1 l-hash-vector-length) *nothing*)) - -(define* (l-hash-table-get table keys . thunk) - (let ([len (length keys)]) - (let loop ([obj (vector-ref table (min len l-hash-vector-length))] - [keys (if (< len l-hash-vector-length) keys (cons len keys))]) - (cond [(eq? obj *nothing*) - (if (null? thunk) - (error 'l-hash-table-get "no value found.") ((car thunk)))] - [(null? keys) obj] - [(not (hash-table? obj)) - (error 'l-hash-table-get "got to a premature value.")] - [else (loop (hash-table-get obj (car keys) return-nothing) - (cdr keys))])))) - -(define* (l-hash-table-put! table keys value) - (let* ([len (length keys)] - [obj (vector-ref table (min len l-hash-vector-length))]) - (when (eq? obj *nothing*) - (set! obj (if (zero? len) value (make-hash-table 'weak))) - (vector-set! table (min len l-hash-vector-length) obj)) - (unless (zero? len) - (let loop ([obj obj] - [keys (if (< len l-hash-vector-length) keys (cons len keys))]) - (cond [(not (hash-table? obj)) - (error 'l-hash-table-put! "got to a premature value.")] - [(null? (cdr keys)) (hash-table-put! obj (car keys) value)] - [else (let ([value (hash-table-get - obj (car keys) return-nothing)]) - (when (eq? value *nothing*) - (set! value (make-hash-table 'weak)) - (hash-table-put! obj (car keys) value)) - (loop value (cdr keys)))]))))) - -(defsubst* - (set-l-hash-table-get! table key value) (l-hash-table-put! table key value) - (_ table key thunk value) (l-hash-table-put! table key value)) - -;; Simple memoization. - -;;>> (memoize func) -;;> Return a memoized version of `func'. Note that if `func' is -;;> recursive, it should be arranged for it to call the memoized version -;;> rather then call itself directly. -(define* (memoize f) - (let ([table (make-l-hash-table)]) - (lambda args - (l-hash-table-get - table args - (thunk - (let ([r (apply f args)]) (l-hash-table-put! table args r) r)))))) - -;;>> (memoize! func-name) -;;> Changes the given function binding to a memoized version. -(defsubst* (memoize! f) (set! f (memoize f))) - -;; --------------------------------------------------------------------------- -;;>>... Generic iteration and list comprehension -;; Idea originated in a post on c.l.s by Based on Phil Bewig (July 2002), but -;; went light years beyond that. - -;;>> (collect [dir] (var base expr) clause ...) -;;> Sophisticated iteration syntax. The iteration is specified by the -;;> given clauses, where `var' serves as an accumulator variable that -;;> collects a value beginning with `base' and continuing with `expr' -- -;;> similar to a single binding in a `do' form with a variable, an initial -;;> value and an update expression. But there are much more iteration -;;> options than a `do' form: this form supports a generic -;;> list-comprehension and related constructs. Forms that use this -;;> construct are: -;;> - -;;>> (loop-for clause ...) -;;> Use when no value collection is needed, and the default for -;;> expressions is to do them instead of using them as a filter. -;;> Implemented as: -;;> (collect => (acc (void) acc) do clause ...) -(defsubst* (loop-for clause ...) - (collect => (acc (void) acc) do clause ...)) -;;> - -;;>> (list-of expr clause ...) -;;> Implemented as: -;;> (reverse! (collect (acc '() (cons expr acc)) clause ...)) -(defsubst* (list-of expr clause ...) - (reverse (collect (acc '() (cons expr acc)) clause ...))) -;;> - -;;>> (sum-of expr clause ...) -;;> Implemented as: -;;> (collect (acc 0 (+ expr acc)) clause ...) -(defsubst* (sum-of expr clause ...) - (collect (acc 0 (+ expr acc)) clause ...)) -;;> - -;;>> (product-of expr clause ...) -;;> Implemented as: -;;> (collect (acc 1 (* expr acc)) clause ...) -(defsubst* (product-of expr clause ...) - (collect (acc 1 (* expr acc)) clause ...)) -;;> - -;;>> (count-of clause ...) -;;> Only count matching cases, implemented as: -;;> (sum-of 1 clause ...) -(defsubst* (count-of clause ...) - (sum-of 1 clause ...)) -;;> - -;;> Each clause is either: -;;> * (v <- ...): a binding generator clause; -;;> * (v <- ... and v <- ...): parallel generator clauses; -;;> * (v is is-expr): bind `v' to the result of `is-expr'; -;;> * while expr: a `while' keyword followed by an expression will -;;> abort the whole loop if that expression evaluates to -;;> #f; -;;> * until expr: an `until' keyword followed by an expression will -;;> abort the whole loop if that expression evaluates to -;;> a non-#f value; -;;> * when ...: filter by the following expressions -- if an -;;> expression evaluates to #f, stop processing this -;;> iteration (default for all macros except for -;;> `loop-for'); -;;> * unless ...: filter by the negation of the following expressions; -;;> * do ...: execute the following expressions, used for side -;;> effects (default for the `loop-for' macro); -;;> * expr: expression is used according to the current mode set -;;> by a `when', `unless', or `do', keyword that -;;> precedes it. -;;> The effect of this form is to iterate each generator variable -;;> according to generating `<-' clauses (see below for these) and -;;> parallel clauses, and evaluate the `expr' with each combination, which -;;> composes a result out of iteration-bound values and an accumulated -;;> result. Generation is done in a nested fashion, where the rightmost -;;> generator spin fastest. Parallel generators (specified with an infix -;;> `and') make all iterations happen simultaneously, ending as soon as -;;> the first one ends. An `is' clause is used for binding arbitrary -;;> variables, a `do' clause is used to execute code for general -;;> side-effects, and other clauses are used to filter results before -;;> continuing down the clause list. Each clause can use variables bound -;;> by previous clauses, and the `expr' can use all bound variables as -;;> well as the given accumulator variable. -;;> -;;> An optional first token can be used to specify the direction which is -;;> used to accumulate the result. It can be one of these two tokens: -;;> `<=': A "backward" collection, the default (similar to `foldl'); -;;> `=>': A "forward" collection (similar to `foldr'). -;;> The default "backward" direction works by generating an accumulator -;;> carrying loop, as in this code (this code is for demonstration, not -;;> what `collect' creates): -;;> (let loop ([x foo] [acc '()]) -;;> (if (done? x) acc (loop (next x) (cons (value x) acc)))) -;;> which is a common Scheme idiom for such operations. The problem is -;;> that this accumulation happens in reverse -- requiring reversing the -;;> final result (which is done by the `list-of' macro). A "forward" -;;> direction does a naive recursive loop: -;;> (let loop ([x foo]) -;;> (if (done? x) '() (cons (value x) (loop (next x))))) -;;> collecting values in the correct order, but the problem is that it -;;> keeps a computation context which makes memory consumption -;;> inefficient. The default style is usually preferred, since reversing -;;> a list is a cheap operation, but it is not possible when infinite -;;> lists (streams) are used since it is impossible to reverse them. In -;;> these cases, the "forward" style should be used, but the `expr' must -;;> take care not to evaluate the iteration "variable" immediately, using -;;> `delay' or a similar mechanism (this "variable" is not bound to a -;;> value but substituted with an expression (a symbol macro)). For -;;> example, here's a quick lazy list usage: -;;> => (defsubst (lcons x y) (delay (cons x y))) -;;> => (define (lcar s) (car (force s))) -;;> => (define (lcdr s) (cdr (force s))) -;;> => (define x (collect (_ '() (lcons x _)) (x <- 0 ..))) -;;> ; loops indefinitely -;;> => (define x (collect => (_ '() (lcons x _)) (x <- 0 ..))) -;;> => (lcar (lcdr (lcdr x))) -;;> 2 -;;> Note that the `loop-for' macro uses a "forward" direction, but this is -;;> only because it is slightly faster since it doesn't require an extra -;;> binding. -;;> [The direction can be changed for a single part by using a "<-!" -;;> keyword instead of "<-", but this is an experimental feature since I -;;> don't know if it's actually useful for anything. Do not try to mix -;;> this with the `while' and `until' keywords which are implemented -;;> differently based on the direction.] -;;> - -(defsyntax* (collect stx) - (define (split id stxs) - (let loop ([stxs '()] [stxss '()] - [l (if (syntax? stxs) (syntax->list stxs) stxs)]) - (cond [(null? l) (reverse (cons (reverse stxs) stxss))] - [(and (identifier? (car l)) (module-identifier=? id (car l))) - (loop '() (cons (reverse stxs) stxss) (cdr l))] - [else (loop (cons (car l) stxs) stxss (cdr l))]))) - (define (gen-loop generate add-aux! &optional hacked) - (with-syntax ([generate generate] - [(cur step done? value) - (generate-temporaries '(cur step done? value))]) - (add-aux! #'((cur step done? value) (apply values generate))) - (with-syntax ([value #'(if value (value cur) cur)]) - (with-syntax ([value (if hacked - #`(let ([r value]) (set! #,hacked r) r) - #'value)]) - #'(cur cur (step cur) (and done? (done? cur)) value))))) - (define (gen var args add-aux! hack-var! &optional seq?) - (define (hack!) (when (and seq? hack-var!) (hack-var! var))) - (define (gen1 arg) (if seq? arg (gen-loop arg add-aux!))) - (with-syntax ([v var]) - (syntax-case args (then until while .. ..<) -;;> Generator forms are one of the following ("..", "then", "until", -;;> "while" are literal tokens), see below for what values are generated: -;;> * (v <- sequence): -;;> iterate `v' on values from `sequence'; - [(arg) (gen1 #'(collect-iterator arg))] -;;> * (v <- 1st [2nd] .. [last]): -;;> iterate on an enumerated range, including last element of range; - [(a b .. z) (gen1 #'(collect-numerator a b z ))] - [(a b .. ) (gen1 #'(collect-numerator a b #f ))] - [(a .. z) (gen1 #'(collect-numerator a #f z ))] - [(a .. ) (gen1 #'(collect-numerator a #f #f ))] -;;> * (v <- 1st [2nd] ..< last): -;;> iterate on an enumerated range, excluding last element of range; - [(a b ..< z) (gen1 #'(collect-numerator a b z '< ))] - [(a ..< z) (gen1 #'(collect-numerator a #f z '< ))] -;;> * (v <- 1st [2nd] .. while last): -;;> iterate on an enumerated range, excluding last element of range; - [(a b .. while z) (gen1 #'(collect-numerator a b z 'while))] - [(a .. while z) (gen1 #'(collect-numerator a #f z 'while))] -;;> * (v <- 1st [2nd] .. until last): -;;> iterate on an enumerated range, excluding last element of range; - [(a b .. until z) (gen1 #'(collect-numerator a b z 'until))] - [(a .. until z) (gen1 #'(collect-numerator a #f z 'until))] -;;> * (v <- x then next-e [{while|until} cond-e]): -;;> start with the `x' expression, continue with the `next-e' expression -;;> (which can use `v'), do this while/until `cond-e' is true if a -;;> condition is given; - [(arg then next) (hack!) - (if seq? ; making seq? => convert to composable funcs - #'(list arg (lambda (v) next) #f #f) - #'(v arg next #f v))] - [(arg then next while cond) (hack!) - (if seq? - #'(list arg (lambda (v) next) (lambda (v) (not cond)) #f) - #'(v arg next (not cond) v))] - [(arg then next until cond) (hack!) - (if seq? - #'(list arg (lambda (v) next) (lambda (v) cond) #f) - #'(v arg next cond v))] -;;> * (v <- x {while|until} cond-e): -;;> repeat using the `x' expression while/until `cond-e' is true; - [(arg while cond) (hack!) - (if seq? - #'(list #f #f #f (lambda (_) (if cond arg collect-final))) - #'(v #f #f #f (begin (set! v arg) (if cond v collect-final))))] - [(arg until cond) (hack!) - (if seq? - #'(list #f #f #f (lambda (_) (if cond collect-final arg))) - #'(v #f #f #f (begin (set! v arg) (if cond collect-final v))))] -;;> * (v <- func arg ...): -;;> applies `func' to `arg ...', the result is expected to be some -;;> "iterator value" which is used to do the iteration -- iteration -;;> values are created by `collect-iterator' and `collect-numerator', -;;> see below for their description and return values. -;;> * (v <- gen1 <- gen2 <- ...): -;;> generator clauses can have multiple parts specified by more `<-'s, -;;> all of them will run sequentially; - [(f x ...) - (let ([argss (split #'<- args)]) - (if (= 1 (length argss)) - (gen1 #'(f x ...)) - (let ([hacked #f]) - (with-syntax - ([(gen ...) - (map (lambda (as) - (gen var as add-aux! - (lambda (v) (set! hacked v) (hack-var! v)) - #t)) - argss)]) - (gen-loop #'(sequential-generators gen ...) - add-aux! hacked)))))]))) - (define-values (acc base0 expr clauses fwd?) - (syntax-case stx (<= =>) - [(_ <= (acc base expr) clause ...) - (values #'acc #'base #'expr #'(clause ...) #f)] - [(_ => (acc base expr) clause ...) - (values #'acc #'base #'expr #'(clause ...) #t)] - [(_ (acc base expr) clause ...) - (values #'acc #'base #'expr #'(clause ...) #f)])) - (define need-break? #f) - (define loop-body - (let c-loop ([base base0] [clauses clauses] [mode 'when] [rev? #f]) - (syntax-case clauses (<- <-! is do when unless while until) - [() (if (if rev? (not fwd?) fwd?) - #`(letsubst ([#,acc #,base]) #,expr) - expr)] - [((var <-! arg ...) rest ...) - (c-loop base #'((var <- arg ...) rest ...) mode 'rev!)] - [((var <- arg ...) rest ...) -;;> * (v1 <- gen1 ... and v2 <- gen2 ...): -;;> finally, an infix `and' specifies parallel generators, binding -;;> several variables. - (let ([rev? (if (eq? 'rev! rev?) #t #f)] - [gens (split #'and #'(var <- arg ...))] - [loop-id (car (generate-temporaries '(loop)))] - [aux '()] [hacked-vars '()]) - (for-each - (lambda (g) - (syntax-case g (<-) - [(var <- arg ...) (identifier? #'var) #f] - [_ (raise-syntax-error - #f "expected a generator clause" stx g)])) - gens) - (with-syntax ([((var <- arg ...) ...) gens]) - ;; Hack needed: generator variables are defined later in the loop - ;; just before their code, after the place where the expression - ;; appear in setup code. This is usually not a problem since - ;; functions are applied the same, but when using expression - ;; iteration (`then') in a sequential range which is in - ;; simultaneous iteration where real expressions are turned to - ;; functions (which are define before variables the might - ;; reference). This could be eliminated, restricting expressions - ;; from referencing variables that are bound in parallel, but this - ;; is usually the power of using expression (which can be claimed - ;; redundant). The hack is doing this: - ;; (let ([x #f] ...) - ;; ... (let ([x (let ([r value]) (set! x r) r)]))) - ;; The problem is that the extra junk makes it run twice slower, - ;; so do this only for bindings that has the above scenario - ;; (parallel of sequential of expression generators). To test it, - ;; do this: - ;; (list-of (list c x y) - ;; (c <- 1 .. 5 and x <- 1 <- 'x then y - ;; and y <- 1 <- 'y then x)) - ;; but this always works: - ;; (list-of (list c x y) - ;; (c <- 1 .. 5 and x <- 'x then y and y <- 'y then x)) - (with-syntax ([((cur fst next done? value) ...) - (map (lambda (v as) - (gen v as - (lambda (a) (set! aux (cons a aux))) - (lambda (v) - (set! hacked-vars - (cons v hacked-vars))))) - (syntax->list #'(var ...)) - (syntax->list #'((arg ...) ...)))] - [loop loop-id] - [(aux ...) (reverse aux)] [acc acc] [base base]) - (with-syntax - ([body - (let* ([fwd? (if rev? (not fwd?) fwd?)] - [return (if fwd? #'base #'acc)] - [body (if fwd? - (c-loop #`(#,loop-id next ...) - #'(rest ...) mode rev?) - #`(loop next ... - #,(c-loop #'acc #'(rest ...) - mode rev?)))]) - #`(let-values (aux ...) - (let loop ([cur fst] ... - #,@(if fwd? #'() #'((acc base)))) - (if (or done? ...) - #,return - #,(let vloop ([vars (syntax->list #'(var ...))] - [values (syntax->list - #'(value ...))]) - (if (null? vars) - body - #`(let ([#,(car vars) #,(car values)]) - (if (eq? #,(car vars) collect-final) - #,return - #,(vloop (cdr vars) - (cdr values))))))))))]) - (if (null? hacked-vars) - #'body - (with-syntax ([(var ...) (reverse hacked-vars)]) - #'(let ([var #f] ...) body)))))))] - [((var is is-expr) rest ...) - #`(let ([var is-expr]) #,(c-loop base #'(rest ...) mode rev?))] - [(while cond rest ...) - #`(if cond - #,(c-loop base #'(rest ...) mode rev?) - #,(if (if rev? (not fwd?) fwd?) - base0 (begin (set! need-break? #t) #`(break #,base))))] - [(until cond rest ...) - #`(if cond - #,(if (if rev? (not fwd?) fwd?) - base0 (begin (set! need-break? #t) #`(break #,base))) - #,(c-loop base #'(rest ...) mode rev?))] - [(do rest ...) (c-loop base #'(rest ...) 'do rev?)] - [(when rest ...) (c-loop base #'(rest ...) 'when rev?)] - [(unless rest ...) (c-loop base #'(rest ...) 'unless rev?)] - [(expr rest ...) - (with-syntax ([cont (c-loop base #'(rest ...) mode rev?)]) - (case mode - [(when) #`(if expr cont #,base)] - [(unless) #`(if expr #,base cont)] - [(do) #`(begin expr cont)]))]))) - (if need-break? - #`(let/ec break #,loop-body) loop-body)) -;;> - -(define (sequential-generators gen . rest) - (let-values ([(new) #f] [(fst step done? value) (values . gen)]) - (define (next!) - (and (pair? rest) - (begin (set! gen (car rest)) (set! rest (cdr rest)) - (set! fst (1st gen)) (set! step (2nd gen)) - (set! done? (3rd gen)) (set! value (4th gen)) - #t))) - (list fst - (lambda (x) - (let ([r (step (if new (begin0 new (set! new #f)) x))]) - (if (and done? (done? r)) (if (next!) fst collect-final) r))) - (lambda (x) - (and (null? rest) - (or (eq? x collect-final) (and done? (done? x))))) - (lambda (x) - (let ([r (if value (value x) x)]) - (if (eq? r collect-final) - (let* ([n? (next!)] [r (and n? (if value (value fst) fst))]) - (set! new fst) - (if (or (not n?) (done? fst)) collect-final r)) - r)))))) - -(define (function->iterator f &optional done? include-last?) - (define arity - (cond [(procedure-arity-includes? f 0) 0] - [(procedure-arity-includes? f 1) 1] - [else (error 'function->iterator - "don't know how to iterate over function ~e" f)])) - (when (and done? include-last?) - (set! done? - (let ([d? done?]) - (lambda (x) (when (d? x) (set! f (lambda _ collect-final))) #f)))) - (when (eq? 1 arity) (set! f (function-iterator f collect-final))) - (list (void) void #f - (if done? - (lambda (_) - (let ([x (f)]) - (if (or (eq? x collect-final) (done? x)) collect-final x))) - (lambda (_) (f))))) - -;;> Iteration is possible on one of the following sequence values: -(define* (collect-iterator seq) - (define (out-of-range r) (lambda (x) (<= r x))) - (cond -;;> * list: iterate over the list's element; - [(list? seq) (list seq cdr null? car)] -;;> * vector: iterate over the vector's elements; - [(vector? seq) (list 0 add1 (out-of-range (vector-length seq)) - (lambda (i) (vector-ref seq i)))] -;;> * string: iterate over characters in the string; - [(string? seq) (list 0 add1 (out-of-range (string-length seq)) - (lambda (i) (string-ref seq i)))] -;;> * integer n: iterate on values from 0 to n-1; - [(integer? seq) (list 0 add1 (out-of-range seq) #f)] -;;> * procedure f: - [(procedure? seq) -;;> - if f accepts zero arguments, begin with (f) and iterate by -;;> re-applying (f) over and over, so the only way to end this -;;> iteration is by returning `collect-final' (see below); -;;> - otherwise, if f accepts one argument, it is taken as a generator -;;> function: it is passed a one-argument procedure `yield' which can -;;> be used to suspend its execution returning the given value, and it -;;> will be continued when more values are required (see -;;> `function-iterator' below); - (function->iterator seq)] -;;> * hash-table: iterate over key-value pairs -- this is done with a -;;> generator function: -;;> (lambda (yield) -;;> (hash-table-for-each seq (lambda (k v) (yield (cons k v))))) - [(hash-table? seq) - (collect-iterator (lambda (yield) - (hash-table-for-each - seq (lambda (k v) (yield (cons k v))))))] -;;> * other values: repeated infinitely. - [else (list seq identity #f #f)])) -;;> Note that iteration over non-lists is done efficiently, iterating over -;;> a vector `v' is better than iterating over `(vector->list v)'. -;;> - -;;> Enumeration is used whenever a ".." token is used to specify a range. -;;> There are different enumeration types based on different input types, -;;> and all are modified by the token used: -;;> * "..": a normal inclusive range; -;;> * "..<": a range that does not include the last element; -;;> * ".. while": a range that continues while a predicate is true; -;;> * ".. until": a range that continues until a predicate is true. -;;> The "..<" token extends to predicates in the expected way: the element -;;> that satisfies the predicate is the last one and it is not included in -;;> the enumeration -- unlike "..". -;;> These are the possible types that can be used with an enumeration: -(define* (collect-numerator from second to &optional flag) - (define (check-type pred? &optional not-to) - (and (pred? from) (or (not second) (pred? second)) - (or not-to (not to) (pred? to)))) - (define (to->pred) - (and to (let ([to (if (and (procedure? to) - (procedure-arity-includes? to 1)) - to (lambda (x) (equal? x to)))]) - (if (eq? 'while flag) (negate to) to)))) - (when (and (memq flag '(while until)) - (not (and (procedure? to) (procedure-arity-includes? to 1)))) - (set! to (lambda (x) (equal? x to)))) -;;> * num1 [num2] .. [num3]: go from num1 to num3 in num3 in num2-num1 -;;> steps, if num2 is not given then use +1/-1 steps, if num3 is not -;;> given don't stop; -;;> * num1 [num2] .. pred: go from num1 by num2-num1 steps (defaults to -;;> 1), up to the number that satisfies the given predicate; - (cond [(check-type number?) - (let* ([step - (cond [second (- second from)] - [(and (number? to) (> from to)) -1] - [else 1])] - [gt? - (case flag - [(#f) (if (positive? step) > <)] - [(<) (if (positive? step) >= <=)] - [else (error 'collect-numerator "internal error")])]) - (list from - (lambda (x) (+ x step)) - (if (number? to) (lambda (x) (gt? x to)) #f) - #f))] -;;> * char1 [char2] .. [char3/pred]: the same as with numbers, but on -;;> character ranges; - [(check-type char? #t) - (let ([numerator (collect-numerator - (char->integer from) - (and second (char->integer second)) - (cond [(char? to) (char->integer to)] - [(and (procedure? to) - (procedure-arity-includes? to 1)) - (compose to integer->char)] - [else to]) - flag)]) - (list (1st numerator) (2nd numerator) (3rd numerator) - integer->char))] -;;> * func .. [pred/x]: use `func' the same way as in an iterator above, -;;> use `pred' to identify the last element, if `pred' is omitted repeat -;;> indefinitely; - [(and (procedure? from) (not second)) - (let ([to (to->pred)]) - (function->iterator from to (and (not flag) to)))] -;;> * fst [next] .. [pred]: start with `fst', continue by repeated -;;> applications of the `next' function on it, and use `pred' to -;;> identify the last element, if `pred' is omitted repeat indefinitely, -;;> if `next' is omitted repeat `fst', and if both `fst' and `next' are -;;> numbers or characters then use their difference for stepping. (Note -;;> that to repeat a function value you should use `identity' as for -;;> `next' or the function will be used as described above.) - [else - (cond [(and (number? from) (number? second)) - (let ([d (- second from)]) (set! second (lambda (x) (+ x d))))] - [(not second) (set! second identity)] - [(not (and (procedure? second) - (procedure-arity-includes? second 1))) - (error 'collect-numerator - "don't know how to enumerate ~e ~e .. ~e" - from second to)]) - (if (not to) - (list from second #f #f) - (let ([to (to->pred)]) - (if (or flag (not to)) - (list from second to #f) - (let ([almost-done? (to from)] [done? #f]) - (list from (lambda (x) - (if almost-done? - (set! done? #t) - (let ([next (second x)]) - (when (to next) (set! almost-done? #t)) - next))) - (lambda (_) done?) #f)))))])) -;;> - -;;> Here is a long list of examples for clarification, all using -;;> `list-of', but the generalization should be obvious: -;;> => (list-of x [x <- '(1 2 3)]) -;;> (1 2 3) -;;> => (list-of (list x y) [x <- '(1 2 3)] [y <- 1 .. 2]) -;;> ((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)) -;;> => (list-of (format "~a~a~a" x y z) -;;> [x <- '(1 2)] [y <- #(a b)] [z <- "xy"]) -;;> ("1ax" "1ay" "1bx" "1by" "2ax" "2ay" "2bx" "2by") -;;> => (list-of (+ x y) [x <- '(1 2 3)] [y <- 20 40 .. 100]) -;;> (21 41 61 81 101 22 42 62 82 102 23 43 63 83 103) -;;> => (list-of (+ x y) [x <- '(1 2 3) and y <- 20 40 .. 100]) -;;> (21 42 63) -;;> => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)] (even? x)) -;;> (a c e g i) -;;> => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)] -;;> when (even? x) do (echo y)) -;;> a -;;> c -;;> e -;;> g -;;> i -;;> (a c e g i) -;;> => (list-of (list x y) [x <- 3 and y <- 'x]) -;;> ((0 x) (1 x) (2 x)) -;;> => (list-of (list x y) [x <- 3 and y <- 'x ..]) -;;> ((0 x) (1 x) (2 x)) -;;> => (list-of (list x y) [x <- #\0 .. and y <- '(a b c d)]) -;;> ((#\0 a) (#\1 b) (#\2 c) (#\3 d)) -;;> => (list-of x [x <- '(1 2 3) then (cdr x) until (null? x)]) -;;> ((1 2 3) (2 3) (3)) -;;> => (list-of (list x y) -;;> [x <- '(1 2 3) then (cdr y) until (null? x) and -;;> y <- '(10 20 30) then (cdr x) until (null? y)]) -;;> (((1 2 3) (10 20 30)) ((20 30) (2 3)) ((3) (30))) -;;> => (list-of x [x <- (lambda (yield) 42)]) -;;> () -;;> => (list-of x [x <- (lambda (yield) (yield 42))]) -;;> (42) -;;> => (list-of x [x <- (lambda (yield) (yield (yield 42)))]) -;;> (42 42) -;;> => (list-of x [x <- (lambda (yield) -;;> (for-each (lambda (x) (echo x) (yield x)) -;;> '(3 2 1 0)))]) -;;> 3 -;;> 2 -;;> 1 -;;> 0 -;;> (3 2 1 0) -;;> => (list-of x [x <- (lambda (yield) -;;> (for-each (lambda (x) (echo x) (yield (/ x))) -;;> '(3 2 1 0)))]) -;;> 3 -;;> 2 -;;> 1 -;;> 0 -;;> /: division by zero -;;> => (list-of x -;;> [c <- 3 and -;;> x <- (lambda (yield) -;;> (for-each (lambda (x) (echo x) (yield (/ x))) -;;> '(3 2 1 0)))]) -;;> 3 -;;> 2 -;;> 1 -;;> (1/3 1/2 1) -;;> => (define h (make-hash-table)) -;;> => (set! (hash-table-get h 'x) 1 -;;> (hash-table-get h 'y) 2 -;;> (hash-table-get h 'z) 3) -;;> => (list-of x [x <- h]) -;;> ((y . 2) (z . 3) (x . 1)) -;;> => (list-of x [x <- 4 <- 4 .. 0 <- '(1 2 3)]) -;;> (0 1 2 3 4 3 2 1 0 1 2 3) -;;> => (list-of (list x y) -;;> [x <- 1 .. 3 <- '(a b c) and -;;> y <- (lambda (y) (y 'x) (y 'y)) <- "abcd"]) -;;> ((1 x) (2 y) (3 #\a) (a #\b) (b #\c) (c #\d)) -;;> -;;> Note that parallel iteration is useful both for enumerating results, -;;> and for walking over a finite prefix of an infinite iteration. -;;> -;;> The following is an extensive list of various ranges: -;;> => (list-of x [x <- 0 .. 6]) -;;> (0 1 2 3 4 5 6) -;;> => (list-of x [x <- 0 ..< 6]) -;;> (0 1 2 3 4 5) -;;> => (list-of x [x <- 0 .. -6]) -;;> (0 -1 -2 -3 -4 -5 -6) -;;> => (list-of x [x <- 0 ..< -6]) -;;> (0 -1 -2 -3 -4 -5) -;;> => (list-of x [x <- 0 2 .. 6]) -;;> (0 2 4 6) -;;> => (list-of x [x <- 0 2 ..< 6]) -;;> (0 2 4) -;;> => (list-of x [x <- 0 -2 ..< -6]) -;;> (0 -2 -4) -;;> => (list-of x [x <- #\a .. #\g]) -;;> (#\a #\b #\c #\d #\e #\f #\g) -;;> => (list-of x [x <- #\a ..< #\g]) -;;> (#\a #\b #\c #\d #\e #\f) -;;> => (list-of x [x <- #\a #\c .. #\g]) -;;> (#\a #\c #\e #\g) -;;> => (list-of x [x <- #\a #\c ..< #\g]) -;;> (#\a #\c #\e) -;;> => (list-of x [x <- #\g #\e ..< #\a]) -;;> (#\g #\e #\c) -;;> => (list-of x [x <- 6 5 .. zero?]) -;;> (6 5 4 3 2 1 0) -;;> => (list-of x [x <- 6 5 ..< zero?]) -;;> (6 5 4 3 2 1) -;;> => (list-of x [x <- 6 5 .. until zero?]) -;;> (6 5 4 3 2 1) -;;> => (list-of x [x <- 6 5 .. while positive?]) -;;> (6 5 4 3 2 1) -;;> => (list-of x [x <- '(1 2 3) cdr .. null?]) -;;> ((1 2 3) (2 3) (3) ()) -;;> => (list-of x [x <- '(1 2 3) cdr ..< null?]) -;;> ((1 2 3) (2 3) (3)) -;;> => (list-of x [x <- '(1 2 3) cdr .. until null?]) -;;> ((1 2 3) (2 3) (3)) -;;> => (list-of x [x <- '(1 2 3) cdr .. while pair?]) -;;> ((1 2 3) (2 3) (3)) -;;> => (list-of x [x <- #\a #\d .. while char-alphabetic?]) -;;> (#\a #\d #\g #\j #\m #\p #\s #\v #\y) -;;> => (list-of x [x <- #\a #\d .. char-alphabetic?]) -;;> (#\a) -;;> => (list-of x [x <- #\a #\d ..< char-alphabetic?]) -;;> () -;;> => (list-of x [x <- 0 1 .. positive?]) -;;> (0 1) -;;> => (list-of x [x <- 1 2 .. positive?]) -;;> (1) -;;> => (list-of x [x <- 1 2 ..< positive?]) -;;> () -;;> => (list-of x [x <- '(a b c) ..< pair?]) -;;> () -;;> => (list-of x [x <- '(a b c) .. pair?]) -;;> ((a b c)) -;;> => (list-of x [x <- '(a b c) cdr .. pair?]) -;;> ((a b c)) -;;> => (list-of x [x <- read-line .. eof-object?]) -;;> ...list of remaining input lines, including #... -;;> => (list-of x [x <- read-line ..< eof-object?]) -;;> ...list of remaining input lines, excluding #... -;;> => (list-of x [x <- read-line ..< eof]) -;;> ...the same... -;;> - -;;>> collect-final -;;> This value can be used to terminate iterations: when it is returned as -;;> the iteration value (not the state), the iteration will terminate -;;> without using it. -(define* collect-final (list "*")) - -;;>> (function-iterator f [final-value]) -;;> `f' is expected to be a function that can accept a single input value. -;;> It is applied on a `yield' function that can be used to return a value -;;> at any point. The return value is a function of no argument, which -;;> returns on every application values that were passed to `yield'. When -;;> `f' terminates, the final result of the iterated return value depends -;;> on the optional argument -- if none was supplied, the actual return -;;> value is returned, if a thunk was supplied it is applied for a return -;;> value, and if any other value was given it is returned. After -;;> termination, calling the iterated function again results in an error. -;;> (The supplied `yield' function returns its supplied value to the -;;> calling context when resumed.) -;;> => (define (foo yield) (yield 1) (yield 2) (yield 3)) -;;> => (define bar (function-iterator foo)) -;;> => (list (bar) (bar) (bar)) -;;> (1 2 3) -;;> => (bar) -;;> 3 -;;> => (bar) -;;> function-iterator: iterated function # exhausted. -;;> => (define bar (function-iterator foo 'done)) -;;> => (list (bar) (bar) (bar) (bar)) -;;> (1 2 3 done) -;;> => (bar) -;;> function-iterator: iterated function # exhausted. -;;> => (define bar (function-iterator foo (thunk (error 'foo "done")))) -;;> => (list (bar) (bar) (bar)) -;;> (1 2 3) -;;> => (bar) -;;> foo: done -(define* (function-iterator f . finally) - (define ret #f) - (define (done) - (set! cnt (thunk (error 'function-iterator - "iterated function ~e exhausted." f)))) - (define cnt - (cond [(null? finally) (thunk (let ([r (f yield)]) (done) (ret r)))] - [(and (procedure? (car finally)) - (procedure-arity-includes? (car finally) 0)) - (thunk (f yield) (done) (ret ((car finally))))] - [else (thunk (f yield) (done) (ret (car finally)))])) - (define (yield v) (let/cc k (set! cnt (thunk (k v))) (ret v))) - (thunk (let/cc ret1 (set! ret ret1) (cnt)))) - -;;>> (collect-iterator sequence) -;;>> (collect-numerator from second to [flag]) -;;> These functions are used to construct iterations. `collect-iterator' -;;> is the function used to create iteration over a sequence object and it -;;> is used by `(x <- sequence)' forms of `collect'. `collect-numerator' -;;> create range iterations specified with `(x <- from second to)' forms, -;;> where unspecified values are passed as `#f', and the flag argument is -;;> a `<', `while', or `until' symbol for ranges specified with "..<", -;;> ".. while" and ".. until". These functions are available for -;;> implementing new iteration constructs, for example: -;;> => (define (in-values producer) -;;> (collect-iterator (call-with-values producer list))) -;;> => (list-of x [x <- in-values (thunk (values 1 2 3))]) -;;> (1 2 3) -;;> The return value that specifies an iteration is a list of four items: -;;> 1. the initial state value; -;;> 2. a `step' function that gets a state and returns the next one; -;;> 3. a predicate for the end state (#f for none); -;;> 4. a function that computes a value from the state variable. -;;> But usually the functions are more convenient. -;;> -;;> Finally, remember that you can return `collect-final' as the value to -;;> terminate any iteration. - -;; ---------------------------------------------------------------------------- -;;>>... Convenient printing - -;;>> *echo-display-handler* [h] -;;>> *echo-write-handler* [h] -;;> Currently, Racket's I/O can be customized only on a per port basis. -;;> This means that installing the object printing generic later will -;;> change only the standard ports, and for new ports a handleres should -;;> always be installed. This means that `echos' will not work with -;;> objects since it uses a new port -- so use these parameters to allow -;;> to change them later to the Swindle printer. -(define* *echo-display-handler* (make-parameter display)) -(define* *echo-write-handler* (make-parameter write)) - -;;>> (echo arg ...) -;;> This is a handy printout utility that offers an alternative approach -;;> to `printf'-like output (it's a syntax, but it can be used as a -;;> regular function too, see below). When applied, it simply prints its -;;> arguments one by one, using certain keywords to control its behavior: -;;> * :>e - output on the current-error-port; -;;> * :>o - output on the current-output-port (default); -;;> * :>s - accumulate output in a string which is the return value -;;> (string output sets `:n-' as default (unless -;;> pre-specified)); -;;> * :> p - output on the given port `p', or a string if `#f'; -;;> * :>> o - use `o', a procedure that gets a value and a port, as the -;;> output handler (the procedure can take one value and -;;> display it on the current output port); -;;> * :d - use `display' output (default); -;;> * :w - use `write' output; -;;> * :d1 :w1 - change to a `display' or `write' output just for the next -;;> argument; -;;> * :s- - no spaces between arguments; -;;> * :s+ - add spaces between arguments (default); -;;> * :n- - do not print a final newline; -;;> * :n+ - terminate the output with a newline (default); -;;> * :n - output a newline now; -;;> * : or :: - avoid a space at this point; -;;> * :\{ - begin a list construct (see below). -;;> Keywords that require additional argument are ignored if no argument -;;> is given. -;;> -;;> Recursive processing of a list begins with a `:\{' and ends with a -;;> `:\}' (which can be simpler if `read-curly-brace-as-paren' is off). -;;> Inside a list context, values are inspected and any lists cause -;;> iteration for all elements. In each iteration, all non-list arguments -;;> are treated normally, but lists are dissected and a single element is -;;> printed in each step, terminating when the shortest list ends (and -;;> repeating a last `dotted' element of a list): -;;> => (define abc '(a b c)) -;;> => (echo :\{ "X" abc :\}) -;;> X a X b X c -;;> => (echo :\{ "X" abc '(1 2 3 4) :\}) -;;> X a 1 X b 2 X c 3 -;;> => (echo :\{ "X" abc '(1 . 2) :\}) -;;> X a 1 X b 2 X c 2 -;;> Inside a list context, the `:^' keyword can be used to stop this -;;> iteration if it is the last: -;;> => (echo :s- :\{ abc :^ ", " :\}) -;;> a, b, c -;;> Nesting of lists is also simple, following these simple rules, by -;;> nesting the `:\{' ... `:\}' construct: -;;> => (echo :s- :\{ "<" :\{ '((1 2) (3 4 5) 6 ()) :^ "," :\} ">" -;;> :^ "-" :\}) -;;> <1,2>-<3,4,5>-<6>-<> -;;> Note that this example is similar to the CL `format': -;;> (format t "~{<~{~a~^,~}>~^-~}" '((1 2) (3 4 5) 6 ())) -;;> except that `echo' treats a dotted element (a non-list in this case) -;;> as repeating as needed. -;;> -;;> There are two additional special keywords that are needed only in -;;> uncommon situations: -;;> * :k- - turn off keyword processing -;;> * :k+ - turn keyword processing on -;;> Usually, when `echo' is used, it is processed by a macro that detects -;;> all keywords, even if there is a locally bound variable with a keyword -;;> name. This means that keywords are only ones that are syntactically -;;> so, not expressions that evaluate to keywords. The two cases where -;;> this matters are -- when `echo' is used for its value (using it as a -;;> value, not in a head position) no processing is done so all keywords -;;> will just get printed; and when `echo' is used in a context where a -;;> variable has a keyword name and you want to use its value (which not a -;;> great idea anyway, so there is no way around it). The first case is -;;> probably more common, so the variable `echo:' is bound to a special -;;> value that will force treating the next value as a keyword (if it -;;> evaluates to one) -- it can also be used to turn keyword processing on -;;> (which means that all keyword values will have an effect). Here is a -;;> likely examples where `echo:' should be used: -;;> => (define (echo-values vals) -;;> (apply echo "The given values are:" echo: :w vals)) -;;> => (echo-values '("a" "b" "c")) -;;> The given values are: "a" "b" "c" -;;> => (echo-values '(:a :b :c)) -;;> The given values are: :a :b :c -;;> And here are some tricky examples: -;;> => (echo :>s 2) -;;> "2" -;;> => (define e echo) ; `e' is the real `echo' function -;;> => (e :>s 2) ; no processing done here -;;> :>s 2 -;;> => (e echo: :>s 2) ; explicit key -;;> "2" -;;> => (e echo: :k+ :>s 2) ; turn on keywords -;;> "2" -;;> => (let ([:>s 1]) (echo :>s 2)) ; `:>s' was processed by `echo' -;;> "2" -;;> => (let ([:>s 1]) (e :>s 2)) ; `:>s' was not processed -;;> 1 2 -;;> => (let ([:>s 1]) (e echo: :>s 2)) ; `:>s' is not a keyword here! -;;> 1 2 -;;> => (let ([:>s 1]) (echo echo: :>s 2)) ; `echo:' not needed -;;> "2" -;;> -;;> Finally, it is possible to introduce new keywords to `echo'. This is -;;> done by calling it with the `:set-user' keyword, which expects a -;;> keyword to attach a handler to, and the handler itself. The handler -;;> can be a simple value or a keyword that will be used instead: -;;> => (echo :set-user :foo "foo") -;;> => (echo 1 :foo 2) -;;> 1 foo 2 -;;> => (echo :set-user :foo :n) -;;> => (echo 1 :foo 2) -;;> 1 -;;> 2 -;;> The `:set-user' keyword can appear with other arguments, it has a -;;> global effect in any case: -;;> => (echo 1 :foo :set-user :foo "FOO" 2 :foo 3 -;;> :set-user :foo "bar" :foo 4) -;;> 1 -;;> 2 FOO 3 bar 4 -;;> => (echo 1 :foo 2) -;;> 1 bar 2 -;;> If the handler is a function, then when this keyword is used, the -;;> function is applied on arguments pulled from the remaining `echo' -;;> arguments that follow (if the function can get any number of -;;> arguments, then all remaining arguments are taken). The function can -;;> work in two ways: (1) when it is called, the `current-output-port' -;;> will be the one that `echo' currently prints to, so it can just print -;;> stuff; (2) if the function returns a list (or a single value which is -;;> not `#f' or `void'), then these values will be used instead of the -;;> taken arguments. Some examples: -;;> => (echo :set-user :foo (thunk "FOO") 1 :foo 2) -;;> 1 FOO 2 -;;> => (echo :set-user :add1 add1 1 :add1 2) -;;> 1 3 -;;> => (echo :set-user :+1 (lambda (n) (list n '+1= (add1 n))) :+1 2) -;;> 2 +1= 3 -;;> => (echo :set-user :<> (lambda args (append '("<") args '(">"))) -;;> :<> 1 2 3) -;;> < 1 2 3 > -;;> Care should be taken when user keywords are supposed to handle other -;;> keywords -- the `echo:' tag will usually be among the arguments except -;;> when `:k+' was used and an argument value was received. This exposes -;;> the keyword treatment hack and might change in the future. -;;> -;;> To allow user handlers to change settings temporarily, there are -;;> `:push' and `:pop' keywords that will save and restore the current -;;> state (space and newline flags, output type and port etc). For -;;> example: -;;> => (echo :set-user :@ -;;> (lambda (l) -;;> (echo-quote -;;> list :push :s- :\{ "\"" l "\"" :^ ", " :\} :pop))) -;;> => (echo 1 :@ '(2 3 4) 5) -;;> 1 "2", "3", "4" 5 -;;> The above example shows another helper tool -- the `echo-quote' -;;> syntax: `(echo-quote head arg ...)' will transform into `(head ...)', -;;> where keyword arguments are prefix with the `echo:' tag. Without it, -;;> things would look much worse. -;;> -;;> In addition to `:set-user' there is an `:unset-user' keyword which -;;> cancels a keyword handler. Note that built-in keywords cannot be -;;> overridden or unset. - -;;>> (echo-quote head arg ...) [h] -;;> This macro will result in `(head arg ...)', where all keywords in the -;;> argument list are preceded with the `echo:' tag. It is a convenient -;;> form to use for defining new echo keyword handlers. -(defsyntax* (echo-quote stx) - (define (process args) - (syntax-case args () - [() #'()] - [(x . more) (with-syntax ([more (process #'more)]) - (if (syntax-keyword? #'x) - ;; `datum' protects from using a local binding - #'(echo: (#%datum . x) . more) #'(x . more)))] - [x #'x])) ; only in case of (echo ... . x) - (syntax-case stx () - [(_ head . args) (quasisyntax/loc stx (head . #,(process #'args)))])) - -(provide (rename echo-syntax echo)) -(defsyntax (echo-syntax stx) - (syntax-case stx () - [(_ . args) (syntax/loc stx (echo-quote echo . args))] - [_ #'echo])) - -;; A table for user-defined keywords -(define echo-user-table (make-hash-table)) - -;; Make an echo keyword handler for a given procedure. The handler gets the -;; current list of arguments and returns the new list of arguments. -(define (make-echo-handler keyword proc) - (let* ([arity (procedure-arity proc)] - [at-least (and (arity-at-least? arity) - (arity-at-least-value arity))] - [required (or at-least arity)]) - (unless (integer? required) - (error 'echo "handler function for `~.s' has bad arity" keyword)) - (lambda (args) - (if (< (length args) required) - (error 'echo "user-keyword `~.s' didn't get enough arguments" keyword) - (let*-values ([(proc-args rest-args) - (if at-least - (values args '()) - (let loop ([rest args] [args '()] [n required]) - (if (zero? n) - (values (reverse args) rest) - (loop (cdr rest) (cons (car rest) args) - (sub1 n)))))] - [(result) (apply proc proc-args)]) - (cond [(list? result) (append result rest-args)] - [(and result (not (void? result))) - (if (keyword? result) - (list* echo: result rest-args) (cons result rest-args))] - [else rest-args])))))) - -(define (echo . args) - (define break: "break:") - (define call: "call:") - (let ([printer (*echo-display-handler*)] [out (current-output-port)] - [spaces? #t] [newline? 'x] [first? #t] [str? #f] [keys? #f] - [states '()]) - (define (getarg) (begin0 (car args) (set! args (cdr args)))) - (define (push-state!) - (set! states (cons (list printer out spaces? newline? first? str? keys?) - states))) - (define (pop-state!) - (if (null? states) - (error 'echo "tried to restore a state, but none saved") - (let ([s (car states)]) - (set! states (cdr states)) - (set!-values (printer out spaces? newline? first? str? keys?) - (apply values s))))) - (define (set-out! arg) - (set! out (or arg (open-output-string))) - (set! str? (not arg)) - (unless (output-port? out) - (error 'echo "expected an output-port or #f, given ~e" out))) - (define (printer1! hparam) - (unless (or (null? args) (eq? echo: (car args))) - (let ([p (hparam)]) - (unless (eq? printer p) - (let ([v (getarg)] [op printer]) - (set! printer p) - (set! args (list* v echo: :>> op args))))))) - (define (process-list) - (define level 1) - (define ((do-lists args)) - ;; this returns a thunk so the whole thing is not expanded in one shot - (let loop ([args args] [cars '()] [cdrs '()] [last? '?]) - (if (null? args) - (reverse - (if last? cars (list* (do-lists (reverse cdrs)) call: cars))) - (let* ([1st (car args)] [p? (pair? 1st)]) - (if (and last? (eq? 1st break:)) - (reverse cars) - (if (null? 1st) - '() - (loop (cdr args) - (if (eq? 1st break:) - cars (cons (if p? (car 1st) 1st) cars)) - (cons (if p? (cdr 1st) 1st) cdrs) - (if p? - (or (eq? last? #t) (null? (cdr 1st))) - last?)))))))) - (let loop ([l-args '()]) - (define (pop-key-tags) - (when (and (pair? l-args) (eq? echo: (car l-args))) - (set! l-args (cdr l-args)) (pop-key-tags))) - (when (null? args) - (error 'echo "found a `~.s' with no matching `~.s'" :\{ :\})) - (let ([arg (getarg)]) - (define (next) (loop (cons arg l-args))) - (cond - [(eq? arg echo:) (set! keys? (or keys? 'just-one)) (next)] - [(and keys? (keyword? arg)) - (unless (eq? keys? #t) (set! keys? #f)) - (case arg - [(:\}) - (set! level (sub1 level)) - (if (zero? level) - (begin - (pop-key-tags) - (set! args (append ((do-lists (reverse l-args))) args))) - (next))] - [(:\{) - (set! level (add1 level)) (next)] - [(:^) - (when (eq? 1 level) (set! arg break:) (pop-key-tags)) - (next)] - [else (next)])] - [else (next)])))) - (let loop () - (unless (null? args) - (let ([arg (getarg)]) - (cond - [(eq? arg call:) (set! args (append ((getarg)) args))] - [(eq? arg echo:) (set! keys? (or keys? 'just-one))] - [(and keys? (keyword? arg)) - (unless (eq? keys? #t) (set! keys? #f)) - (case arg - [(:>e) (set-out! (current-error-port))] - [(:>o) (set-out! (current-output-port))] - [(:>s) (set-out! #f)] - [(:>) (unless (or (null? args) (eq? echo: (car args))) - (set-out! (getarg)))] - [(:>>) (unless (or (null? args) (eq? echo: (car args))) - (let ([p (getarg)]) - (set! printer (if (eq? 1 (procedure-arity p)) - (lambda (x _) (p x)) p))))] - [(:d) (set! printer (*echo-display-handler*))] - [(:w) (set! printer (*echo-write-handler*))] - [(:d1) (printer1! *echo-display-handler*)] - [(:w1) (printer1! *echo-write-handler*)] - [(:s-) (set! spaces? (and spaces? (not first?) 'just-one))] - [(:s+) (set! spaces? #t)] - [(:n-) (set! newline? #f)] - [(:n+) (set! newline? #t)] - [(:n) (newline out) (set! first? #t)] - [(:: :) (set! first? #t)] - [(:push) (push-state!)] - [(:pop) (pop-state!)] - [(:\{) (process-list)] - [(:\} :^) (error 'echo "unexpected list keyword `~.s'" arg)] - [(:k-) (set! keys? #f)] - [(:k+) (set! keys? #t)] - [(:set-user :unset-user) - (let loop ([keyword echo:]) - (if (null? args) - (error 'echo "expecting a keyword+handler after `~.s'" arg) - (let ([x (getarg)]) - (cond - [(eq? keyword echo:) (loop x)] - [(not (keyword? keyword)) - (error 'echo "got a `~.s' with a non-keyword `~.s'" - arg keyword)] - [(eq? arg :unset-user) - (hash-table-put! echo-user-table keyword #f)] - [(eq? x echo:) (loop keyword)] - [else (let ([handler (if (procedure? x) - (make-echo-handler keyword x) x)]) - (hash-table-put! echo-user-table keyword handler) - (when (and newline? (not (eq? #t newline)) - (null? args)) - (set! newline? #f)))]))))] - [else - (let ([user (hash-table-get echo-user-table arg (thunk #f))]) - (if user - (set! args - (cond [(procedure? user) (user args)] - [(keyword? user) (list* echo: user args)] - [else (cons user args)])) - (error 'echo "unknown keyword: `~.s'" arg)))])] - [first? (printer arg out) (set! first? #f)] - [spaces? (display " " out) (printer arg out) - (unless (eq? spaces? #t) (set! spaces? #f))] - [else (printer arg out)]) - (loop)))) - (when (and newline? (or (not str?) (eq? newline? #t))) (newline out)) - (when str? (get-output-string out)))) - -;;>> (echos arg ...) -;;> Just uses `echo' with `:>s'. -(provide (rename echos-syntax echos)) -(defsyntax (echos-syntax stx) - (syntax-case stx () - [(_ . args) (syntax/loc stx (echo-syntax :>s . args))] - [_ #'echos])) -(define (echos . args) - (echo echo: :>s . args)) - -;;>> echo: -;;> See the `echo' description for usage of this value. -(define* echo: "echo:") - -;; ---------------------------------------------------------------------------- -;; Simple macros - -;;>> (named-lambda name args body ...) -;;> Like `lambda', but the name is bound to itself in the body. -(defsubst* (named-lambda name args . body) - (letrec ([name (lambda args . body)]) name)) - -;;>> (thunk body ...) -;;> Returns a procedure of no arguments that will have the given body. -(defsubst* (thunk body ...) (lambda () body ...)) - -;;>> (while condition body ...) -;;>> (until condition body ...) -;;> Simple looping constructs. -(defsubst* (while cond body ...) - (let loop () (when cond (begin body ... (loop))))) -(defsubst* (until cond body ...) - (while (not cond) body ...)) - -;;>> (dotimes (i n) body ...) -;;> Loop `n' times, evaluating the body when `i' is bound to 0,1,...,n-1. -(defsubst* (dotimes [i n] body0 body ...) - (let ([n* n]) - (let loop ([i 0]) - (when (< i n*) body0 body ... (loop (add1 i)))))) - -;;>> (dolist (x list) body ...) -;;> Loop with `x' bound to elements of `list'. -(defsubst* (dolist [x lst] body0 body ...) - (for-each (lambda (x) body0 body ...) lst)) - -;;>> (no-errors body ...) -;;> Execute body, catching all errors and returning `#f' if one occurred. -(defsubst* (no-errors body ...) - (with-handlers ([void (lambda (x) #f)]) body ...)) -;;>> (no-errors* body ...) -;;> Execute body, catching all errors and returnsthe exception if one -;;> occured. -(defsubst* (no-errors* body ...) - (with-handlers ([void identity]) body ...)) - -;;>> (regexp-case string clause ...) -;;> Try to match the given `string' against several regexps. Each clause -;;> has one of the following forms: -;;> * (re => function): if `string' matches `re', apply `function' on the -;;> resulting list. -;;> * ((re args ...) body ...): if `string' matches `re', bind the tail of -;;> results (i.e, excluding the whole match result) to the given -;;> arguments and evaluate the body. The whole match result (the first -;;> element of `regexp-match') is bound to `match'. -;;> * (re body ...): if `string' matches `re', evaluate the body -- no -;;> match results are available. -;;> * (else body ...): should be the last clause which is evaluated if all -;;> previous cases failed. -(defsyntax* (regexp-case stx) - (define (do-clause c) - (syntax-case c (else base-else => base-=>) - [(else body ...) c] - [(base-else body ...) #'(else body ...)] - [(re => func) #'((regexp-match re s) => (lambda (r) (apply func r)))] - [(re base-=> func) #'((regexp-match re s) => (lambda (r) (apply func r)))] - [((re . args) body ...) - #`((regexp-match re s) => - (lambda (r) - (apply (lambda (#,(datum->syntax-object c 'match c) . args) - body ...) - r)))] - [(re body ...) #'((regexp-match re s) body ...)])) - (syntax-case stx () - [(_ str clause ...) - #`(let ([s str]) - (cond #,@(map do-clause (syntax->list #'(clause ...)))))])) diff --git a/pkgs/swindle/patterns.rkt b/pkgs/swindle/patterns.rkt deleted file mode 100644 index 4303061b88..0000000000 --- a/pkgs/swindle/patterns.rkt +++ /dev/null @@ -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)) diff --git a/pkgs/swindle/readme.txt b/pkgs/swindle/readme.txt deleted file mode 100644 index ffd77fd6ed..0000000000 --- a/pkgs/swindle/readme.txt +++ /dev/null @@ -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. - -====< * >=============================================================== diff --git a/pkgs/swindle/setf.rkt b/pkgs/swindle/setf.rkt deleted file mode 100644 index 980dfe6fea..0000000000 --- a/pkgs/swindle/setf.rkt +++ /dev/null @@ -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))))))]))))) diff --git a/pkgs/swindle/swindle-icon.png b/pkgs/swindle/swindle-icon.png deleted file mode 100644 index 75a6c44e6eacd50c8542abd051d807606c00e44a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2486 zcmV;n2}$;eP)9xF9fl{`dhrATcWLGys9ilVA%6Xk{oX;LVJL|DW|K)9HT zi7~#dz4zIj*_oZ`!?IJG(3Gfu=}5Dyng4gr_y5j!W(2<4iUPf=O3%`z;{2v2A!*yV zCr>)r(NT987yym{nOogZxW#)m_V)U=tzRG5xO%l5=5F9@Htimg=RCw#H z<(BJ4KCIRLxeIs~aQ>eJR&LlJy|i^}`0f=eR1718Y06lZpIXg_>((C^MF&|n35Rt) z`6SCT&pd%?uBTkyIbhrSb^srJ)dYlOQuyVw&xU`!X;WM(l_KbR7{dr+nliR6-82D3 zDHDz685$bnvB!QvDD*=Lg?AiXf9^M~JN_%6b|aAQCgA=hOMH8G?@sLK>6t4|O{K_W zl4P@S^7$x*f=00zp`MhAu7{~qLR2ats#O_5a9OyphU0ulfBz3?YFaFa;&*yYvwykk zPP_@&U&es2WQp(9J$q7HWO**xY@9+t^FSKaH)3dLApo77mk9<9qR~8a=1kJuJdUD_ za?d?KAs+u3ic%(>u8~gv^qpGm#HN`{%wiy!6rSC^JF!F4T9}xa%hXg8xm>;SM#Y6f zl*!4t?Ah}K2M>Oe1cL_gc!iTE(~OM#h*&H~DCEPkzSUi+ z90)@3gPSF=@`V@Fy*)j1#dJEw)KnAG(@6@2DA{bBk&!kA2fI0UZVAVZ-NVR8oA+R` zs1XjA>FT;jC{#gFDuly2SFVh5;=~SARY%hbxNZu=_}V?y>N|&lD*%mN5;km*UfQ%N zE{%=FC=@hGrTY0^zTC;VbGI=*-b_9py?)-x7lczNXaKmb;Dw?X-nA^7M5B3h{oA5x ze(xpAdh;7VO}zg6#;se!cb7^L54c=bC>A4}J9itWPA%i|CgIktCarj$yjGF4EC4%;e-8jvrqMz`ge#rK{@#l4KJIR0#yC$g)Xa-wN-y-*4gb z)lif&k;rZ6`u$JY_Wr*~Ky>~3z(&Ied3|o0GSzCpquuYf=<2%2s#Sfow_ha~G+4ZN zko)dCj3Bs(qC+51B^0W7ar(5*#fzJ0Yb$&I*|tO|R3R8N@cY-TvF-iM641MPwH%lU zY}*os5hRmIVA~Si-RD`o`Y7$~S5cJuhK-5@!NupR;rCl8N*PTnpsIPEe|{0M*g7A^_rl$O}dc0Bzq3dBfI)>@(Jwki?RbsIms#-!( z$^-&cFM$U2;jm65lIOYS94=h=9j&by5{V4)c$RQj$F?Q>eha_fA`s|65L$brrAx*6 zqFA@qMmUa$VFU?>b$WXG>F5|Hk*IH`X$8Vz9a%PKB_PWtnT*c1ZAtq3|3qu6LUZ#t zsZ^RoBIAkE=c^$}Hj?BZig(PHnwo^fjqTI$_&e|Xl=k+kB$LxLHBFI9rHMxKsA`FF z+2qtXQ_DPN9Y^%Sb#qzi%o%qWZ0~%0z8Zl*6-_I6l?%csTejRqwfZ8htrf!I(ODv_ zCtwl^Rft52M5B4y+D7Q@J%S*(n5K;5h_iHN+ddrU%;!=*?+y$OR!OC->*BBphjrrd ztatWLJ~;=&c#)Qt9PxPe3tiCgfnd-;QOdNoUZc172pt{6oISgQN+mR_!z{~BwK{_9 z4i8Ack&iwytw$a){jzKl2viY8he)J|rWF_%$Z_o0Z)t0*vyx0sqpBtRe(SoBT+eEQ zL4$eoMp?D0kM8dC6pIn2r;`{)@H%L~Gdk0J-vJIuK<41V>W7a%Ub#OQG?3-`+1968 znb%)Wp{i>Lg~mM>)3gFTJ^id%a}(D2_hy-x(U~SjQlcoC?EYMMuGNvhe9{%a4_Yw$Lo}V{t`O!!Jf*`m6 z%%A@`mo9apC}m=?9HQt@EJhd`YayLZVVW|PN{Dh6dfif=iSh|^~u)&Z>;wA5kjE~xm=8)p@p0}wT$!UyD62_8Ne#VVuW&e=O8$* z&3qql_U*Hue(=HU;dSd2(KKbRZ2|$q18EpkWA@KnV`I%+xw3#vCc(tSTqY;yc%!{k zQYjQPa=94U?7y(A*LDCF%zh)fdg6p7Kkxv(npPi3;c%Hlhai*LjH>G1Aj;=sbaxM; zX+;1=N9Xaz8=Dy%T+Hxr2UAliipBcNYaKLBI-O#2(x6b-{<7<4|KK^%4TboYFZaE^ zXHV)OpD%@?l-av?ik&+@rnR+7bMrWJ=1dZe<_QK3Iy)}|Ff_DqR+}}%rt4t}1?@U3 z66y34AJl4n4>YR3SpopT<;#74-MKUV-Bc=uZRc6Lb_<&JG%YP-G&N13C}nRPH;$%m zF7+Naj3DK*LaC&Z&qtY_*2!d^`bVwSw;3qSs`w@e*b@`(-`{_~qI7gr?_Rb{5n{39 z95}EBNovKmC8||{{2CA@BTgU_+7Kcaf5+I^$q$qV%s8?bq&Kf>{`~Lqqe>8kJnqx`m)V$C4rf%8CVDO z2*RQTKHt~l;1^ssmvNjk!>&6#02~Ca-Rg$_2J%bB`vFTFr2qf`07*qoM6N<$f|v}( A5C8xG diff --git a/pkgs/swindle/swindle-logo.png b/pkgs/swindle/swindle-logo.png deleted file mode 100644 index d07c20bcaa2450bdcce241ea5aaeb9f7bcd0baa4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12785 zcmW+-bzD>L7e?t0=@bMcB$Sj90@5V|q#H(ejU0_gN_R*}cXvyJbPp!dY;?nK-`_s> z?)~rXz4xB;oadb9S>zX0IeZ*y92683dK;-K8--(5R{4S@T>q0IVW=e9Okt_0Z zE8Px3F4)fUx^5^axWxaRFCZ4iKTuHK|4{fWsR>>=?z~N;l}Y(^-#VO--sl8W;J{{X zsF&|~-DH!uTuhM>PH(-3o?*9mwBC9(z9GXWlc%_85M|X zrqhs*uTa#e>1(M4vK-oe3iuX1{`>d0@rs0{J3}G2v7(<$ZyuuD9&S!y!(j`0=iQ^v zPTy~}jC&{ygNJodIkuc$5+!RBG5s=)?0U9ihmiH4vJ}0ba1JE-^7)YI3(BZ zz~yt&hah^tZkkHpK=FnXsc-M3v`E|nOCBC+qt@E<@m>4hY3R z3CZ@M{wCnnegXIn%q^H>PZ9|MnzIRn0MQ$`3mW4VIDY=gq+t9kQ^qI19AaA0$J@j> zP}#GIvWSwctk%Exiz$&9k5C#SVew&;_Qu!_n~-|~9W-+%sz@hY`grqXb@RlgsFJTq zT;!MZ$C`^t>+AhLM5B!~Rt!aab-8$a2FnDo>#B*mpTE%CAl1Us7(%u z_M6hdkm1I(sD;j)3`uD z*w_t43Qgs8krbApw-#l%lp;evO8;JOU6VQGHJ`xcYu{_f?aikN=+gVR9Qt05MXEK| zsNTy(OhkLTx(#nOW^(;Le02-85zOS4r-2>e-0E_Q7=is$O|Y|N6Cl@t{<;doW$>B>pPv3#RE-?=DKmN`+r~$TZG!@59i!(RfSP5t}^U5>|GBlS-mzLocr+;^7E@PZ>mYb zd2PEhca%BJG*hcFhxEPY|4#im0uLqcyVTWTKMDLuE}%jw+*|6<@U2Bj!a&UVCd}WU zZfWsn{^u(v0Qlr%Tz`a;a4ZIMYu3n646E0=`6jfk-)+*7E8E#M8YckliR`?wR&y1&Q; zj==f}#Z>%IWDlA27>3S`23?-$hCc@FdXq&8o{H9U zEx90$b@s-z_V-CnOm!WLL@Yi8$HoG5b#CAfCtmG0!w`32NC5GeE0GlJ9wWz!DRg9| zk^Fky>KxI}Dzy1-|K#Z`55nFP(&a<4xfycU^{MrN!oZ7uDiNHcg-(Y_A4V5OpL)Wd zyn*A+x90-gD!1{OUnByvY78}vS=6((u7yO$J?B20rRsY>-OBv?r)crPvQTs0_d+z$ ze!*;4HIw0a=^y-Q(qz7jr^M;GPpfT#UN3I@z8c8g{SD?9et6eXHBaiviLFKxYlxk^ zQNeKSUr@Ht?}j-^9h1aT=ohuMr6qc`1c9x!N}~K`8ov?{_cP8H#F=& znLUOmU`V%LewlJPDD^BAWY_s^A;M*yf<4)&*M%F}Mlv;~nR`()lwYFY1?Yj*q?$Jf zXdG?{gg#Ty!rl~xCE-#IaoVpm#K#clUFd?k0jt^1P1&-aBV)e&IMCaye_Mirm#D+gFX~B;9vhlrmOjpch#4 z+x&%E)oA_Yw%0cdX26_!FV^m9I2A&80zJ}=lgjsub^y#jpNbA1Rc!C1lD&HMy(Fiu z_1Y+;tBVKYjsnF1b@t|IHEFE7So02Lm>t#@q#04uzxef_L+g1xHbUj_f-!!95dmFE zWL~?DX%naY)$`%7aPxfp+vrp1(^IN9G$`g_he!A7_`D2ApL{{o0b{#5!G}(bTY&c% z6O%csAEu9SP#3Mmf_6K<26ZwF&$KvVEH;)2C}azvc9CMMp>9-!c3mJ-T+#d2P=7?; zR~1nng3drV9JJcx+q#LK0MQ;&%)G0pR=o>M4gKMOri8&hiCkrTK}bX;=u!6B5r?^p#cGY;NoG%RyZA9UXWfrMp zAk-sfkBxDib^~o&l^EO)>9qd-sCal4g(X%ftCKIFZ7k&Ep!D=~6A&l?SQ@wxz*1IJ zJSn}zxb&-tKEm)>7wY|X|72sVviSrW2jTx1ur_#YxqfO2p@%?+hM+>-#1{3zxzB4B z;G462V?pQ2b7Is=qq>6W*+PH=TN5o3YEvxvL_0Fdt5&3pHwAUMsdd#+O zwQTTritKHPMaT3yK{)sJvF|RPp2k7~bbA_&K9~9vqpHjWai^w&Dg;nBPFet(n{;&9 z|D}w_p`)3ZSt#U|A}UUtBu8$)se*wcNZi$KR?mH_ZX|)ONpF3dat)e9(%F?dEQVtI~uEl(!mSW(sZgAP^2m8)7{SPp^f+yeO4sGouj% zy*XltyF+q`n_lX!>rU>fZt=0+5QZ;o$}GW-6n@|=xLU#(o$2{Mz&>1vjWl8ERhwNR z|MHJF3C53#A9&-ps@nh7iMfuwq({Sy{VHnRUJg3~L+BQM>BaS3iPl$5l}~(%EdG;? z#weO=YO&N{gUhMCF~nJohd8R|6?iLCN)dxjTi+`quY$kjK$%wTUExz(4Tt zpT_Wm!s6_WvwRZA>mBu~wz8fwExIf~YJd~t#m%N7OK$`NPQatx$agZqMZ;#%&HE25 zek7Za#%=D2w|xZnN6g6^wBR-w`mjuQ$Ia%Y8dH|T#m(RM@aywKYgp= zTgu8ZqoN{{%Q!gH&amhDT9Z|ZTXU@l#Iy&_rMs-U4Y*nH>7Wy*RbS0>X|eh<^TQH0 z6!Z6-6TF4qJCbS-bHcfOFIv)g92N)ej`*HP1RlKzLI5 zlE$bMi|onVGYolorzZ~P`;V5*T@fa2)J|He*}=^lbuCYKjd=L@ZvVzLrS#`~5qd8c zMbrcV6VvfMb<8;w47$up-as)g)w8K*`9K~TNNAxerROn9)V*dVb`9BeE#`mwEDplN*^op!Qz(GNwTPn}z7BVZLe zM1zkkU?EjiSA`v1P(8Z_aji&6fI3C#pV-}Z1aEPcuTkYxYL_JQrxj|KdbiE0UU+6~ zQLMaJUuVtEruw&wUSFSzNt5>_u#`R0!OJ9rT$Ly&ny9esj2{uywjjT6LP^b-p|_6peoma=+~fks&-~88CJXbmF)EfX3i|=^uiMX<+0#VKK`Zm7l+` zYmY6;I~S`Z6*+t=S|FK`sp2A-dF4)<>DLueS}KVXHpy|+lFEJO%yNAnY^KgD^tSaM z_1;O>!_eeTUbWhmx1}i05yNMXC((E6n_dlb5Q2ZJ$sg1?;;(K_Pf4;!oQE^Sl8!l(?I*H8rUb^i1dCE+PveqqBh zXg-CXe)Rrz3A-e&zYIzO`p`<8oQ-nQr*b!TRToeEY>WfSAv&579m}?CE`S>SRyw-j zDh=46873~S;rNu7Hbd}qpc3#@al|$RNyC)u2bSxj*mi2&-nzTLV`#EOb`QM>gy`%n z?50aUn=ekNvfNLUVM2slrP(F0@Ozke@V17^~VX+{P7GE5qKR8|Q(EDJTKX%D|iD7iRrxvCh> zbn;PF<<{s!h1?>GEixI64WH^YYZP9+p4rl-wcYcLBk1ir4<~V0RV8zmllw6_`Eq?7 z7s==u{P}yKCP563^7Xd!e@w5h`mVdHmmBRe>aF55K@;vFq0Jh0lK8K8h{F1aV6Y(4 z@cfBWlc+*B{t!Cl$~$4znzo&3#xUSMaN~0y?#&Yf>K%bian<iZ(ih{s+8)%3srsj1mDkkPF0+JdQ#;WytgDFmo{9^Dp<;3x3(hEBBmV%9( z(CuK(MRdw0aF$^2ZVIC&Ha$In+eq^!px)fW@Ir~!`QgPcbg8@OSf7sjs;M=DJF#ND zeLZ6&@DjaSb}(2%F<7{>!Cql3FWvhfa|cF1O4PL6Vubjz1C3d(ZLY%&A2T zM;yG{Fpek_t=RISqm!vyCP~>b%b<@f_~>ks;ujD-k=g9L?s1rwb+pxo9)*N5V6U*R z#egLk{DP6&`DE=qvP|~&_1U8~@JHGi_VNnyigiX#iEEHXnR5K_(U}O~!OK$CJN)|0 z%l7Y|ACgyl?=gmySJ_JUp$Z+`Dyk;SB-K$Dwq~1ZC%F6Or2iT%kna4YKU25X_S9Bx zm#^2}zPo>*msel^iMv_HaDq6w$MxgXNMb}$vez=PS{`-n}JGnC@g2 zm6hKE)9nLZ7hH254EU3oBK+DQz=Be@p(}l6MvGSLVEbOY=~(E&cm;LZzEU6deA7}j zwbf5Q9G6+4|CVO05}U+Gw$%LQ$tLNiL(63l?#O%Vt?BY)jyU~oMrclspW*S*J56m+ z@nxlyHBJ~wK|x}c1cY>~?)?O`Df!GL>q8g(YlKm;g0%FoK#0%^GfNYBxLcgd@K<-!AaC7 z=Sxh)qpOuw(8flq?eSq|QL|U9fnzQ8emaII-uo(aj1-qFDGw&*hfLEiUIq!Dhw}@m z)Gi4~XxQNv?(UerSKz%Yrjn5GJZuBwf!`lD6;4 zRc&WAJzU>uKZ?36K}u9yI9Q0Kv`xL-Ny`(~HzhPGJ3HOT`rqlk{8K23rstOTP2_iF zV6$hyTwDykw5jePJ9+n*FZ|L4+QX!`=sU6PILjZY)|GRC+2cVr9CwfG3R@4#iaEp# z#>5o4WWM^_>jLq#ssHYIDG*nj@~*QTeF?k1ntU%TJP3u7iizDGaKw1x@QniYhmh8g_@OQ@)`7uQpoEPxC##!3czq z5ZSQlpk4g34N4^g4BFeh)wpN?0tH8_ZN=B>#wfNX;Z(}Z`YJx@*PJ}eu@BB^#uEw_ z5$3YWYaYtn!T%ywJ(&T*R`_6G!}ois?QM(a;gLj-EHXBoWdv7|k+qQBefx(KLXnTGpUcpjOPX9(}q6+!%(MmzDv{0+b;9 z)$yah$+sxQTloo+nPphWN!v@8#x5|A#3DJ;(!`uqxyum+x+r^8qUA@O6xPIL$=VxZ z@B3pK@6$mNbMu|i&9wuAPt<$NdzX)1XOH}uE$pPEyOTDwZ@)n!UwBR5F)4Dr)Af)G zc})Dtn+RH#(%QiDTxvNTvKB1VRUCy(rXsK8F$zXxxX+BB?=&+*`{M=f%NKUo*eg}1J=7khhbf?;&p z*%Nnd{4lPQK${XmwQCEOQa1%b-#4-6#!JoccF}8tc%N6JS}l_F%`0}aKD3@K-}yCn zXY34cz*DmZZG~*4CeAf4z{EwY9FkG8Ow)V2{7VYM13{=t!N}sBO=h3r7?RX%UfFD3 z#A7KB($)QtzRFJijO%;7G3YjBv*BAE2(0wOH_Edrd;$^f-*x&l21q*5JB~622Ecq8CcYu&R@dSt8n(mvYzGc4y3Q>c_Cn* zRoEr!@GXVk$goV2P&y)bxe|Hp7wmA>+-Ju7>&ZOiT*&nsFABuGkt5b0SNhcQO zF$0Hc?Qu0pV;O@oUliXIVX+txADwEkQfH@QyeH_?a<_J;vPaSsWQ=o}%54hKOd8lI ziP83BJQIfh8023xrGzNe-WaOpJkTJ4AywPh67*Ak z8ojjk=NsHM%o6WRyxut6sciPUg7bXfgE58bdz2Y)AJw!~HC8mK03V6u!Q#f565mj+ zOE(9ON6E)r_mAE+-~+_J#z>%5YWl<<38Jxc&P#nWDN>x~eOW`y6q00!Rr`{0A%6}u zx^t|o<^*zg7s&NXu$-cgL&YRVBI%3j1DZHvnCt&BzyA9~VAG#s7yM#Uu+i~(YSSAj z?ZuZNAsR}-bY5SVnlh~`<+Lp*Wr@h`Dc9wfa zAi3l0ENYg-=Ey0GTrQ3ymi|)Mt@x8TTx+*pWmc`@WT%f{ml)a5XgVLKg49BvTmx5| zG%izl&^KbfdVzLs>{h{C;iC(i2 zlegQ>M$1jooMPVGqS!Y;lL*7L2fxRJMbP1JW-2H{@^g^Vik@=Y0Fp#4+uMxP6aeY` zjqN_YTJ54{@0Q6&7*6JNra#`_-`tq@&J@t^PPUFurm!XVp?l6Cibs!yboSc*u<(0z z@T=yusI(V?{@XhB17##-`I}<$7W3U-$I%8`>b|S!215yBNhEDJsi^J5T_Fy3_P%7r z-h^R&gdhFy$i;8+QYD_3cYA_9XlO|Oa(rDB6y~@(B3;LJR7h3Q!kEVIyNKh%xAY&F zdy=Q+!X2?Yv=nGWRy}LDK-NcEfl8r!D0TQT#Qrhegc2oU9;PrZOi!^3L_1#kxT+}J zMK$Y&!1t;GIw9nL1vj>E{UgoZO(MFd9rExKWwuHJN1R=+ao!KS2al6>LT|5j5`1s) zj=+_DBy{`PYIS;@s|@IfA;dYoB8ydi@-LCPSl4_ot{qszM-^e;#4v{A`QiZ@Lf3JT zU;^KeVPy?YJA2*H+6ZH5k+p7m5aQ}!pKy-4-Z}0$f#))2a@E#MYwZT8Ca!$lEK>2L z3V)qgYUxm+u`hK&WLO&iuiW9f-P*WWb7^bgOVja>F?@4MiJi69lACLYaX%aaM=V=e z8Z5q9B6Roex>#w%Ap8X6SE#q1=WpB~I6@LWGn_;a%IYKc-D`IbY#-lOQdyyUpT3C) z$INB|{>?Ug((LOG*X2HfcFGC*3P_1g%oIrM3{v>sE<(6mPk)9a(WfiBUMQ7+8fsxx zJnYX5V=K`;L~i{!yT8tWcG$7(PiE;g|9;i8D)PDPmEyw-NH&6qP_ax46`d3ARDFdD zHGe#D;i1|xc(TG0CLBK>KF2)XGr*d=Cr*bY$kVbtu&y5s4(xSl-7nncfN{fqZ>bz@ z{JjA+008cM1Ix^%Po)__LVhu3J{ED|+R45`w9*vQ&iC*4wOLs8bjdmPzgiviVUixd zLE3Ky`26nnVMu*~$`j6A(?ThVRk^*o@&m!Fl1z>=V+&3pPfkQ@Z}+8VCo2LrF)hn( z-?e!b#Aax*qjP?hZ)+oA5e*?K|55jfQLz+1#o&;J*C8vzVvQM~a~FT6Abx-3k^>R% z&vYVZPgW#Tnc1+{MJfzH2Fwk`N}(trW zs~t{d_BOps1+uTkC-Aokb{V!PaQYueC}Cg(^RLcW_=6rN2$^=UfYkWFge!5QRduhJ zAcEdqWe{1{v-#EWYOfMca;y7D=@VBKamMB5F{S-XEtqpxDPfUI;ZJ7oBuELr_VzSs zdjiTW(-yLoZ35P*v(=iNFA$S&C1!WSQn%+Av56^Y)amPM*NgvYnNB&>{4wA`(#S`_ z`NEp_0;lp6jGteEF5W=XlLi7eC7cOgfNI=YWkRPt4v!0Jq@(=VZ2?cbbKMka#TGEx z<@iAk4AF?B%y?H6c8UzW3Y!?}Yxzdp%{oCKo9H+IUSTqoBV*7kI2nrx7!Z(YfAoT4 zkb58wwY~TuX|tkEGx9miOU3*1A9a7$^s~$z_o?caFg&l#zFBV568xJTQ|kVTQP70) zF#b&WFKgnwK>{g%Jt$=HM(;i0Y{QQ;{VWj=+;%TtW!1K1cqc|bTfn5VYjL(tlQ80! ztyjR>gGMSyEJl*1R8-9G$-fg8(#e0~GsMU^Ipzrrfqr9AsdF_H*+-@8$O)R*5Y^b}lE z7#~xE%CPvPWKA=RQ>_aJg$^V27mt4(6;eBr$B$7REivl0CU^!~#k<VvZ_d;d{}p<8O@4|Xi$Zcl&!MCsygBjpBE+i3 zwa8+aAU#c8M6w9iM69^=Rljgxk`YIXr|rYi-4u0yOUB3u&CP{I?_AR6g{1BQ-0}l? zxpuY5YSX2Gn+gvqs%70W6`ncX^i6=!&KXL5z1>H*;+|7jK^DL(#nroZGKdsZBCm)? z$%=_ruNoHc5;+d(vUge9ab)Pv zD-xFveQ4en86$6sf{0dIz%E>JvEY^}V{9X9LPxztWDzzr)NOLw9G?)XwzT+5()7rR zc<+pnhTg;5R&y-i?gh7)FI&~^4&cNjxNv^Bc`>>ZIcnhNIywbjnX;z*YE3J9e=K~& zD{1O}>u%>kw+S4uzVX#g?X7I4E=@0d6@+X0X2*kaNU*TuQ_UJ{Cqqnen1P}|G`AlF zP*9Ma1=uACXAwBxZuER&69Lp8t+j>$PAEan2#3%cF$8-&<~GewTC^(@-RfG<#2a@n zNJM`Aah8Zc?5@g!B%xi}qCm#9kULHohKb)eUFs391DNwNJLL@zSLWrscIMFv%g9bj zyn#?)7r|@?-RuL=)Yw}oCoAD34DMgZQM>*}?>{D>;v^h^gL^z0AhC9-%m0nn+WYb8 zX@;O@OyOh{k#`v;^AiD~EuYn<&=!sEnd#^j`2;;N7>mo*g&LPTTv4rOFUo546}-|o z#k-QV0e`ZMSkj|Msthson~R5s1h6$u`gl(U_>G5o#jR}xA_U47W*-oZ@K2-3q&Rkz zbXrM@F{K5mg60(OQuI50(1kWTVtac#d#VEy8=7f;UmoyyO!$huX^OpxHhH%0 zDHh2r^-qDlm)ouHe0~Z zn<+FX2~bnfj_61P8)45zi)#g$GnQ=^bnOeLt#}KV{JcatKNk#>;+p$tg1mF{j$Ftw%+*wsEy5 zgnvDLS(PhC*tJ>H`*$m1qUq|D6Se_XWRj4HE+JCiMLf1*V8=-jz7g8aJCukpv9v_Z z91Rr#Qt@%9%t%s=-NtsR34o!f=D*>~L;9wjib@-;HG-s0bxVh#Ib^70#g;W#*EyKsvm=1fe$ zpF$DaJQ-7pC^~%8kxFKy4dqx!CF#R*+x+%_JN0t1#RWruu7+ER0e_tFeHMz1=_A|? zVEkw)k7!-^1vGkU`hlXzuE>J93Gd@=<9-fxN9h!fRmwNn5;mO2ngtuv39U$la8+zY z>j3gHC1V$#0-_=qnwA=s_#4Ml@k9f2`gu==nj{9VAtAt`gIBp0;5le9`oz7pVPU<- zaEFvqsw!j8xgQ8b&X#&#dn|xP-!S&$f{d;4yV)t}ZO4FzZ`tdg_eF9=B3&c?8J|le zKw+n_jiqg{3OhKT~lauTo`j><&uHVt^3k*&yeeOt*%DE^{rZ9}`Iwo~2 zy^ZpmpDc&GmAV;wJ2&J;D6vxCAqU)7F_z>v7=(GN?l{oI(0@HeT)3i|f>ZyM}<&VDd)4zNvZ)?TVqw#tkEpi_5Wmyqk!Q77Zp!#ab&;Vi&W16#KX9wEcHP z?W5OZfdPHr`GJ=^)*F>XCiRueEEdVwXW7SV*7WF!$LrOH$IZ-(ORjZcBhYA^K-#~! z5ex3TxpKB0W?6OC(k5!=FSc1#Rqq$7*1tI@(Uv?Wtt-r53s_BN?Ix=E>>oYQKR&+d z!R;AHFrkQ2bKd?O)E_aNmVL~!#wR9{ysR2;TJGYTktC$(@g=OLb%#9DDyMd-#l`z? z3VH{q@tL-W^~-^OgC|X33Hsl#A9RW;i4!>{upz+SVPbTQz$RCzM^=-C%gh$E*WBIH zXlg=8LPkxEQ0f8KIin{eWdYA_=FXQCN6q!dIh;`9;oGT841BRpoJ*jLU$@PUAkp(R zreSy(T;G1(_I#XAuzBrImsWsGAm%hzVF&(d08SBT`VOl%r|1%&7-Mh#wH%Gvi!qVD zaD17s)sxPrX7}w}g-RJFj*db8_XO(PPUgFlxpiiPs>Q1b{}iQNnL~)wVIux?!Hb*ICC(y)2Jyb%zh#>2mw!J!?)P_i+8#3|B6Tsu(>+ot z&>6lu)~BLsjosK#u)h}ts-jXC-MOp_yn9#iw+|iJgnZO z%W_Salqi5v)}e9RXdt&Z=D3IOtROUbo?!&ljGSo8Cmqn)yAg zUkmKG{wOWwqm>AFvD(C|g35^21=rvPv{cE(=W}oiNKsJm(;Y?6)ZVAKa&GlhA*3Nj|wqv2&og%i}F3A@%swTOmza zPrp7{_H;@xv4L@XX!RFolB%v0NMma~oBw$(|46KCSD{J^|JTfo4Lm}zq#cH*UPXg1 zh-6ekY7exrJ2kYCpeN%{;TfVvYP#4^PIZH8QbR+?c2&D4VpqZn>Gb2#68R~B?|Ehx z`p@lnpBw64>L}L+>&d*_jD1CEUH;V)d{p~RO~S!-LO@$kcbiPLlby&6zxei5-7>Az z!zPwXmNgDByB1znlyJe>dlv+Cdy$l))gFy=d zVeuhTm$+zu!oS-Xej)YrOR3zjw57SLn`)P&{hmiH3H)ob|(F6!~$c zTlj#+u2c%-E{cO?6_y{8owPgA++STH-C5!}ig)jD z(pu|@LYjAiPEFnirFd}?0hV|TJlJ6L_Pt@=0C`rvZ$!wZy&X*{-XE`^iFL)J@;giS zH=C~B6t3pe-)}Z|&!-$@(%}C)!Oj_jq2mLj74XEbr zi5CxK?=l&Mkh=L5JDep^S6#RKO0G~;ttHXldH@}G_-02}M8xQCj<2B0-``(zkQ23l zuJE{- zn?4W>V{3Mp&Rr3E8Pc$iC5`#&)^0b8KHWS|4n~D^+?DmY*pkrnVbR7#E zxh|t5_lfG(FU4z9OIVf2l@$Lt21BhW6Wy$}2gc#wYVK5|jDex-*g5|%^6k5>M+eT_JHe2;RxHSH#}bEwtnqmc8u1XMV8+Z$a}ZTr6W+)7uxbqxf4h8{OVdY*3>65_=5 z2Cn-Zcn>I04OGp#ie4IzF12HbP{vq%ki=Udgjk#q4X4-y8L)YzpO0CoNtqa*TM1b9P$3|sd+ur@f=0t0DDiKw@t%Uky!>jGmF7K)@X z{I9`QF=v(cMdbD@Hu;88M&8QO%xtzyn-gI=G62lPMV56dc z@(CmuTf_nDG<^L;U#X@!_bBf7%&V8mJ3+&q3K`hyZ$3XL7dzTGKE2)L9{d?c#CUTx zYqc1l(V)2>Eue)z8qLv8m@5v`**Sf?bYfy#prl!8ZOnK4-1Y1#@z0tl>f04zj%E&$jfYKC`sRd zPs0rGq+Ii>w^$V%DbtFdF!FxBPJU;jXaN|xkgAXVdVJzlzjp`xVSC^^gf`VSRKCCnbmsgQQN6UY$4$sdwQNkX>3HjKqyF-KB(KWD`!r4F& zLTBPb&B}^4JIgCXVgHe8-A_w#Z$GH2>UA~P$*E>a+o?LQ99Kl-*AdRe1R5<51ifeW zdzCN4KyQ@DewASGuNRM;CMyjOWT?-^ETs<+)_0h;77eA?|NV1AK}Pj+m6S>F{{SZs BoAdwx diff --git a/pkgs/swindle/swindle.scrbl b/pkgs/swindle/swindle.scrbl deleted file mode 100644 index 0a252507d9..0000000000 --- a/pkgs/swindle/swindle.scrbl +++ /dev/null @@ -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.} - -] diff --git a/pkgs/swindle/tiny-clos.rkt b/pkgs/swindle/tiny-clos.rkt deleted file mode 100644 index a1647de142..0000000000 --- a/pkgs/swindle/tiny-clos.rkt +++ /dev/null @@ -1,2327 +0,0 @@ -;;; Heavily hacked by Eli Barzilay: Maze is Life! (eli@barzilay.org) - -;;> This module is the core object system. It is a heavily hacked version -;;> of the original Tiny-CLOS code from Xerox, but it has been fitted to -;;> Racket, optimized and extended. See the source file for a lot of -;;> details about how the CLOS magic is created. -;;> -;;> [There is one difference between Swindle and Tiny-CLOS: the meta object -;;> hierarchy is assumed to be using only single inheritance, or if there is -;;> multiple inheritance then the built in meta objects should come first to -;;> make the slots allocated in the same place. This should not be a -;;> problem in realistic situations.] - -;;; Original copyright: -;;; *************************************************************************** -;;; Copyright (c) 1992 Xerox Corporation. All Rights Reserved. -;;; -;;; Use, reproduction, and preparation of derivative works are permitted. Any -;;; copy of this software or of any derivative work must include the above -;;; copyright notice of Xerox Corporation, this paragraph and the one after it. -;;; Any distribution of this software or derivative works must comply with all -;;; applicable United States export control laws. -;;; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ALL -;;; WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, AND -;;; NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY LIABILITY FOR -;;; DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS EXPRESSLY DISCLAIMED, -;;; WHETHER ARISING IN CONTRACT, TORT (INCLUDING NEGLIGENCE) OR STRICT -;;; LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED OF THE POSSIBILITY OF SUCH -;;; DAMAGES. -;;; *************************************************************************** - -#lang s-exp swindle/base - -;;; A very simple CLOS-like language, embedded in Scheme, with a simple MOP. -;;; The features of the default base language are: -;;; * Classes, with instance slots, but no slot options. -;;; * Multiple-inheritance. -;;; * Generic functions with multi-methods and class specializers only. -;;; * Primary methods and call-next-method; no other method combination. -;;; * Uses Scheme's lexical scoping facilities as the class and generic -;;; function naming mechanism. Another way of saying this is that class, -;;; generic function and methods are first-class (meta)objects. -;;; -;;; While the MOP is simple, it is essentially equal in power to both MOPs in -;;; AMOP. This implementation is not at all optimized, but the MOP is designed -;;; so that it can be optimized. In fact, this MOP allows better optimization -;;; of slot access extenstions than those in AMOP. -;;; -;;; In addition to calling a generic, the entry points to the default base -;;; language are: -;;; -;;; (MAKE-CLASS list-of-superclasses list-of-slot-names) -;;; (MAKE-GENERIC-FUNCTION) -;;; (MAKE-METHOD list-of-specializers procedure) -;;; (ADD-METHOD generic method) -;;; -;;; (MAKE class . initargs) -;;; (INITIALIZE instance initargs) ; Add methods to this, dont call directly. -;;; -;;; (SLOT-REF object slot-name) -;;; (SLOT-SET! object slot-name new-value) -;;; (SLOT-BOUND? object slot-name) -;;; -;;; So, for example, one might do: -;;; (define (make-class (list ) (list 'x 'y))) -;;; (add-method initialize -;;; (make-method (list ) -;;; (lambda (call-next-method pos initargs) -;;; (for-each (lambda (initarg-name slot-name) -;;; (slot-set! pos slot-name -;;; (getarg initargs initarg-name 0))) -;;; '(x y) -;;; '(x y))))) -;;; (set! p1 (make 'x 1 'y 3)) -;;; -;;; NOTE! Do not use EQUAL? to compare objects! Use EQ? or some hand written -;;; procedure. Objects have a pointer to their class, and classes are -;;; circular structures, and... -;;; -;;; The introspective part of the MOP looks like the following. Note that -;;; these are ordinary procedures, not generics. -;;; * CLASS-OF -;;; INSTANCE-OF? -;;; SUBCLASS? -;;; * CLASS-DIRECT-SUPERS -;;; CLASS-DIRECT-SLOTS -;;; CLASS-CPL -;;; CLASS-SLOTS -;;; CLASS-NAME -;;; * GENERIC-METHODS -;;; GENERIC-ARITY -;;; GENERIC-NAME -;;; GENERIC-COMBINATION -;;; * METHOD-SPECIALIZERS -;;; METHOD-PROCEDURE -;;; METHOD-NAME -;;; -;;; The intercessory protocol looks like (generics in uppercase): -;;; ELI: All of these are generic functions now! -;;; MAKE -;;; ALLOCATE-INSTANCE -;;; INITIALIZE (really a base-level generic) -;;; class initialization -;;; COMPUTE-CPL -;;; COMPUTE-SLOTS -;;; COMPUTE-GETTER-AND-SETTER -;;; method initialization -;;; COMPUTE-APPLY-METHOD -;;; ADD-METHOD (Notice this is not a generic!) [eli: yes!] -;;; COMPUTE-APPLY-GENERIC -;;; COMPUTE-METHODS -;;; COMPUTE-METHOD-MORE-SPECIFIC? -;;; COMPUTE-APPLY-METHODS - -;;; OK, now let's get going. But, as usual, before we can do anything -;;; interesting, we have to muck around for a bit first. First, we need to -;;; load the support library. [-- replaced with a module.] -(require swindle/misc - racket/undefined) - -;; This is a convenient function for raising exceptions -(define (raise* exn-maker fmt . args) - (let ([sym (and (symbol? fmt) - (begin0 fmt - (when (null? args) (error 'raise* "got too few arguments")) - (set! fmt (car args)) (set! args (cdr args))))] - [fmt-num (- (length args) (procedure-arity exn-maker) -2)]) - (when (< fmt-num 0) - (error 'raise* "got too few arguments")) - (let loop ([fmt-args '()] [args args] [a fmt-num]) - (if (zero? a) - (raise (exn-maker - (if sym - (apply format (concat "~s: " fmt) sym (reverse fmt-args)) - (apply format fmt (reverse fmt-args))) - (current-continuation-marks) . args)) - (loop (cons (car args) fmt-args) (cdr args) (sub1 a)))))) - -;; A simple topological sort. -;; It's in this file so that both TinyClos and Objects can use it. -;; This is a fairly modified version of code I originally got from Anurag -;; Mendhekar . -(define (compute-std-cpl c get-direct-supers) - (top-sort (build-transitive-closure get-direct-supers c) - (build-constraints get-direct-supers c) - (std-tie-breaker get-direct-supers))) -(define (top-sort elements constraints tie-breaker) - (let loop ([elements elements] [constraints constraints] [result '()]) - (if (null? elements) - result - (let ([can-go-in-now - (filter (lambda (x) - (every (lambda (constraint) - (or (not (eq? (cadr constraint) x)) - (memq (car constraint) result))) - constraints)) - elements)]) - (if (null? can-go-in-now) - (error 'top-sort "invalid constraints") - (let ([choice (if (null? (cdr can-go-in-now)) - (car can-go-in-now) - (tie-breaker result can-go-in-now))]) - (loop (filter (lambda (x) (not (eq? x choice))) elements) - constraints (append result (list choice))))))))) -(define (std-tie-breaker get-supers) - (lambda (partial-cpl min-elts) - (let loop ([pcpl (reverse partial-cpl)]) - (let* ([current-elt (car pcpl)] - [ds-of-ce (get-supers current-elt)] - [common (filter (lambda (x) (memq x ds-of-ce)) min-elts)]) - (if (null? common) - (if (null? (cdr pcpl)) - (error 'std-tie-breaker "nothing valid") (loop (cdr pcpl))) - (car common)))))) -(define (build-transitive-closure get-follow-ons x) - (let track ([result '()] [pending (list x)]) - (if (null? pending) - result - (let ([next (car pending)]) - (if (memq next result) - (track result (cdr pending)) - (track (cons next result) - (append (get-follow-ons next) (cdr pending)))))))) -(define (build-constraints get-follow-ons x) - (let loop ([elements (build-transitive-closure get-follow-ons x)] - [this-one '()] - [result '()]) - (if (or (null? this-one) (null? (cdr this-one))) - (if (null? elements) - result - (loop (cdr elements) - (cons (car elements) (get-follow-ons (car elements))) - result)) - (loop elements - (cdr this-one) - (cons (list (car this-one) (cadr this-one)) result))))) - -;;; Then, we need to build what, in a more real implementation, would be the -;;; interface to the memory subsystem: instances and entities. The former are -;;; used for instances of instances of ; the latter are used for -;;; instances of instances of . In this MOP, none of this is -;;; visible to base- or MOP-level programmers. -;;; A few things to note, that have influenced the way all this is done: -;;; - R4RS doesn't provide a mechanism for specializing the -;;; behavior of the printer for certain objects. -;;; - Some Scheme implementations bomb when printing circular structures -- -;;; that is, arrays and/or lists that somehow point back to themselves. -;;; So, the natural implementation of instances -- vectors whose first field -;;; point to the class -- is straight on out. Instead, we use a procedure to -;;; `encapsulate' that natural representation. -;;; Having gone that far, it makes things simpler to unify the way normal -;;; instances and entities are handled, at least in the lower levels of the -;;; system. Don't get faked out by this -- the user shouldn't think of normal -;;; instances as being procedures, they aren't. (At least not in this -;;; language.) If you are using this to teach, you probably want to hide the -;;; implementation of instances and entities from people. - -;;>> ??? -;;> This is Racket's `unspecified' value which is used as the default -;;> value for unbound slots. It is provided so you can check if a slot is -;;> unbound. -(define* ??? undefined) -(define unspecified-initializer (lambda args ???)) -(define false-func (lambda args #f)) - -;; Basic allocation follows, all was in a single let, but this is not needed -;; with Racket's modules. Also modified to use simple structs for -;; everything, including entities since PLT has applicable struct objects. - -(define-values (struct:instance make-instance instance? inst-ref inst-set!) - ;; slots: applicable, class, function, slots-vector - (make-struct-type 'swindleobj #f 3 0 #f '() (current-inspector) - (lambda (o . args) (apply (instance-proc o) args)))) -(defsubst (instance-class x) (inst-ref x 0)) -(defsubst (instance-proc x) (inst-ref x 1)) -(defsubst (instance-slots x) (inst-ref x 2)) -(defsubst (set-instance-class! x c) (inst-set! x 0 c)) -(defsubst (set-instance-proc! x p) (inst-set! x 1 p)) -(defsubst (set-instance-slots! x s) (inst-set! x 2 s)) - -(defsubst (%instance-ref o f) (vector-ref (instance-slots o) f)) -(defsubst (%instance-set! o f n) (vector-set! (instance-slots o) f n)) - -(define (%allocate-instance class nfields) - (make-instance class - (lambda args - (error 'instance - "an instance isn't a procedure -- can't apply it")) - (make-vector nfields ???))) - -(define (%allocate-entity class nfields) - (letrec ([o (make-instance - class - (lambda args - (error 'entity - "tried to call an entity before its proc is set")) - (make-vector nfields ???))]) - o)) - -;; This is used only once as part of bootstrapping the braid. -(define (set-instance-class-to-self! class) - (set-instance-class! class class)) - -;;>>... -;;> *** Low level functionality -;;> (These functions should be used with caution, since they make shooting -;;> legs in exotic ways extremely easy.) - -;;>> (change-class! object new-class initargs ...) -;;> This operation changes the class of the given `object' to the given -;;> `new-class'. The way this is done is by creating a fresh instance of -;;> `new-class', then copying all slot values from `object' to the new -;;> instance for all shared slot names. Finally, the new instance's set -;;> of slots is used for the original object with the new class, so it -;;> preserves its identity. -(define* (change-class! obj new-class . initargs) - (let ([new (make new-class . initargs)] - [new-slots (%class-slots new-class)]) - (dolist [slot (%class-slots (class-of obj))] - (when (and (not (eq? :class (getarg (cdr slot) :allocation :instance))) - (assq (car slot) new-slots)) - (slot-set! new (car slot) (slot-ref obj (car slot))))) - (set-instance-slots! obj (instance-slots new)) - (set-instance-class! obj new-class))) - -;; This might be cute for some ugly hacks but not needed for now. -;; Copies the contents of source to target, making it an "alias" object. This -;; is no re-provided by clos.rkt, but maybe it will in the future... -;; (define* (copy-object-contents! target source) -;; (set-instance-class! target (instance-class source)) -;; (set-instance-proc! target (instance-proc source)) -;; (set-instance-slots! target (instance-slots source))) - -;;>> (set-instance-proc! object proc) -;;> This function sets the procedure of an entity object. It is useful -;;> only for making new entity classes. -(provide set-instance-proc!) ; dangerous! - -;; Basic allocation ends here. - -;;>>... -;;> *** Basic functionality - -;;>> (instance? x) -;;>> (object? x) -;;> These two are synonyms: a predicate that returns #t for objects that -;;> are allocated and managed by Swindle. -(provide instance?) -(define* object? instance?) - -;;>> (class-of x) -;;> Return the class object of `x'. This will either be a Swindle class -;;> for objects, or a built-in class for other Scheme values. -;;; %allocate-instance, %allocate-entity, %instance-ref, %instance-set! and -;;; class-of are the normal interface, from the rest of the code, to the -;;; low-level memory system. One thing to take note of is that the protocol -;;; does not allow the user to add low-level instance representations. I have -;;; never seen a way to make that work. -;;; Note that this implementation of class-of assumes the name of a the -;;; primitive classes that are set up later. -(define* (class-of x) - ;; This is an early version that will be modified when built-in types are - ;; introduced later. - (if (instance? x) (instance-class x) )) - -;;; Now we can get down to business. First, we initialize the braid. -;;; For Bootstrapping, we define an early version of MAKE. It will be changed -;;; to the real version later on. -(define* (make class . initargs) - (cond [(or (eq? class ) (eq? class )) - (let* ([new (%allocate-instance class - (length the-slots-of-a-class))] - [dsupers (getarg initargs :direct-supers '())] - [dslots (map list (getarg initargs :direct-slots '()))] - [cpl (let loop ([sups dsupers] [so-far (list new)]) - (if (null? sups) - (reverse so-far) - (loop (append (cdr sups) - (%class-direct-supers (car sups))) - (if (memq (car sups) so-far) - so-far - (cons (car sups) so-far)))))] - [slots - (apply append dslots (map %class-direct-slots (cdr cpl)))] - [nfields 0] - [name (or (getarg initargs :name) '-anonymous-)] - [field-initializers '()] - ;; this is a temporary allocator version, kept as the original - ;; one in tiny-clos. the permanent version below is modified. - [allocator - (lambda (init) - (let ([f nfields]) - (set! nfields (+ nfields 1)) - (set! field-initializers (cons init field-initializers)) - (mcons (lambda (o) (%instance-ref o f)) - (lambda (o n) (%instance-set! o f n)))))] - [getters-n-setters - (map (lambda (s) - (cons (car s) (allocator unspecified-initializer))) - slots)]) - (%set-class-direct-supers! new dsupers) - (%set-class-direct-slots! new dslots) - (%set-class-cpl! new cpl) - (%set-class-slots! new slots) - (%set-class-nfields! new nfields) - (%set-class-field-initializers! new (reverse field-initializers)) - (%set-class-getters-n-setters! new getters-n-setters) - (%set-class-name! new name) - (%set-class-initializers! new '()) ; no class inits now - (%set-class-valid-initargs! new #f) ; no initargs now - new)] - [(eq? class ) - (let ([new (%allocate-entity class (length (%class-slots class)))] - [arity (getarg initargs :arity #f)] - [name (or (getarg initargs :name) '-anonymous-)]) - (%set-generic-methods! new '()) - (%set-generic-arity! new arity) - (%set-generic-name! new name) - (%set-generic-combination! new #f) - new)] - [(eq? class ) - (let ([new (%allocate-entity class (length (%class-slots class)))] - [name (or (getarg initargs :name) '-anonymous-)]) - (%set-method-specializers! new (getarg initargs :specializers)) - (%set-method-procedure! new (getarg initargs :procedure)) - (%set-method-qualifier! new (or (getarg initargs :qualifier) - :primary)) - (%set-method-name! new name) - (set-instance-proc! new (method:compute-apply-method #f new)) - new)])) - -;;; These are the real versions of slot-ref and slot-set!. Because of the way -;;; the new slot access protocol works, with no generic call in line, they can -;;; be defined up front like this. Cool eh? - -;;>> (slot-ref obj slot) -;;> Pull out the contents of the slot named `slot' in the given `obj'. -;;> Note that slot names are usually symbols, but can be other values as -;;> well. -(define* (slot-ref object slot-name) - ((lookup-slot-info (class-of object) slot-name mcar) object)) -(defsubst (%slot-ref object slot-name) - ((lookup-slot-info (class-of object) slot-name mcar) object)) - -;;>> (slot-set! obj slot new) -;;> Change the contents of the `slot' slot of `obj' to the given `new' -;;> value. -(define* (slot-set! object slot-name new-value) - ((lookup-slot-info (class-of object) slot-name mcdr) object new-value)) -(defsubst (%slot-set! object slot-name new-value) - ((lookup-slot-info (class-of object) slot-name mcdr) object new-value)) -;;>> (set-slot-ref! obj slot new) -;;> An alias for `slot-set!', to enable using `setf!' on it. -(define* set-slot-ref! slot-set!) - -;; This is a utility that is used to make locked slots -(define (make-setter-locked! g+s key error) - (let ([setter (mcdr g+s)]) - (set-mcdr! g+s - (lambda (o n) - (cond [(and (pair? n) (eq? key (car n)) (not (eq? key #t))) - (setter o (cdr n))] - [(eq? ??? ((mcar g+s) o)) (setter o n)] - [else (error)]))))) - -;;>> (slot-bound? object slot) -;;> Checks if the given `slot' is bound in `object'. See also `???' -;;> above. -(define* (slot-bound? object slot-name) - (not (eq? ??? (%slot-ref object slot-name)))) - -(define (lookup-slot-info class slot-name selector) - (selector (cdr (or (assq slot-name - ;; no need to ground slot-ref any more! -- see below - ;; (if (eq? class ) - ;; ;;* This grounds out the slot-ref tower - ;; getters-n-setters-for-class - ;; (%class-getters-n-setters class)) - (%class-getters-n-setters class)) - (raise* make-exn:fail:contract - "slot-ref: no slot `~.s' in ~.s" - slot-name class))))) - -;;; These are for optimizations - works only for single inheritance! -(define (%slot-getter class slot-name) - (lookup-slot-info class slot-name mcar)) -(define (%slot-setter class slot-name) - (lookup-slot-info class slot-name mcdr)) - -;;>>... Singleton and Struct Specifiers - -;;; Singleton class. A hash-table is used so it is still possible to compare -;;; classes with eq?. -(define singleton-classes (make-hash-table 'weak)) -;;>> (singleton x) -;;> Returns a singleton specification. Singletons can be used as type -;;> specifications that have only one element in them so you can -;;> specialize methods on unique objects. -;;> -;;> This is actually just a list with the symbol `singleton' in its head -;;> and the value, but this function uses a hash table to always return -;;> the same object for the same value. For example: -;;> => (singleton 1) -;;> (singleton 1) -;;> => (eq? (singleton 1) (singleton 1)) -;;> #t -;;> but if the input objects are not `eq?', the result isn't either: -;;> => (eq? (singleton "1") (singleton "1")) -;;> #f -;;> Only `eq?' is used to compare objects. -(define* (singleton x) - (or (hash-table-get singleton-classes x false-func) - (let ([c (list 'singleton x)]) - (hash-table-put! singleton-classes x c) - c))) -;;>> (singleton? x) -;;> Determines if something is a singleton specification (which is any -;;> list with a head containing the symbol `singleton'). -(define* (singleton? x) - (and (pair? x) (eq? (car x) 'singleton))) -(defsubst (%singleton? x) - (and (pair? x) (eq? (car x) 'singleton))) -;;>> (singleton-value x) -;;> Pulls out the value of a singleton specification. -(define* singleton-value cadr) - -;;>>... -;;> Also note that Racket struct types are converted to appropriate -;;> Swindle classes. This way, it is possible to have Swindle generic -;;> functions that work with struct type specializers. - -;;>> (struct-type->class struct-type) -;;> This function is used to convert a struct-type to a corresponding -;;> Swindle subclass of `'. See the Racket manual for details -;;> on struct types. -(define struct-to-class-table (make-hash-table)) -(define* (struct-type->class stype) - (hash-table-get - struct-to-class-table stype - (thunk - (let-values ([(name init-field-k auto-field-k accessor mutator - immutable-k-list super skipped?) - (struct-type-info stype)]) - (let* ([supers (list (cond [super (struct-type->class super)] - [skipped? ] - [else ]))] - [proc? (procedure-struct-type? stype)] - [supers (if proc? (cons supers) supers)] - [this (parameterize ([*default-object-class* #f]) - (make (if proc? ) - :name name :direct-supers supers))]) - (hash-table-put! struct-to-class-table stype this) - this))))) - -;;>>... -;;> *** Common accessors - -;;; Given that the early version of MAKE is allowed to call accessors on class -;;; metaobjects, the definitions for them come here, before the actual class -;;; definitions, which are coming up right afterwards. -;;>> (class-direct-slots class) -;;>> (class-direct-supers class) -;;>> (class-slots class) -;;>> (class-cpl class) -;;>> (class-name class) -;;>> (class-initializers class) -;;> Accessors for class objects (look better than using `slot-ref'). -(define* (class-direct-slots c) (%slot-ref c 'direct-slots)) -(define* (class-direct-supers c) (%slot-ref c 'direct-supers)) -(define* (class-slots c) (%slot-ref c 'slots)) -(define (class-nfields c) (%slot-ref c 'nfields)) -(define (class-field-initializers c) (%slot-ref c 'field-initializers)) -(define (class-getters-n-setters c) (%slot-ref c 'getters-n-setters)) -(define* (class-cpl c) (%slot-ref c 'cpl)) -(define* (class-name c) (%slot-ref c 'name)) -(define* (class-initializers c) (%slot-ref c 'initializers)) -(define (class-valid-initargs c) (%slot-ref c 'valid-initargs)) -;;>> (generic-methods generic) -;;>> (generic-arity generic) -;;>> (generic-name generic) -;;>> (generic-combination generic) -;;> Accessors for generic function objects. -(define* (generic-methods g) (%slot-ref g 'methods)) -(define* (generic-arity g) (%slot-ref g 'arity)) -(define* (generic-name g) (%slot-ref g 'name)) -(define* (generic-combination g) (%slot-ref g 'combination)) -;;>> (method-specializers method) -;;>> (method-procedure method) -;;>> (method-qualifier method) -;;>> (method-name method) -;;>> (method-arity method) -;;> Accessors for method objects. `method-arity' is not really an -;;> accessor, it is deduced from the arity of the procedure (minus one for -;;> the `call-next-method' argument). -(define* (method-specializers m) (%slot-ref m 'specializers)) -(define* (method-procedure m) (%slot-ref m 'procedure)) -(define* (method-qualifier m) (%slot-ref m 'qualifier)) -(define* (method-name m) (%slot-ref m 'name)) -(define* (method-arity m) - (let ([a (procedure-arity (%method-procedure m))]) - (cond [(integer? a) (sub1 a)] - [(arity-at-least? a) - (make-arity-at-least (sub1 (arity-at-least-value a)))] - [else (error 'method-arity "the procedure in ~.s has bad arity ~e" - m a)]))) - -;;; These versions will be optimized later. -(define %class-direct-slots class-direct-slots) -(define %class-direct-supers class-direct-supers) -(define %class-slots class-slots) -(define %class-nfields class-nfields) -(define %class-field-initializers class-field-initializers) -(define %class-getters-n-setters class-getters-n-setters) -(define %class-cpl class-cpl) -(define %class-name class-name) -(define %class-initializers class-initializers) -(define %class-valid-initargs class-valid-initargs) -(define %generic-methods generic-methods) -(define %generic-arity generic-arity) -(define %generic-name generic-name) -(define %generic-combination generic-combination) -(define %method-specializers method-specializers) -(define %method-procedure method-procedure) -(define %method-qualifier method-qualifier) -(define %method-name method-name) - -(define (%set-class-direct-slots! c x) (%slot-set! c 'direct-slots x)) -(define (%set-class-direct-supers! c x) (%slot-set! c 'direct-supers x)) -(define (%set-class-slots! c x) (%slot-set! c 'slots x)) -(define (%set-class-nfields! c x) (%slot-set! c 'nfields x)) -(define (%set-class-field-initializers! c x) - (%slot-set! c 'field-initializers x)) -(define (%set-class-getters-n-setters! c x) - (%slot-set! c 'getters-n-setters x)) -(define (%set-class-cpl! c x) (%slot-set! c 'cpl x)) -(define (%set-class-name! c x) (%slot-set! c 'name x)) -(define (%set-class-initializers! c x) (%slot-set! c 'initializers x)) -(define (%set-class-valid-initargs! c x) (%slot-set! c 'valid-initargs x)) -(define (%set-generic-methods! g x) (%slot-set! g 'methods x)) -(define (%set-generic-arity! g x) (%slot-set! g 'arity x)) -(define (%set-generic-name! g x) (%slot-set! g 'name x)) -(define (%set-generic-combination! g x) (%slot-set! g 'combination x)) -(define (%set-method-specializers! m x) (%slot-set! m 'specializers x)) -(define (%set-method-procedure! m x) (%slot-set! m 'procedure x)) -(define (%set-method-qualifier! m x) (%slot-set! m 'qualifier x)) -(define (%set-method-name! m x) (%slot-set! m 'name x)) - -;;; These are used to access the two slots that optimize generic invocations. -(define (%generic-app-cache g ) (%slot-ref g 'app-cache)) -(define (%generic-singletons-list g ) (%slot-ref g 'singletons-list)) -(define (%set-generic-app-cache! g x) (%slot-set! g 'app-cache x)) -(define (%set-generic-singletons-list! g x) (%slot-set! g 'singletons-list x)) - -;;; The next 7 clusters define the 6 initial classes. It takes 7 to 6 because -;;; the first and fourth both contribute to . - -(define the-slots-of-a-class - '(direct-supers ; (class ...) - direct-slots ; ((name . options) ...) - cpl ; (class ...) - slots ; ((name . options) ...) - nfields ; an integer - field-initializers ; (proc ...) - getters-n-setters ; ((slot-name getter setter) ...) - name ; a symbol - initializers ; (proc ...) - valid-initargs)) ; (initarg ...) or #f -(define getters-n-setters-for-class ; see lookup-slot-info - (map (lambda (s) - (let ([f (position-of s the-slots-of-a-class)]) - (cons s (mcons (lambda (o) (%instance-ref o f)) - (lambda (o n) (%instance-set! o f n)))))) - the-slots-of-a-class)) - -;;>>... -;;> *** Basic classes - -;;>> -;;> This is the "mother of all classes": every Swindle class is an -;;> instance of `'. -;;> Slots: -;;> * direct-supers: direct superclasses -;;> * direct-slots: direct slots, each a list of a name and options -;;> * cpl: class precedence list (classes list this to ) -;;> * slots: all slots (like direct slots) -;;> * nfields: number of fields -;;> * field-initializers: a list of functions to initialize slots -;;> * getters-n-setters: an alist of slot-names, getters, and setters -;;> * name: class name (usually the defined identifier) -;;> * initializers: procedure list that perform additional initializing -;;> See the `clos' documentation for available class and slot keyword -;;> arguments and their effect. -(define* (%allocate-instance #f (length the-slots-of-a-class))) -(set-instance-class-to-self! ) - -;; In the original tiny-clos, this block used to just set the getters-n-setters -;; slot of a class to '() since it wasn't used anyway. In Swindle the MOP -;; accessors are all optimized to directly get the vector element because the -;; meta hierarchy is assumed to be single-inheritance only (allocation of more -;; slots always come after the built in ones), so what I do here is set the -;; slot value properly, and since `%class-getters-n-setters' accesses the -;; vector directly it doesn't go through slot-ref, which means that the -;; slot-ref definition above is fine. So, -;; (%set-class-getters-n-setters! getters-n-setters-for-class) -;; translates into this: -((mcdr (cdr (assq 'getters-n-setters getters-n-setters-for-class))) - getters-n-setters-for-class) -;; and now the direct `%class-getters-n-setters' version: -(set! %class-getters-n-setters - ;; and (lookup-slot-info 'getters-n-setters mcar) translates to: - (mcar (cdr (assq 'getters-n-setters getters-n-setters-for-class)))) - -;;>> -;;> This is the "mother of all values": every value is an instance of -;;> `' (including standard Scheme values). -(define* (make :direct-supers '() - :direct-slots '() - :name ')) - -;;>> -;;> This is the "mother of all objects": every Swindle object is an -;;> instance of `'. -(define* (make :direct-supers (list ) - :direct-slots '() - :name ')) - -;;; This cluster, together with the first cluster above that defines -;;; and sets its class, have the effect of: -;;; (define -;;; (make :direct-supers (list ) -;;; :direct-slots '(direct-supers ...) -;;; :name ')) -(%set-class-direct-supers! (list )) -(%set-class-cpl! (list )) -(%set-class-direct-slots! (map list the-slots-of-a-class)) -(%set-class-slots! (map list the-slots-of-a-class)) -(%set-class-nfields! (length the-slots-of-a-class)) -(%set-class-field-initializers! (map (lambda (s) - unspecified-initializer) - the-slots-of-a-class)) -(%set-class-name! ') -(%set-class-initializers! '()) -(%set-class-valid-initargs! #f) - -;;>> -;;> The class of all procedures classes, both standard Scheme procedures -;;> classes and entity (Swindle procedure objects) classes. (Note that -;;> this is a class of *classes*). -(define* - (make :direct-supers (list ) - :direct-slots '() - :name ')) - -;;>> -;;> The class of entity classes -- generic functions and methods. An -;;> entity is a procedural Swindle object, something that you can apply as -;;> a function but it is still a Swindle object. Note that this is the -;;> class of entity *classes* not of entities themselves. -(define* - (make :direct-supers (list ) - :direct-slots '() - :name ')) - -;;>> -;;> The class of all applicable values: methods, generic functions, and -;;> standard closures. -(define* - (make :direct-supers (list ) - :direct-slots '() - :name ')) - -;;; The two extra slots below (app-cache and singletons-list) are used to -;;; optimize generic invocations: app-cache holds an 'equal hash-table that -;;; maps a list of classes to the lambda expression that holds the method call -;;; (it used to be an l-hash-table, but 'equal is ok since we can't compare -;;; swindleobj instances recursively -- which is also why tool.rkt needs to -;;; redefine the `render-value/format' method). The contents of this slot is -;;; reset whenever a method is added to the generic. Two problems make things -;;; a little more complicated. First, if add-method is used to modify any of -;;; the generic-invocation-generics then all of these caches should be flushed, -;;; this is achieved by setting *generic-app-cache-tag* to a new [list] object -;;; and the value of app-cache is a cons of that value and the actual hash -;;; table - if we see that the car is not eq? to the current tag, then we flush -;;; the cache. Second, singleton values might screw things up, so we hold in -;;; singletons-list a list that has the same length as all method specializer -;;; lists, each element contains a hash table with all singleton values that -;;; appear in that place matched to #t, then when we try to see if we have a -;;; cached function for a generic application, we scan the argument list -;;; against this list, and any value that has a singleton with that value at -;;; some method, is left in place for the app-cache lookup (it is used itself -;;; rather than its class). This whole thing is a bit complicated but leads to -;;; dramatic run-time improvement. -;;>> -;;> The class of generic functions: objects that contain method objects -;;> and calls the appropriate ones when applied. -;;> Slots: -;;> * methods: a list of objects -;;> * arity: the generic arity (same for all of its methods) -;;> * name: generic name -;;> * combination: a method combination function or #f, see -;;> `make-generic-combination' below for details -(define* - (make :direct-supers (list ) - :direct-slots '(methods arity name combination - app-cache singletons-list) ; see above - :name ')) - -;;>> -;;> The class of methods: objects that are similar to Scheme closures, -;;> except that they have type specifiers attached. Note that in contrast -;;> to Tiny CLOS, methods are applicable objects in Swindle -- they check -;;> supplied argument types when applied. -;;> Slots: -;;> * specializers: a list of class (and singleton) specializers -;;> * procedure: the function (never call directly!) -;;> * qualifier: some qualifier tag, used when applying a generic -;;> * name: method name -(define* - (make :direct-supers (list ) - :direct-slots '(specializers procedure qualifier name) - :name ')) -;; Do this since compute-apply-method relies on them not changing, as well as a -;; zillion other places. A method should be very similar to a lambda. -(dolist [slot '(specializers procedure qualifier)] - (make-setter-locked! (lookup-slot-info slot values) #t - (lambda () - (raise* make-exn:fail:contract - "slot-set!: slot `~.s' in is locked" slot)))) - -;;>>... -;;> *** Convenience functions -;;> -;;> These are some convenience functions -- no new syntax, just function -;;> wrappers for `make' with some class and some slot values. See `clos' -;;> for a more sophisticated (and convenient) approach. - -;;; These are the convenient syntax we expose to the base-level user. -;;>> (make-class direct-supers direct slots) -;;> Creates a class object -- an instance of . -(define* (make-class direct-supers direct-slots) - (make :direct-supers direct-supers - :direct-slots direct-slots)) -;;>> (make-generic-function [name/arity]) -;;> Creates a generic function object -- an instance of . The -;;> argument can specify name and/or arguments number. -(define* (make-generic-function . name/arity) - (cond - [(null? name/arity) (make )] - [(null? (cdr name/arity)) - (let ([n/a (car name/arity)]) - (if (integer? n/a) - (make :arity n/a) (make :name n/a)))] - [else (make :name (car name/arity) :arity (cadr name/arity))])) -;;>> (make-method specializers procedure) -;;> Creates a method object -- an instance of , using the given -;;> specializer list and procedure. The procedure should have a first -;;> argument which is being used to access a `call-next-method' call. -(define* (make-method specializers procedure) - (make :specializers specializers - :procedure procedure)) - -;;>> (no-next-method generic method [args ...]) -;;>> (no-applicable-method generic [args ...]) -;;> These two generic functions are equivalents to the ones in CL. The -;;> first one is applied on a generic and a method in case there was no -;;> next method and `call-next-method' was used. The second is used when -;;> a generic was called but no matching primary methods were found. The -;;> only difference is that in Swindle methods can be applied directly, -;;> and if `call-next-method' is used, then `no-next-method' gets `#f' for -;;> the generic argument. -(define* no-next-method (make-generic-function 'no-next-method)) -(define* no-applicable-method (make-generic-function 'no-applicable-method)) - -;;; Add possibility of generic-independent method application - this is the -;;; instance-proc of methods, which is activated when you apply the object (in -;;; the original, methods could not be applied). This is defined using this -;;; name and arguments because it is later used directly by the generic -;;; function (cannot use the generic in the initial make since methods need to -;;; be created when the generics are constructed). -(define (method:compute-apply-method call-next-method method) - (let* ([specializers (%method-specializers method)] - [*no-next-method* ; see the *no-next-method* trick below - (lambda args (no-next-method #f method . args))] - [proc (%method-procedure method)] - [arity (method-arity method)] - [exact? (integer? arity)] - [required ((if exact? identity arity-at-least-value) arity)]) - (when (and exact? (> (length specializers) required)) - (error 'compute-apply-method - "got ~e specializers for ~s - too much for procedure arity ~a" - (length specializers) (%method-name method) required)) - (lambda args - (cond [(if exact? - (not (= (length args) required)) (< (length args) required)) - (raise* make-exn:fail:contract:arity - "method ~a: expects ~a~e argument~a, given ~e~a" - (%method-name method) - (if exact? "" "at least ") required - (if (= 1 required) "" "s") (length args) - (if (null? args) "" (format ": ~e" args)))] - [(not (every instance-of? args specializers)) - (let loop ([args args] [specs specializers]) - (if (instance-of? (car args) (car specs)) - (loop (cdr args) (cdr specs)) - (raise* make-exn:fail:contract - "method ~a: expects argument of type ~a; given ~e" - (%method-name method) (%class-name (car specs)) - (car args))))] - [else (proc *no-next-method* . args)])))) - -;;>>... Generics in the instance initialization protocol -;;> The following generic functions are used as part of the protocol of -;;> instantiating an instance, and some are used specifically to instantiate -;;> class objects. - -;;; The instance structure protocol. -;;>> (allocate-instance class initargs) -;;> This generic function is called to allocate an instance of a class. -;;> It is applied on the class object, and is expected to return the new -;;> instance object of that class. -(define* allocate-instance - (make-generic-function 'allocate-instance)) -;;>> (initialize instance initargs) -;;> This generic is called to initialize an instance. It is applied on -;;> the newly allocated object and the given initargs, and is not expected -;;> to return any meaningful value -- only do some side effects on the -;;> instance to initialize it. When overriding this for a some class, it -;;> is not a good idea to skip `call-next-method' since it is responsible -;;> for initializing slot values. -(define* initialize - (make-generic-function 'initialize)) -;;>> (compute-getter-and-setter class slot allocator) -;;> This generic is used to get a getter and setter functions for a given -;;> slot. It is passed the class object, the slot information (a list of -;;> a slot name and options), and an allocator function. The allocator is -;;> a function that gets an initializer function and returns an index -;;> position for the new slot. The return value should be a list of two -;;> elements -- a getter and a setter functions. -(define* compute-getter-and-setter - (make-generic-function 'compute-getter-and-setter)) -;;; The class initialization protocol. -;;>> (compute-cpl class) -;;> This generic is used to get the class-precedence-list for a class -;;> object. The standard object uses the `compute-std-cpl' (see -;;> in the code) which flattens the class ancestors using a topological -;;> sort that resolve ambiguities left-to-right. -(define* compute-cpl - (make-generic-function 'compute-cpl)) -;;>> (compute-slots class) -;;> This generic is used to compute all slot information for a given -;;> class, after its precedence list has been computed. The standard -;;> collects information from all preceding classes. -(define* compute-slots - (make-generic-function 'compute-slots)) - -;;>> (compute-apply-method method) -;;> This generic is used to compute the procedure that will get executed -;;> when a method is applied directly. -(define* compute-apply-method - (make-generic-function 'compute-apply-method)) - -;;>>... Generics in the generic invocation protocol -;;> These generics are used for invocation of generic functions. See the -;;> code to see how this circularity is achieved. - -;;>> ((compute-apply-generic generic) args ...) -;;> This generic is used to compute the object (a closure) that is -;;> actually applied to execute the generic call. The standard version -;;> uses `compute-method' and `compute-apply-methods' below, and caches -;;> the result. -(define* compute-apply-generic - (make-generic-function 'compute-apply-generic)) -;;>> (compute-methods generic args) -;;> Computes the methods that should be applied for this generic -;;> invocation with args. The standard code filters applicable methods -;;> and sorts them according to their specificness. The return value is -;;> expected to depend only on the types of the arguments (and values if -;;> there are singleton specializers). -(define* compute-methods - (make-generic-function 'compute-methods)) -;;>> ((compute-method-more-specific? generic) mthd1 mthd2 args) -;;> Get a generic and return a function that gets two methods and a list -;;> of arguments and decide which of the two methods is more specific. -;;> This decision should only be based on the argument types, or values -;;> only in case of singletons. -(define* compute-method-more-specific? - (make-generic-function 'compute-method-more-specific?)) -;;>> ((compute-apply-methods generic methods) args ...) -;;> Gets a generic and returns a function that gets the given arguments -;;> for this call. This function which it returns is the combination of -;;> all given methods. The standard one arranges them by default using -;;> the `call-next-method' argument that methods have. Swindle extends -;;> this with qualified methods and applies `before', `after', and -;;> `around' methods in a similar way to CLOS: first the `around' methods -;;> are applied (and they usually call their `call-next-method' to -;;> continue but can return a different value), then all the `before' -;;> methods are applied (with no `call-next-method'), then all `primary' -;;> methods as usual (remembering the return value), and finally the -;;> `after' methods (similar to the `before', but in reverse specificness -;;> order). If the generic has a `combination' slot value, then it is a -;;> procedure that is used to combine the primary methods, but the -;;> auxiliary ones are still applied in the same way. This is unlike CLOS -;;> where the standard combinations run only `around' methods, and there -;;> is generally more control with method combinations, but in Swindle -;;> `compute-apply-methods' should be overridden for this. See -;;> `make-generic-combination' for details about method combinations. -(define* compute-apply-methods - (make-generic-function 'compute-apply-methods)) - -;;; The next thing to do is bootstrap generic functions. - -(define generic-invocation-generics - (list compute-apply-generic compute-methods - compute-method-more-specific? compute-apply-methods)) - -;;; This is used to signal whenever all method caches are to be reset - so when -;;; a method is added to generic-invocation-generics, this is set to some value -;;; which is not eq? to the current one. -(define *generic-app-cache-tag* #t) - -;;>> (add-method generic method) -;;> This generic function is called to add a method to a generic function -;;> object. This is an other change from the original Tiny CLOS where it -;;> was a normal function. -(define* (add-method generic method) - ;; add singleton specializer value (if any) to the corresponding hash table - ;; in singletons-list. - (define (add-to-singletons-list specs tables) - (cond - [(null? specs) null] - [(%singleton? (car specs)) - (let ([ht (or (car tables) - (make-hash-table 'weak))]) - (hash-table-put! ht (singleton-value (car specs)) #t) - (cons ht (add-to-singletons-list (cdr specs) (cdr tables))))] - [else - (cons (car tables) - (add-to-singletons-list (cdr specs) (cdr tables)))])) - (define (n-falses n) - (let loop ([n n] [r '()]) (if (zero? n) r (loop (sub1 n) (cons #f r))))) - (let ([tables (%generic-singletons-list generic)] - [specs (%method-specializers method)] - [qualifier (%method-qualifier method)]) - ;; make sure that tables always contain enough hash tables (or #f's) - (cond [(eq? tables ???) - (set! tables (n-falses (length specs)))] - [(< (length tables) (length specs)) - (set! tables (append - tables - (n-falses (- (length specs) (length tables)))))]) - (set! tables (add-to-singletons-list specs tables)) - (%set-generic-singletons-list! generic tables) - (if (memq generic generic-invocation-generics) - ;; reset all caches by changing the value of *generic-app-cache-tag* - (set! *generic-app-cache-tag* (list #f)) - ;; reset this generic app-cache - (%set-generic-app-cache! generic ???)) - (%set-generic-methods! - generic - (cons method - (filter (lambda (m) - (not (and (every eq? (method-specializers m) specs) - (eq? (%method-qualifier m) qualifier)))) - (%generic-methods generic)))) - (set-instance-proc! generic (compute-apply-generic generic)))) - -;;; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls the -;;; other generics in the generic invocation protocol. Two, related, problems -;;; come up. A chicken and egg problem and a infinite regress problem. -;;; In order to add our first method to COMPUTE-APPLY-GENERIC, we need -;;; something sitting there, so it can be called. The first definition below -;;; does that. -;;; Then, the second definition solves both the infinite regress and the not -;;; having enough of the protocol around to build itself problem the same way: -;;; it special cases invocation of generics in the invocation protocol. - -(set-instance-proc! compute-apply-generic - (lambda (generic) - ((%method-procedure (car (%generic-methods generic))) '() generic))) - -(add-method compute-apply-generic - (make-method (list ) - (named-lambda method:compute-apply-generic (call-next-method generic) - #| The code below is the original, then comes the optimized version below - ;; see the definition of the class above. - (lambda args - (if (and (memq generic generic-invocation-generics) ;* Ground case - (memq (car args) generic-invocation-generics)) - (apply (%method-procedure (last (%generic-methods generic))) #f args) - ((compute-apply-methods generic) - (compute-methods generic args) . args))) - |# - ;; This function converts the list of arguments to a list of keys to look - ;; for in the cache - use the argument's class except when there is a - ;; corresponding singleton with the same value at the same position. - (define (get-keys args tables) - (let loop ([args args] [tables tables] [ks '()]) - (if (or (null? tables) (null? args)) - (reverse ks) - (loop (cdr args) (cdr tables) - (cons (if (and (car tables) - (hash-table-get - (car tables) (car args) false-func)) - (car args) - (class-of (car args))) - ks))))) - ;; This is the main function that brings the correct value from the - ;; cache, or generates one and store it if there is no entry, or the - ;; cache was reset. Finally, it is applied to the arguments as usual. - ;; NOTE: This code is delicate! Handle with extreme care! - (lambda args - (let ([app-cache (%generic-app-cache generic)] - [arity (%generic-arity generic)] - [keys (get-keys args (%generic-singletons-list generic))] - [ground? (and ;* Ground case - (memq generic generic-invocation-generics) - (pair? args) - (memq (car args) generic-invocation-generics))]) - ;; This function creates the cached closure -- the assumption is that - ;; `keys' contain a specification that will identify all calls that - ;; will have this exact same list. - (define (compute-callable) - (let ([c (if ground? - (let ([m (%method-procedure - (last (%generic-methods generic)))]) - (lambda args (apply m #f args))) - (compute-apply-methods - generic (compute-methods generic args)))]) - (hash-table-put! (cdr app-cache) keys c) - c)) - (when (cond [(not arity) #f] - [(integer? arity) (not (= (length args) arity))] - [else (< (length args) (arity-at-least-value arity))]) - (let ([least (and (arity-at-least? arity) - (arity-at-least-value arity))]) - (raise* make-exn:fail:contract:arity - "generic ~a: expects ~a~e argument~a, given ~e~a" - (%generic-name generic) - (if least "at least " "") (or least arity) - (if (= 1 (or least arity)) "" "s") (length args) - (if (null? args) "" (format ": ~e" args))))) - (when (or (eq? app-cache ???) - (not (eq? (car app-cache) *generic-app-cache-tag*))) - (set! app-cache (cons *generic-app-cache-tag* - (make-hash-table 'weak 'equal))) - (%set-generic-app-cache! generic app-cache)) - ((hash-table-get (cdr app-cache) keys compute-callable) - . args)))))) - -(add-method compute-methods - (make-method (list ) - (named-lambda method:compute-methods (call-next-method generic args) - (let ([more-specific? (compute-method-more-specific? generic)]) - (sort (filter - (lambda (m) - ;; Note that every only goes as far as the shortest list - (every instance-of? args (%method-specializers m))) - (%generic-methods generic)) - (lambda (m1 m2) (more-specific? m1 m2 args))))))) - -(add-method compute-method-more-specific? - (make-method (list ) - (named-lambda method:compute-method-more-specific? - (call-next-method generic) - (lambda (m1 m2 args) - (let loop ([specls1 (%method-specializers m1)] - [specls2 (%method-specializers m2)] - [args args]) - (cond [(and (null? specls1) (null? specls2)) - (if (eq? (%method-qualifier m1) (%method-qualifier m2)) - (error 'generic - "two methods are equally specific in ~e" generic) - #f)] - ;; some methods in this file have less specializers than - ;; others, for things like args -- so remove this, leave the - ;; args check but treat the missing as if it's - ;; ((or (null? specls1) (null? specls2)) - ;; (error 'generic - ;; "two methods have different number of ~ - ;; specializers in ~e" generic)) - [(null? args) ; shouldn't happen - (error 'generic - "fewer arguments than specializers for ~e" generic)] - [(null? specls1) ; see above -> treat this like - (if (eq? (car specls2)) - (loop specls1 (cdr specls2) (cdr args)) - #f)] - [(null? specls2) ; see above -> treat this like - (if (eq? (car specls1)) - (loop (cdr specls1) specls2 (cdr args)) - #t)] - [else (let ([c1 (car specls1)] [c2 (car specls2)]) - (if (eq? c1 c2) - (loop (cdr specls1) (cdr specls2) (cdr args)) - (more-specific? c1 c2 (car args))))])))))) - -(add-method compute-apply-methods - (make-method (list ) - (named-lambda method:compute-apply-methods - (call-next-method generic methods) - (let ([primaries '()] [arounds '()] [befores '()] [afters '()] - [combination (%generic-combination generic)]) - ;; *** Trick: this (and in above) is the only code that is - ;; supposed to ever apply a method procedure. So, the closure that - ;; will invoke `no-next-method' is named `*no-next-method*' so it is - ;; identifiable. The only way to break this would be to call the - ;; method-procedure directly on an object with such a name. - (define one-step - (if combination - (combination generic) - (lambda (tail args) - (lambda newargs - ;; tail is never null: (null? (cdr tail)) below, and the fact - ;; that this function is applied on the primaries which are - ;; never null - (let ([args (if (null? newargs) args newargs)]) - ((cdar tail) - (if (null? (cdr tail)) - (named-lambda *no-next-method* args - (no-next-method generic (caar tail) . args)) - (one-step (cdr tail) args)) - . args)))))) - (define ((apply-before/after-method args) method) - ((cdr method) - (named-lambda *no-next-method* args - (no-next-method generic (car method) . args)) - . args)) - (define ((call-before-primary-after args) . newargs) - ;; could supply newargs below, but change before calling befores - (let ([args (if (null? newargs) args newargs)]) - (for-each (apply-before/after-method args) befores) - (begin0 ((one-step primaries args)) - (for-each (apply-before/after-method args) afters)))) - (define (one-around-step tail args) - (if (null? tail) - (call-before-primary-after args) - (lambda newargs - (let ([args (if (null? newargs) args newargs)]) - ((cdar tail) (one-around-step (cdr tail) args) . args))))) - ;; first sort by qualifier and pull out method-procedures - (let loop ([ms methods]) - (unless (null? ms) - (letsubst ([(push! p) - (set! p (cons (cons (car ms) - (%method-procedure (car ms))) - p))]) - (case (%method-qualifier (car ms)) - [(:primary) (push! primaries)] - [(:around) (push! arounds)] - [(:before) (push! befores)] - [(:after) (push! afters)] - ;; ignore other qualifiers - ;; [else (error 'compute-apply-methods - ;; "a method ~e has an unexpected qualifier `~e'" - ;; (car methods) - ;; (%method-qualifier (car methods)))] - ) - (loop (cdr ms))))) - (set! primaries (reverse primaries)) - (set! arounds (reverse arounds)) - (set! befores (reverse befores)) - ;; no reverse for afters - (cond [(null? primaries) - (lambda args (no-applicable-method generic . args))] - ;; optimize common case of only primaries - [(and (null? befores) (null? afters) (null? arounds)) - ;; args is initialized to () since if it is a generic of no - ;; arguments then it will always stay so, otherwise, the first - ;; call will have the real arguments anyway - (one-step primaries '())] - [else (one-around-step arounds '())]))))) - -;;>> (((make-generic-combination keys...) generic) tail args) -;;> This function can be used to construct simple method combinations that -;;> can be used with the `combination' slot of generic functions. The -;;> combination itself is a function that gets a generic and returns a -;;> function that gets a list of method/procedure pairs (for optimization -;;> the method-procedures are pre taken) and the arguments and performs -;;> the call -- but this is only interesting if there's any need to -;;> implement a method combination directly, otherwise, the -;;> `make-generic-combination' interface should allow enough freedom. -;;> Note that when a method combination is used, `around', `before', and -;;> `after' are called around the primary call as usual, but the primaries -;;> are never called with a valid `call-next-method' argument. -;;> -;;> The keyword arguments that can be taken determine the behavior of this -;;> combination. Overall, it is roughly like a customizable version of a -;;> fold operation on the method calls. -;;> * :init -;;> - The initial value for this computation. Defaults to null. -;;> * :combine -;;> - A function to be called on a method call result and the old value, -;;> and produces a new value. The default is `cons', which with an -;;> initial null value will collect the results into a reversed list. -;;> * :process-methods -;;> - A function that can be called on the initial list of -;;> method/procedure pairs to change it -- for example, it can be -;;> reversed to apply the methods from the least specific to the most -;;> specific. No default. -;;> * :process-result -;;> - A function that can be called on the final resulting value to -;;> produce the actual return value. For example, it can reverse back -;;> a list of accumulated values. No default. -;;> * :control -;;> - If this parameter is specified, then the `:combine' argument is -;;> ignored. The value given to `:control' should be a function of -;;> four arguments: -;;> 1. a `loop' function that should be called on some new value and -;;> some new tail; -;;> 2. a `val' argument that gets the current accumulated value; -;;> 3. a `this' thunk that can be called to apply the current method -;;> and return its result; -;;> 4. a `tail' value that holds the rest of the method/procedure list -;;> which can be sent to `loop'. -;;> It should be clear now, that a `:control' argument can have a lot -;;> of control on the computation, it can abort, change arbitrary -;;> values and skip calling methods. Note that if it won't call -;;> `loop' with an empty list, then a `:process-result' function will -;;> not be used as well. See the pre-defined combinations in the -;;> source code to see examples of using this function. -(define* (make-generic-combination - &key [init '()] [combine cons] - process-methods process-result control) - (lambda (generic) - (lambda (tail dummy-args) - (let ([tail (if process-methods (process-methods tail) tail)]) - (lambda args - (let loop ([res init] [tail tail]) - ;; see *no-next-method* trick above - (let ([*no-next-method* - (lambda args (no-next-method generic (caar tail) . args))]) - (if (null? tail) - (if process-result (process-result res) res) - (if control - (control loop res - (lambda () ((cdar tail) *no-next-method* . args)) - (cdr tail)) - (loop (combine ((cdar tail) *no-next-method* . args) res) - (cdr tail))))))))))) - -;;>> generic-+-combination -;;>> generic-list-combination -;;>> generic-min-combination -;;>> generic-max-combination -;;>> generic-append-combination -;;>> generic-append!-combination -;;>> generic-begin-combination -;;>> generic-and-combination -;;>> generic-or-combination -;;> These are all functions that can be used as a `combination' value for -;;> a generic function. They work in the same way as the standard method -;;> combinations of CL. Most of them do the obvious thing based on some -;;> function to combine the result. The `begin' combination simply -;;> executes all methods one by one and returns the last value, the `and' -;;> and `or' combinations will call them one by one until a false or true -;;> result is returned. The source of these can be used as templates for -;;> defining more combinations. -(define* generic-+-combination - (make-generic-combination :init 0 :combine +)) -(define* generic-list-combination - (make-generic-combination :process-result reverse)) -(define* generic-min-combination - (make-generic-combination :process-result (lambda (r) (apply min r)))) -(define* generic-max-combination - (make-generic-combination :process-result (lambda (r) (apply max r)))) -(define* generic-append-combination - (make-generic-combination - :process-result (lambda (r) (apply append (reverse r))))) -(define* generic-append!-combination - (make-generic-combination - :process-result (lambda (r) (apply append (reverse r))))) -(define* generic-begin-combination - (make-generic-combination :init #f :combine (lambda (x y) x))) -(define* generic-and-combination - (make-generic-combination - :init #t - :control (lambda (loop val this tail) (and val (loop (this) tail))))) -(define* generic-or-combination - (make-generic-combination - :init #f - :control (lambda (loop val this tail) (or (this) (loop #f tail))))) - -;;>>... -;;> *** More class functionality -;;> (In the following, a `class' can be a class, a singleton specifier, or a -;;> struct type.) - -;; optimized helper -(defsubst (%struct->class c) - (if (struct-type? c) (struct-type->class c) c)) - -;;>> (subclass? class1 class2) -;;> Is `class1' a subclass of `class2'? -(define* (subclass? c1 c2) - (if (%singleton? c1) - (if (%singleton? c2) - (eq? (singleton-value c1) (singleton-value c2)) - (instance-of? (singleton-value c1) (%struct->class c2))) - (memq (%struct->class c2) (%class-cpl (%struct->class c1))))) - -;;>> (instance-of? x class) -;;> Checks if `x' is an instance of `class' (or one of its subclasses). -(define* (instance-of? x c) - ;; efficiency: many cases use (all untyped arguments) - (or (eq? c ) - (if (%singleton? c) - ;; efficiency: similar to `subclass?' above - (eq? (singleton-value c) x) - (memq (%struct->class c) (%class-cpl (%struct->class (class-of x))))))) - -;;>> (class? x) -;;> Determines whether `x' is a class. -(define* (class? x) (instance-of? x )) -(defsubst (%class? x) (instance-of? x )) - -;;>> (specializer? x) -;;> Determines whether `x' is a class, a singleton, or a struct-type. -(define* (specializer? x) (or (class? x) (%singleton? x) (struct-type? x))) - -;;>> (more-specific? class1 class2 x) -;;> Is `class1' more specific than `class2' for the given value? -(define* (more-specific? c1 c2 arg) - (if (%singleton? c1) - (and (eq? (singleton-value c1) arg) - (not (and (%singleton? c2) (eq? (singleton-value c1) arg)))) - (let ([cc1 (memq (%struct->class c1) (%class-cpl (class-of arg)))]) - (and cc1 (memq (%struct->class c2) (cdr cc1)))))) - -(add-method initialize - (make-method (list ) - (named-lambda method:initialize (call-next-method object initargs) - (error 'initialize "can't initialize an instance of ~e" - (class-of object))))) - -(add-method initialize - (make-method (list ) - (named-lambda method:initialize (call-next-method object initargs) - (let* ([class (class-of object)] - [field-initializers (%class-field-initializers class)]) - (for-each (lambda (init) (init . initargs)) - (%class-initializers class)) - (let loop ([n 0] [inits field-initializers]) - (when (pair? inits) - (%instance-set! object n ((car inits) . initargs)) - (loop (+ n 1) (cdr inits)))))))) - -(add-method initialize - (make-method (list ) - (named-lambda method:initialize (call-next-method class initargs) - (call-next-method) - (%set-class-direct-supers! - class - (let ([default (*default-object-class*)] - [supers (getarg initargs :direct-supers)]) - ;; check valid supers, and always have an object class - (cond - [(not default) supers] ; check disabled - [(or (not supers) (null? supers)) (list default)] - [(not (list? supers)) (error 'class "bad superclasses: ~e" supers)] - [else (let ([c (find-if - (lambda (c) - (not (and (%class? c) (subclass? c default)))) - supers)]) - (if c - (error 'class "cannot inherit from a ~a, ~e" - (if (%class? c) "non-object class" "non-class") c) - supers))]))) - (%set-class-direct-slots! - class - (let ([autoinitargs (getarg initargs :autoinitargs)]) - (map (lambda (s) - (if (pair? s) - (if (or (not autoinitargs) - (getarg (cdr s) :initarg) - (not (symbol? (car s)))) - s - (list* (car s) :initarg (string->symbol - (string-append - ":" (symbol->string (car s)))) - (cdr s))) - (list s))) - (getarg initargs :direct-slots '())))) - (%set-class-cpl! class (compute-cpl class)) - (%set-class-slots! class (compute-slots class)) - (%set-class-name! class (or (getarg initargs :name) '-anonymous-)) - (let* ([nfields 0] - [field-initializers '()] - ;; allocator: give me an initializer function, get a slot number - [allocator (lambda (init) - (let ([f nfields]) - (set! nfields (+ nfields 1)) - (set! field-initializers - (cons init field-initializers)) - f))] - [getters-n-setters (map (lambda (slot) - (cons (car slot) - (compute-getter-and-setter - class slot allocator))) - (%class-slots class))]) - (%set-class-nfields! class nfields) - (%set-class-field-initializers! class (reverse field-initializers)) - (%set-class-getters-n-setters! class getters-n-setters)) - (%set-class-initializers! - class (reverse - (mappend - (lambda (c) - (if (instance-of? c ) (%class-initializers c) '())) - (cdr (%class-cpl class))))) - (%set-class-valid-initargs! ; for sanity checks - class (getarg initargs :valid-initargs - (thunk (mappend (lambda (slot) - (getargs (cdr slot) :initarg)) - (%class-slots class)))))))) - -(add-method initialize - (make-method (list ) - (named-lambda method:initialize (call-next-method generic initargs) - (call-next-method) - (%set-generic-methods! generic '()) - (%set-generic-arity! generic (getarg initargs :arity #f)) - (%set-generic-name! generic (or (getarg initargs :name) '-anonymous-)) - (%set-generic-combination! generic (getarg initargs :combination)) - (set-instance-proc! generic - (lambda args - (raise* make-exn:fail:contract - "~s: no methods added yet" - (%generic-name generic))))))) - -(add-method initialize - (make-method (list ) - (named-lambda method:initialize (call-next-method method initargs) - (call-next-method) - (%set-method-specializers! method - (map (lambda (c) (%struct->class c)) - (getarg initargs :specializers))) - (%set-method-procedure! method (getarg initargs :procedure)) - (%set-method-qualifier! method (or (getarg initargs :qualifier) - :primary)) - (%set-method-name! method (or (getarg initargs :name) - '-anonymous-)) - (set-instance-proc! method (compute-apply-method method))))) - -(add-method allocate-instance - (make-method (list ) - (named-lambda method:allocate-instance (call-next-method class initargs) - (%allocate-instance class (length (%class-field-initializers class)))))) - -(add-method allocate-instance - (make-method (list ) - (named-lambda method:allocate-instance (call-next-method class initargs) - (%allocate-entity class (length (%class-field-initializers class)))))) - -(add-method compute-cpl - (make-method (list ) - (named-lambda method:compute-cpl (call-next-method class) - (compute-std-cpl class %class-direct-supers)))) - -(add-method compute-slots - (make-method (list ) - (named-lambda method:compute-slots (call-next-method class) - (let ([all-slots (map %class-direct-slots (%class-cpl class))] - [final-slots #f]) - (let collect ([to-process (apply append all-slots)] - [result '()]) - (if (null? to-process) - (set! final-slots result) - (let* ([name (caar to-process)] - [others '()] - [remaining-to-process - (filter (lambda (o) - (if (eq? (car o) name) - (begin (set! others (cons (cdr o) others)) #f) - #t)) - to-process)]) - (collect remaining-to-process - (cons (cons name (apply append (reverse others))) - result))))) - ;; Sort the slots by order of appearance in cpl, makes them stay in the - ;; same index, allowing optimizations for single-inheritance - (let collect ([to-process (apply append (reverse all-slots))] - [result '()]) - (cond [(null? to-process) (reverse result)] - [(assq (caar to-process) result) - (collect (cdr to-process) result)] - [else (collect (cdr to-process) - (cons (assq (caar to-process) final-slots) - result))])))))) - -(add-method compute-getter-and-setter - (make-method (list ) - (letrec ([nothing "nothing"] - [l-getarg - ;; apply getarg on a list of names until get a value - (lambda (args initargs) - ;; give priority to first initargs - (if (null? initargs) - nothing - (let ([x (getarg args (car initargs) nothing)]) - (if (eq? x nothing) (l-getarg args (cdr initargs)) x))))]) - (named-lambda method:compute-getter-and-setter - (call-next-method class slot allocator) - (let ([initargs (getargs (cdr slot) :initarg)] - [initializer (getarg (cdr slot) :initializer)] - [initvalue (getarg (cdr slot) :initvalue ???)] - [type (getarg (cdr slot) :type #f)] - [allocation (getarg (cdr slot) :allocation :instance)] - [lock (getarg (cdr slot) :lock #f)]) - (define init - (if initializer - (if (eq? 0 (procedure-arity initializer)) - (lambda args (initializer)) initializer) - (lambda args initvalue))) - (define (init-slot . args) - (let ([result (l-getarg args initargs)]) - (when (eq? result nothing) - (set! result (apply init args))) - (when (and type (not (eq? result ???)) - (not (instance-of? result type))) - (error 'class - "bad initial value type for slot ~e in ~e (~e not a ~e)" - (car slot) class result type)) - result)) - (when (and type (not (specializer? type))) - (error 'class "bad type specifier for ~e: ~e" (car slot) type)) - (case allocation - [(:instance) - (let* ([f (allocator init-slot)] - [g+s (mcons (lambda (o) (%instance-ref o f)) - (if (and type (not (eq? type))) - (lambda (o n) - (if (instance-of? n type) - (%instance-set! o f n) - (raise* make-exn:fail:contract - "slot-set!: wrong type for slot ~ - `~.s' in ~e (~e not in ~e)" - (car slot) class n type))) - (lambda (o n) (%instance-set! o f n))))]) - (when lock - (make-setter-locked! g+s lock - (lambda () - (raise* make-exn:fail:contract - "slot-set!: slot `~.s' in ~.s is locked" - (car slot) (%class-name class))))) - g+s)] - [(:class) - (unless (null? initargs) - (let ([setter #f]) - (%set-class-initializers! - class - (cons (lambda args - (let ([result (l-getarg args initargs)]) - ;; cache the setter - (unless setter - (set! setter - (mcdr (cdr (assq (car slot) - (%class-getters-n-setters - class)))))) - (unless (eq? result nothing) - (setter #f result)))) - (%class-initializers class))))) - (if (and (assq (car slot) (%class-direct-slots class)) - (getarg (cdr (assq (car slot) - (%class-direct-slots class))) - :allocation #f)) - ;; the slot was declared as :class here - (let* ([cell (init)] ; default value - no arguments - [g+s (mcons (lambda (o) cell) - (lambda (o n) - (if (and type (not (instance-of? n type))) - (raise* - make-exn:fail:contract - "slot-set!: wrong type for shared slot ~ - `~.s' in ~e (~e not in ~e)" - (car slot) class n type) - (set! cell n))))]) - (when lock - (make-setter-locked! (car slot) g+s lock - (lambda () - (raise* make-exn:fail:contract - "slot-set!: slot `~.s' in ~.s is locked" - (car slot) (%class-name class))))) - g+s) - ;; the slot was inherited as :class - fetch its getters/setters - (let loop ([cpl (cdr (%class-cpl class))]) - (cond [(assq (car slot) (%class-getters-n-setters (car cpl))) - => cdr] - [else (loop (cdr cpl))])))] - [else - (error 'class - "allocation for `~.s' must be :class or :instance, got ~e" - (car slot) allocation)])))))) - -;;; Use the previous function when populating this generic. -(add-method compute-apply-method - (make-method (list ) method:compute-apply-method)) - -(add-method no-next-method - (make-method (list ) - (lambda (call-next-method generic method . args) - (raise* make-exn:fail:contract - (concat "~s: no applicable next method to call" - (case (%method-qualifier method) - [(:before) " in a `before' method"] - [(:after) " in an `after' method"] - [else ""]) - " with arguments: ~e") - (%generic-name generic) args)))) -(add-method no-next-method - (make-method (list (singleton #f) ) - (lambda (call-next-method generic method . args) - (raise* make-exn:fail:contract - (concat "~s: no applicable next method in a direct method call" - " with arguments: ~e") - (%method-name method) args)))) - -(add-method no-applicable-method - (make-method (list ) - (lambda (call-next-method generic . args) - (raise* make-exn:fail:contract - "~s: no applicable primary methods for arguments ~e, of types ~e" - (%generic-name generic) args (map class-of args))))) - -;;; --------------------------------------------------------------------------- -;;; Customization variables - -;;>>... Swindle Customization Parameters - -;;>> *default-method-class* -;;>> *default-generic-class* -;;>> *default-class-class* -;;>> *default-entityclass-class* -;;> These parameters specify default classes for the many constructor -;;> macros in `clos'. -(define* *default-method-class* (make-parameter )) -(define* *default-generic-class* (make-parameter )) -(define* *default-class-class* (make-parameter )) -(define* *default-entityclass-class* (make-parameter )) - -;; an automatic superclass for all classes -- turned off for the builtins below -;;>> *default-object-class* -;;> This parameter contains a value which is automatically made a -;;> superclass for all classes. Defaults to `'. -(define* *default-object-class* (make-parameter #f)) - -;;>> *make-safely* -;;> Setting this parameter to #t will make Swindle perform sanity checks -;;> on given initargs for creating an object. This will make things -;;> easier for debugging, but also slower. Defaults to `#f'. Note that -;;> the sanity checks are done in `initialize'. -;; This could be in `make', but `defclass' will call that with no slots to make -;; the object and then call `initialize' with all arguments to actually create -;; the class. -(define* *make-safely* (make-parameter #f)) - -(define (check-initargs class initargs) - ;; sanity check - verify sensible keywords given - (let ([valid-initargs (%class-valid-initargs class)]) - (or (not valid-initargs) - (let loop ([args initargs]) - (cond [(null? args) #t] - [(not (and (pair? args) (pair? (cdr args)))) - (error 'make "error in initargs for ~e; arg list not balanced" - class)] - [(not (symbol? (car args))) - (error 'make "error in initargs for ~e; ~e is not a keyword" - class (car args))] - [(not (memq (car args) valid-initargs)) - (error 'make "error in initargs for ~e; unknown keyword: ~e" - class (car args))] - [else (loop (cddr args))]))))) - -;;; --------------------------------------------------------------------------- -;;; Make `make' a generic function - -;;>>... Creating Instances - -;;; Now everything works, both generic functions and classes, so we can turn on -;;; the real MAKE. -;;; ELI: This is turned into a generic function - do this carefully - first -;;; create the generic function and the method instances, then change make. - -;;>> (make class initargs ...) -;;> Create an instance of `class', which can be any Swindle class (except -;;> for some special top-level classes and built-in classes). -;;> -;;> See the `Object Initialization Protocol' below for a description of -;;> generic functions that are involved in creating a Swindle object. -(let ([m (make-method (list ) - (named-lambda method:make (call-next-method class . initargs) - (let ([instance (allocate-instance class initargs)]) - (when (*make-safely*) (check-initargs class initargs)) - (initialize instance initargs) - instance)))] - [g (make-generic-function 'make)]) - (add-method g m) - (set! make g)) - -;; The clean concept behind this is due to Joe Marshall. - -;;>> (rec-make (name class arg ...) ...) -;;> This is similar to: -;;> -;;> (letrec ([name (make class arg ...)] ...) -;;> (values name ...)) -;;> -;;> except that the names are first bound to allocated instances with no -;;> initargs, and then they are initialized with all these bindings. This -;;> is useful for situations where creating some instances needs other -;;> instances as values. One sample usage is the way `defclass' makes the -;;> class binding available for slot specifications like `:type'. Note -;;> that this is a special form, which invokes `allocate-instance' and -;;> `initialize' directly, so specializing `make' on some input will not -;;> change the way `rec-make' works. -(defsubst* (rec-make (name class arg ...) ...) - (let ([name (allocate-instance class (list arg ...))] ...) - (when (*make-safely*) (check-initargs class (list arg ...)) ...) - (initialize name (list arg ...)) ... - (values name ...))) - -;;; --------------------------------------------------------------------------- -;;; Make `add-method' a generic function - -;;; Use this to compute a name for the method. specs is a list of classes or -;;; class-names (in case of unnamed-methods in clos.rkt). -(define (compute-method-name specs generic-name) - (define (spec-string spec) - (cond [(%singleton? spec) (format "{~.s}" (singleton-value spec))] - [(%class? spec) (symbol->string - (%class-name (%struct->class spec)))] - [else "???"])) - (string->symbol - (apply string-append - (symbol->string generic-name) ":" - (if (null? specs) - '("()") - (cons (spec-string (car specs)) - (map (lambda (c) (string-append "," (spec-string c))) - (cdr specs))))))) - -(let ([old-add-method add-method]) - (set! add-method (make :name 'add-method :arity 2)) - (old-add-method add-method - (make-method (list ) - (named-lambda method:add-method (call-next-method generic method) - (let ([method-arity (method-arity method)] - [generic-arity (%generic-arity generic)]) - (cond - [(not generic-arity) - (%set-generic-arity! generic method-arity)] - ;; note: equal? works on arity-at-least structs - [(not (equal? generic-arity method-arity)) - (error 'add-method - "wrong arity for `~.s', expects ~a; given a method with ~a" - (%generic-name generic) - (if (integer? generic-arity) - generic-arity - (format "at-least-~a" - (arity-at-least-value generic-arity))) - (if (integer? method-arity) - method-arity - (format "at-least-~a" - (arity-at-least-value method-arity))))]) - ;; set a name for the method if none (when attached to a generic) - (let ([n (%method-name method)]) - (unless (and n (not (eq? n '-anonymous-))) - (%set-method-name! - method - (let* ([psym (object-name (%method-procedure method))] - [pstr (and psym (symbol->string psym))]) - (if (or (not pstr) (regexp-match? #rx":[0-9]*:[0-9]*$" pstr)) - (compute-method-name (%method-specializers method) - (%generic-name generic)) - psym))))) - (old-add-method generic method)))))) - -;;; Optimized frequently used accessors: -;;; This is possible because of the ordering of the slots in compute-slots, -;;; works only for single-inheritance. Note that there is no type checking - -;;; it is unsafe, but makes things around 5-6 times faster! -(set! %class-direct-slots (%slot-getter 'direct-slots)) -(set! %class-direct-supers (%slot-getter 'direct-supers)) -(set! %class-slots (%slot-getter 'slots)) -(set! %class-nfields (%slot-getter 'nfields)) -(set! %class-field-initializers (%slot-getter 'field-initializers)) -(set! %class-getters-n-setters (%slot-getter 'getters-n-setters)) -(set! %class-cpl (%slot-getter 'cpl)) -(set! %class-name (%slot-getter 'name)) -(set! %class-initializers (%slot-getter 'initializers)) -(set! %class-valid-initargs (%slot-getter 'valid-initargs)) -(set! %generic-methods (%slot-getter 'methods)) -(set! %generic-arity (%slot-getter 'arity)) -(set! %generic-name (%slot-getter 'name)) -(set! %generic-combination (%slot-getter 'combination)) -(set! %method-specializers (%slot-getter 'specializers)) -(set! %method-procedure (%slot-getter 'procedure)) -(set! %method-qualifier (%slot-getter 'qualifier)) -(set! %method-name (%slot-getter 'name)) -(set! %set-class-direct-slots! (%slot-setter 'direct-slots)) -(set! %set-class-direct-supers! (%slot-setter 'direct-supers)) -(set! %set-class-slots! (%slot-setter 'slots)) -(set! %set-class-nfields! (%slot-setter 'nfields)) -(set! %set-class-field-initializers!(%slot-setter 'field-initializers)) -(set! %set-class-getters-n-setters! (%slot-setter 'getters-n-setters)) -(set! %set-class-cpl! (%slot-setter 'cpl)) -(set! %set-class-name! (%slot-setter 'name)) -(set! %set-class-initializers! (%slot-setter 'initializers)) -(set! %set-class-valid-initargs! (%slot-setter 'valid-initargs)) -(set! %set-generic-methods! (%slot-setter 'methods)) -(set! %set-generic-arity! (%slot-setter 'arity)) -(set! %set-generic-name! (%slot-setter 'name)) -(set! %set-generic-combination! (%slot-setter 'combination)) -(set! %set-method-specializers! (%slot-setter 'specializers)) -(set! %set-method-procedure! (%slot-setter 'procedure)) -(set! %set-method-qualifier! (%slot-setter 'qualifier)) -(set! %set-method-name! (%slot-setter 'name)) -;; Optimize these internal ones as well. -(set! %generic-app-cache (%slot-getter 'app-cache)) -(set! %generic-singletons-list (%slot-getter 'singletons-list)) -(set! %set-generic-app-cache! (%slot-setter 'app-cache)) -(set! %set-generic-singletons-list! (%slot-setter 'singletons-list)) - -;;; --------------------------------------------------------------------------- -;;; Built-in classes. - -;;>>... Built-in Classes - -;;>> -;;> The class of all built-on classes. -(define* - (make :direct-supers (list ) - :direct-slots '() - :name ' - ;; needed so structs can turn to classes even if *make-safely* - :valid-initargs #f)) -;; Normally, can't allocate these. -(add-method allocate-instance - (make-method (list ) - (named-lambda method:allocate-instance (call-next-method class initargs) - (error 'allocate-instance "can't instantiate a primitive class ~e" - class)))) - -;;>> -;;> The superclass of all built-in classes. -(define* - (make :direct-supers (list ) - :direct-slots '() - :name ')) -(defsubst (defprimclass primclass) (defprimclass primclass ) - (_ primclass supers ...) (define* primclass - (make - :name 'primclass - :direct-supers (list supers ...) - :direct-slots '()))) -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;>> -;;> These classes represent built-in objects. See the class hierarchy -;;> below for a complete description of the relations between these -;;> classes. -;;>> -;;>> -;;> These are also classes for built-in objects, but they are classes for -;;> Racket structs -- which can be used like Swindle classes since they -;;> will get converted to appropriate Swindle subclasses of `'. -;;> `' is a class of structs that are hidden -- see the -;;> documentation for `struct-info' and the `skipped?' result. Note that -;;> structs can be used as long as they can be inspected -- otherwise, we -;;> can't even know that they are structs with `struct?' (this means that -;;> can only appear in the cpl of a struct class that -;;> inherits from a struct which is not under the current inspector). -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(define* ) ; alias -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -;; Have all possible number combinations in any case -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -;; Racket stuff -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -;; make these classes used when we see exn structs -(let ([set-exn-class - (lambda (class make-exn . xs) - (hash-table-put! struct-to-class-table - (let-values ([(e _) - (struct-info - (apply make-exn "foo" - (current-continuation-marks) - xs))]) - e) - class))]) - (set-exn-class make-exn) - (set-exn-class make-exn:fail) - (set-exn-class make-exn:break (let/ec e e))) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -(defprimclass ) -;;>> -;;> The class of all Scheme procedures. -(define* - (make :name ' - :direct-supers (list ) - :direct-slots '())) -;;>> -;;> The class of all primitive Racket procedures. -(define* - (make - :name ' - :direct-supers (list ) - :direct-slots '())) - -(*default-object-class* ) ; turn auto-superclass back on - -(set! class-of - (lambda (x) - ;; If all Schemes were IEEE compliant, the order of these wouldn't - ;; matter? - ;; ELI: changed the order so it fits better the expected results. - (cond [(instance? x) (instance-class x)] - [(struct? x) - (let-values ([(type _) (struct-info x)]) - (if type (struct-type->class type) ))] - [(procedure? x) (cond [(parameter? x) ] - [(primitive? x) ] - [else ])] - [(string? x) (if (immutable? x) )] - [(pair? x) (if (list? x) )] - [(null? x) ] - [(symbol? x) (if (keyword? x) )] - [(number? x) - (if (exact? x) - (cond [(integer? x) ] - [(rational? x) ] - [(real? x) ] - [(complex? x) ] - [else ]) ; should not happen - (cond [(integer? x) ] - [(rational? x) ] - [(real? x) ] - [(complex? x) ] - [else ]))] ; should not happen - [(boolean? x) ] - [(char? x) ] - [(bytes? x) (if (immutable? x) )] - [(path? x) ] - [(vector? x) ] - [(mpair? x) ] - [(eof-object? x) ] - [(input-port? x) - (if (file-stream-port? x) )] - [(output-port? x) - (if (file-stream-port? x) )] - [(void? x) ] - [(box? x) ] - [(weak-box? x) ] - [(regexp? x) ] - [(byte-regexp? x) ] - [(promise? x) ] - [(real-keyword? x) ] - [(semaphore? x) ] - [(hash-table? x) ] - [(thread? x) ] - [(subprocess? x) ] - [(syntax? x) - (if (identifier? x) )] - [(namespace? x) ] - [(custodian? x) ] - [(tcp-listener? x) ] - [(security-guard? x) ] - [(will-executor? x) ] - [(struct-type? x) ] - [(inspector? x) ] - [(pseudo-random-generator? x) ] - [(compiled-expression? x) ] - [else ]))) - -;;; --------------------------------------------------------------------------- -;;; Some useful predicates. - -;;>> (builtin? x) -;;>> (function? x) -;;>> (generic? x) -;;>> (method? x) -;;> Predicates for instances of , , , and -;;> . -(define* (builtin? x) (instance-of? x )) -(define* (function? x) (instance-of? x )) -(define* (generic? x) (instance-of? x )) -(define* (method? x) (instance-of? x )) - -;;; --------------------------------------------------------------------------- -;;>>... Class Hierarchy -;;> -;;> In the following, every class's class is specified after a colon. Also, -;;> some classes appear in more than once place due to multiple-inheritance. -;;> -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : ; alias for -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : ; alias for -;;> : -;;> : -;;> : -;;> -;;> -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> : -;;> ... struct type classes ... - -;;>>... Object Initialization Protocol -;;> This is the initialization protocol. All of these are generic -;;> functions (unlike the original Tiny CLOS). See the individual -;;> descriptions above for more details. -;;> -;;> make -;;> allocate-instance -;;> initialize -;;> class initialization only: -;;> compute-cpl -;;> compute-slots -;;> compute-getter-and-setter -;;> method initialization only: -;;> compute-apply-method -;;> add-method -;;> compute-apply-generic -;;> compute-methods -;;> compute-method-more-specific? -;;> compute-apply-methods diff --git a/pkgs/swindle/tool.rkt b/pkgs/swindle/tool.rkt deleted file mode 100644 index 6664cf9850..0000000000 --- a/pkgs/swindle/tool.rkt +++ /dev/null @@ -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 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)]) - )