├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── info.rkt ├── sicp-doc ├── contributors.scrbl ├── external-links.scrbl ├── info.rkt ├── installation.scrbl ├── sicp-manual.scrbl ├── sicp-pict.scrbl └── sicp.scrbl ├── sicp-pict ├── einstein2.jpg ├── main.rkt └── test │ └── tests.rkt └── sicp ├── lang └── reader.rkt ├── main.rkt └── test └── amb.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | doc -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | env: 4 | global: 5 | - RACKET_DIR=~/racket 6 | matrix: 7 | - RACKET_VERSION=6.3 8 | - RACKET_VERSION=6.6 9 | - RACKET_VERSION=6.9 10 | - RACKET_VERSION=6.12 11 | - RACKET_VERSION=7.0 12 | - RACKET_VERSION=7.1 13 | - RACKET_VERSION=7.2 14 | - RACKET_VERSION=HEAD 15 | - RACKET_VERSION=HEADCS 16 | 17 | matrix: 18 | allow_failures: 19 | - env: RACKET_VERSION=HEAD 20 | - env: RACKET_VERSION=HEADCS 21 | fast_finish: true 22 | 23 | 24 | before_install: 25 | - git clone https://github.com/greghendershott/travis-racket.git 26 | - cat travis-racket/install-racket.sh | bash 27 | - export PATH="${RACKET_DIR}/bin:${PATH}" 28 | 29 | install: 30 | - raco pkg install --auto 31 | 32 | script: 33 | - raco setup --check-pkg-deps --pkgs sicp 34 | - raco test -p sicp 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | sicp 2 | ==== 3 | 4 | [![Build Status](https://travis-ci.com/sicp-lang/sicp.png?branch=master)](https://travis-ci.com/sicp-lang/sicp) 5 | 6 | A SICP language for Racket. 7 | 8 | Ideal for studying the book "Structure and Interpretation of Computer Programs" 9 | by Gerald Jay Sussman and Hal Abelson. 10 | 11 | [Documentation](https://docs.racket-lang.org/sicp-manual/) 12 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | (define version "1.0") 5 | (define test-omit-paths '(#px"^((?!/test/).)*$")) 6 | (define deps '("base" 7 | "draw-lib" 8 | "r5rs-lib" 9 | "rackunit-lib" 10 | "snip-lib")) 11 | (define build-deps '("draw-doc" 12 | "gui-doc" 13 | "r5rs-doc" 14 | "racket-doc" 15 | "scribble-lib")) 16 | -------------------------------------------------------------------------------- /sicp-doc/contributors.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual 4 | (for-label (only-in sicp random))) 5 | 6 | @title{Contributors} 7 | 8 | The following individuals contributed to the implementation and documentation of SICP language: 9 | 10 | @itemlist[ 11 | @item{Abelson & Sussman wrote @link["https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/full-text/book/book-Z-H-15.html#%_sec_2.2.4"]{Structure and Interpretation of Computer Programs}.} 12 | @item{Daniel Coore designed and implemented the 13 | @link["https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/psets/ps4hnd/readme.html"]{original image display code} in MIT Scheme.} 14 | @item{Mike Sperber ported the code to PLT Scheme / Racket.} 15 | @item{Neil Van Dyke maintained the original SICP language package for years.} 16 | @item{Dorai Sitaram implemented the initial version of amb in his 17 | @link["http://ds26gte.github.io/tyscheme/index-Z-H-16.html#node_sec_14.2"]{Teach Yourself Scheme in Fixnum Days}.} 18 | @item{Javier Olaechea fixed bugs in amb.} 19 | @item{Leif Andersen fixed several packaging configuration mistakes.} 20 | @item{Ed Moore fixed a missing function.} 21 | @item{Chuan Wei Foo improved the README file.} 22 | @item{Graeme McCutcheon fixed a typo.} 23 | @item{Huma Zafar updated the documentation to match the new picture language implementation.} 24 | @item{Pavan Maddamsetti implemented the missing @racket[random] function.} 25 | @item{Jiezhe Wang fixed the top-level printing so that mutable pairs are displayed similar to r5rs.} 26 | @item{Noah Ma implemented typed/sicp-pict.} 27 | @item{Sorawee Porncharoenwase is a current maintainer of the package.} 28 | @item{Jens Axel Søgaard is a current maintainer of the package, 29 | implementing the picture language and maintaining the package for years.} 30 | ] 31 | -------------------------------------------------------------------------------- /sicp-doc/external-links.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual) 4 | 5 | @title{External Links} 6 | 7 | @itemlist[ 8 | @item{@link["https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/psets/ps4hnd/readme.html"]{readme.html} 9 | from the SICP website has a more detailed documentation and exercises.} 10 | @item{Peter Henderson's @link["https://eprints.soton.ac.uk/257577/1/funcgeo2.pdf"]{Functional Geometry}.} 11 | ] 12 | -------------------------------------------------------------------------------- /sicp-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings '(("sicp-manual.scrbl" (multi-page) (language)))) 4 | -------------------------------------------------------------------------------- /sicp-doc/installation.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual 4 | (for-label (only-in sicp inc))) 5 | 6 | @title{Installation} 7 | 8 | Use DrRacket to install the sicp package like this: 9 | 10 | @itemlist[#:style 'ordered 11 | @item{Open the Package Manager: 12 | in DrRacket choose the menu "File" then choose "Package Manager...".} 13 | @item{In the tab "Do What I Mean" find the text field and enter: @tt{sicp}} 14 | @item{Finally click the "Install" button.} 15 | @item{Test it. Make sure DrRacket has "Determine language from source" in the bottom left corner. 16 | Write the following program and click run: 17 | 18 | @codeblock{ 19 | #lang sicp 20 | (inc 42) 21 | } 22 | 23 | The expected output is @racket[43].} 24 | ] -------------------------------------------------------------------------------- /sicp-doc/sicp-manual.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval 4 | (for-label (except-in sicp #%app #%datum #%top))) 5 | 6 | @title{SICP Collections} 7 | 8 | This package contains two collections. 9 | 10 | The @racket[sicp] collection contains a @tt{#lang sicp} language ideal 11 | for studying the book "Structure and Interpretation of Computer Programs" 12 | by Gerald Jay Sussman and Hal Abelson. The book is usually referred 13 | to simply as SICP. 14 | 15 | The second @racket[sicp-pict] collection contains the picture language used in SICP. 16 | 17 | @include-section["installation.scrbl"] 18 | @include-section["sicp.scrbl"] 19 | @include-section["sicp-pict.scrbl"] 20 | @include-section["contributors.scrbl"] 21 | @include-section["external-links.scrbl"] 22 | 23 | @index-section{} 24 | 25 | -------------------------------------------------------------------------------- /sicp-doc/sicp-pict.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual scribble/eval 4 | (for-label sicp-pict 5 | racket/base 6 | (only-in racket/contract 7 | -> any/c and/c or/c 8 | listof contract? 9 | <=/c natural-number/c) 10 | (only-in racket/class is-a?/c) 11 | (only-in racket/draw bitmap% color%) 12 | (only-in racket/snip image-snip%))) 13 | 14 | @(define the-eval (make-base-eval)) 15 | @(the-eval '(require sicp-pict)) 16 | 17 | @title{SICP Picture Language} 18 | @defmodule[sicp-pict] 19 | 20 | @index["painter"] 21 | @index["geometry"] 22 | @index["picture"] 23 | @index["Escher"] 24 | 25 | @section[#:tag "sicp-pict-intro"]{Introduction} 26 | 27 | The SICP Picture Language is a small language for drawing pictures. 28 | It shows the power of data abstraction and closure. The picture language 29 | stems from Peter Henderson's 1982 paper "Functional Geometry" and was 30 | included by Hal Abelson in "Structure and Interpretation of Computer 31 | Programs". 32 | 33 | The basic concept of the picture language is a @emph{painter}, which draws 34 | its image (shifted and scaled) within a frame given by a parallelogram. 35 | Painters can be combined to construct new painters. 36 | 37 | Before using this package, read 38 | @link["https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/full-text/book/book-Z-H-15.html#%_sec_2.2.4"]{section 2.2.4 of SICP}, 39 | which is an excellent introduction to the ideas of the picture language. 40 | This manual is meant as a reference guide. 41 | 42 | Peter Henderson has written an updated version of 43 | @link["http://eprints.ecs.soton.ac.uk/7577/01/funcgeo2.pdf"]{Functional Geometry}, 44 | which explains how to construct the Escher fish image. 45 | 46 | @section{Example} 47 | 48 | Using @racket[sicp-pict] from a @tt{#lang sicp} program: 49 | 50 | @codeblock{ 51 | #lang sicp 52 | (#%require sicp-pict) 53 | (paint einstein) 54 | } 55 | 56 | Using @racket[sicp-pict] from a @tt{#lang racket} program: 57 | 58 | @codeblock{ 59 | #lang racket 60 | (require sicp-pict) 61 | (paint einstein) 62 | } 63 | 64 | From the REPL: 65 | 66 | @schemeblock[ 67 | > (require sicp-pict) 68 | > (paint (number->painter 0)) 69 | > (paint diagonal-shading) 70 | > (paint (below (beside diagonal-shading 71 | (rotate90 diagonal-shading)) 72 | (beside (rotate270 diagonal-shading) 73 | (rotate180 diagonal-shading)))) 74 | > (paint einstein) 75 | ] 76 | 77 | @section{Vectors} 78 | 79 | A mathematical vector is called a @emph{vect} here, in order 80 | to avoid confusion with the builtin vectors of Scheme. 81 | 82 | @defproc[(vect? [v any/c]) boolean?]{ 83 | Returns @racket[#t] if @racket[v] is a vect, @racket[#f] otherwise. 84 | } 85 | 86 | @defproc[(make-vect [x real?] [y real?]) vect?]{ 87 | Constructs a vect with the given coordinates. 88 | } 89 | 90 | @defproc[(vector-xcor [v vect?]) real?]{ 91 | Returns the x-coordinate. 92 | } 93 | 94 | @defproc[(vector-ycor [v vect?]) real?]{ 95 | Returns the y-coordinate. 96 | } 97 | 98 | @defproc[(vector-add [v vect?] [w vect?]) vect?]{ 99 | Adds the two vects by adding their coordinates pairwise. 100 | } 101 | 102 | @defproc[(vector-sub [v vect?] [w vect?]) vect?]{ 103 | Subtracts the two vects by subtracting their coordinates pairwise. 104 | } 105 | 106 | @defproc[(vector-scale [s real?] [v vect?]) vect?]{ 107 | Scales the vect by multiplying each coordinate of @racket[v] with 108 | the number @racket[s]. 109 | } 110 | 111 | @defthing[zero-vector vect?]{ 112 | An alias for @racket[(make-vect 0. 0.)] 113 | } 114 | 115 | @section{Frames} 116 | 117 | A @emph{frame} is descibed by three vectors. 118 | @verbatim{ 119 | ^ 120 | | frame edge2 vector 121 | | 122 | _|__________> 123 | /| frame edge1 vector 124 | / 125 | / 126 | / frame origin pointer 127 | } 128 | 129 | @defproc[(frame? [f any/c]) boolean?]{ 130 | Returns @racket[#t] is @racket[f] is a frame, @racket[#f] otherwise. 131 | } 132 | 133 | @defproc[(make-frame [origin vect?] [edge1 vect?] [edge2 vect?]) frame?]{ 134 | Constructs a frame from a frame origin vector and two frame edge vectors. 135 | } 136 | 137 | @deftogether[(@defproc[(frame-origin [f frame?]) vect?] 138 | @defproc[(frame-edge1 [f frame?]) vect?] 139 | @defproc[(frame-edge2 [f frame?]) vect?])]{ 140 | Extracts the origin, first edge or second edge from a frame. 141 | } 142 | 143 | @defproc[(make-relative-frame [origin vect?] 144 | [corner1 vect?] 145 | [corner2 vect?]) (frame? . -> . frame?)]{ 146 | The function @scheme[make-relative-frame] provides a convenient way to 147 | transform frames. Given a frame and three points: @racket[origin], 148 | @racket[corner1], and @racket[corner2] (expressed in frame coordinates), 149 | it returns a new frame with those corners. 150 | } 151 | 152 | @defproc[(frame-coord-map [f frame?]) (vect? . -> . vect?)]{ 153 | Each frame determines a system of "frame coordinates" (x,y) where 154 | (0,0) is the origin of the frame, x represents the displacement 155 | along the first edge (as a fraction of the length of the edge) and 156 | y is the displacement along the second edge. 157 | 158 | The frame coordinate map is returned by @racket[frame-coord-map]. E.g. 159 | these expression return the same value: 160 | 161 | @itemlist[ 162 | @item{@scheme[((frame-coord-map a-frame) (make-vect 0 0))]} 163 | @item{@scheme[(frame-origin a-frame)]} 164 | ] 165 | } 166 | 167 | @section{Segments} 168 | 169 | A pair of vects determines a @emph{directed line segment} 170 | (or simply a @emph{segment}) which runs from the endpoint of 171 | the first vect to the endpoint of the second vect. 172 | 173 | @defproc[(segment? [s any/c]) boolean?]{ 174 | Returns @racket[#t] if @racket[s] is a segment, @racket[#f] otherwise. 175 | } 176 | 177 | @defproc[(make-segment [from vect?] [to vect?]) segment?]{ 178 | Constructs a segment from @racket[from] to @racket[to]. 179 | } 180 | 181 | @deftogether[(@defproc[(segment-start [s segment?]) vect?] 182 | @defproc[(segment-end [s segment?]) vect?])]{ 183 | Returns the start and the end of a segment @racket[s] respectively. 184 | } 185 | 186 | @defproc[(vects->segments [lov (sequence/c vect?)]) (listof segment?)]{ 187 | Partitions consecutive vect in @racket[lov] into chunks of size 2 and 188 | returns a list of segments where each segment is constructed by each chunk. 189 | If @racket[lov]'s length is odd, the last element will be discarded. 190 | 191 | @examples[#:eval the-eval 192 | (vects->segments (list (make-vect 1 2) (make-vect 3 4) (make-vect 5 6) (make-vect 7 8)))] 193 | } 194 | 195 | @section{Primitive Painters} 196 | 197 | Painters take a frame and draw an image, transformed to fit inside the frame. 198 | 199 | Note that our implementation doesn't have a concept of @emph{picture}s, so 200 | @racket[picture->painter] which is commonly found in other implementations 201 | doesn't exist in our implementation. If you wish to load an image file, 202 | use @racket[bitmap->painter]. 203 | 204 | @defthing[painter/c contract?]{ 205 | A contract that recognizes a painter. This is the same as @racket[(-> frame? any/c)]. 206 | } 207 | 208 | @defproc[(number->painter [color (and/c natural-number/c (<=/c 255))]) painter/c]{ 209 | Constructs a painter that fills the frame with a gray color indicated 210 | by the number. 0 is black and 255 is white. 211 | } 212 | 213 | @defproc[(color->painter [color (is-a?/c color%)]) painter/c]{ 214 | Constructs a painter that fills the frame with the given color. 215 | } 216 | 217 | @defproc[(segments->painter [los (sequence/c segment?)]) painter/c]{ 218 | Constructs a painter that draws a stick figure given by the 219 | segments (w.r.t. the unit square).} 220 | 221 | @defproc[(vects->painter [los (sequence/c vect?)]) painter/c]{ 222 | Constructs a painter that draws a stick figure given by the 223 | vects (w.r.t. the unit square).} 224 | 225 | @defproc[(procedure->painter [f procedure?]) painter/c]{ 226 | 227 | Creates painters from procedures. We assume that the procedure 228 | @racket[f] is defined on the unit square. 229 | 230 | Then to plot a point p in the target frame, we find the inverse image 231 | T^-1(p) of p under the transformation that maps the unit square to the 232 | target, and find the value of @racket[f] at T-1(p). 233 | } 234 | 235 | @;{ 236 | @defproc[(picture->painter [p picture?]) painter/c]{ 237 | The picture @racket[p] is defined on some frame. 238 | 239 | Given a point @racket[p] in the target frame, we compute T^-1(p) where T 240 | is the transformation that takes the picture frame to the 241 | target frame, and find the picture value at the closest 242 | integer point. 243 | } 244 | } 245 | 246 | @deftogether[(@defproc[(bitmap->painter [bm (or/c path-string? (is-a?/c bitmap%))]) 247 | painter/c] 248 | @defproc[(load-painter [bm (or/c path-string? (is-a?/c bitmap%))]) 249 | painter/c])]{ 250 | Uses an image given by @racket[bm] (either a path to the image or a bitmap object) 251 | to create a painter.} 252 | 253 | @section{Higher Order Painters} 254 | 255 | @defproc[(transform-painter [origin vect?] 256 | [corner1 vect?] 257 | [corner2 vect?]) (painter/c . -> . painter/c)]{ 258 | Returns a function that takes a painter as argument and returns 259 | a painter that is just like the original painter but is on 260 | the transformed frame characterized by @racket[origin], @racket[corner1], 261 | and @racket[corner2]. 262 | } 263 | 264 | @defproc[(flip-horiz [p painter/c]) painter/c]{ 265 | Returns a painter that flips the image horizontally.} 266 | 267 | @defproc[(flip-vert [p painter/c]) painter/c]{ 268 | Returns a painter that flips the image vertically.} 269 | 270 | @deftogether[(@defproc[(rotate90 [p painter/c]) painter/c] 271 | @defproc[(rotate180 [p painter/c]) painter/c] 272 | @defproc[(rotate270 [p painter/c]) painter/c])]{ 273 | Returns a painter that rotates the image.} 274 | 275 | @defproc[(beside [p1 painter/c] [p2 painter/c]) painter/c]{ 276 | Constructs a painter that paints the images side-by-side.} 277 | 278 | @defproc[(below [p1 painter/c] [p2 painter/c]) painter/c]{ 279 | Constructs a painter that paints the first image 280 | below the second.} 281 | 282 | @defproc[(above3 [p1 painter/c] [p2 painter/c] [p3 painter/c]) painter/c]{ 283 | Constructs a painter that paints the images one above the other.} 284 | 285 | @defproc[(superpose [p1 painter/c] [p2 painter/c]) painter/c]{ 286 | Constructs a painter that paints the two images 287 | on top of each other.} 288 | 289 | @section{Simple Built-In Painters} 290 | 291 | The following painter values are built-in: 292 | 293 | @deftogether[(@defthing[black painter/c] 294 | @defthing[white painter/c] 295 | @defthing[gray painter/c])]{ 296 | Fills the frame with black (0), white (255) or gray (150). 297 | } 298 | 299 | @defthing[diagonal-shading painter/c]{ 300 | Fills the frame with a shades of gray. The color transition 301 | goes from black in the upper left corner is black, to gray 302 | in the bottom right corner. 303 | } 304 | 305 | @defthing[mark-of-zorro painter/c]{ 306 | Draws the Mark of Zorro. 307 | } 308 | 309 | @defthing[einstein painter/c]{ 310 | Draws an image of Einstein. 311 | } 312 | 313 | @defproc[(escher) painter/c]{ 314 | Draws Escher's @link["https://www.wikiart.org/en/m-c-escher/square-limit"]{Square Limit}. 315 | } 316 | 317 | @section{Painting} 318 | 319 | Painting turns a painter into an @emph{image snip} which can be displayed in DrRacket automatically. 320 | 321 | @defproc[(paint [p painter/c] 322 | [#:width width (and/c positive? integer?) 200] 323 | [#:height height (and/c positive? integer?) 200]) 324 | (is-a?/c image-snip%)]{ 325 | Returns an image snip that contains the painter's image with 326 | the specified @racket[width] and @racket[height]. 327 | } 328 | 329 | @deftogether[(@defproc[(paint-hi-res [p painter/c] 330 | [#:width width (and/c positive? integer?) 200] 331 | [#:height height (and/c positive? integer?) 200]) 332 | (is-a?/c image-snip%)] 333 | @defproc[(paint-hires [p painter/c] 334 | [#:width width (and/c positive? integer?) 200] 335 | [#:height height (and/c positive? integer?) 200]) 336 | (is-a?/c image-snip%)])]{ 337 | Aliases of @racket[paint]. They are provided for compatibility with old texts. 338 | } 339 | -------------------------------------------------------------------------------- /sicp-doc/sicp.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual scribble/eval 4 | (for-label (except-in sicp #%app #%datum #%top true false identity error) 5 | (only-in racket require true false identity error 6 | natural-number/c any/c))) 7 | 8 | @title{SICP Language} 9 | @defmodule[sicp #:lang] 10 | 11 | @index["SICP"] 12 | @index["sicp"] 13 | 14 | @section[#:tag "sicp-intro"]{Introduction} 15 | 16 | The programs in the book are written in (a subset of) the programming language Scheme. 17 | As the years have passed the programming language Scheme has evolved. 18 | The language @tt{#lang sicp} provides you with a version of R5RS (the fifth revision of Scheme) 19 | changed slightly in order for programs in SICP to run as is. 20 | 21 | To use the @tt{sicp} language simply use @tt{#lang sicp} as the 22 | first line of your program. If you need to use Racket libraries, 23 | then use @racket[#%require]. 24 | @margin-note*{ 25 | R5RS has no @racket[require] to avoid breaking programs that use the name @racket[require]. 26 | @racket[#%require] is therefore used instead. 27 | } 28 | 29 | @section{Built-In} 30 | 31 | @defthing[nil null?]{ 32 | An alias for @racket['()]. 33 | } 34 | 35 | @defproc[(inc [x number?]) number?]{ 36 | Returns @racket[(+ x 1)]. 37 | } 38 | 39 | @defproc[(dec [x number?]) number?]{ 40 | Returns @racket[(- x 1)]. 41 | } 42 | 43 | @defthing[the-empty-stream stream?]{ 44 | The null/empty stream. 45 | } 46 | 47 | @defform[(cons-stream first-expr rest-expr)]{ 48 | Produces a stream 49 | } 50 | 51 | @defproc[(stream-null? [s stream?]) boolean?]{ 52 | Returns @racket[#t] if @racket[s] is @racket[the-empty-stream], 53 | @racket[#f] otherwise. 54 | } 55 | 56 | @defproc[(runtime) natural-number/c]{ 57 | Returns the current time measured as the number of microseconds passed since a fixed beginning. 58 | } 59 | 60 | @defproc[(random [n positive?]) real?]{ 61 | Returns an random integer between 0 and n-1 (inclusive) if @racket[n] is 62 | an exact integer, otherwise returns a random inexact number between 0 and n 63 | (exclusive). 64 | } 65 | 66 | @defform[(amb expr ...)]{ 67 | The amb operator. 68 | } 69 | 70 | Additionally, @racket[true], @racket[false], @racket[identity], and @racket[error] are provided from Racket. 71 | -------------------------------------------------------------------------------- /sicp-pict/einstein2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sicp-lang/sicp/5ba7b852855cf107892244b37d6a1ffbef14d595/sicp-pict/einstein2.jpg -------------------------------------------------------------------------------- /sicp-pict/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;; 3 | ;;; SICP Picture Language 4 | ;;; 5 | 6 | ; This is a new implementation of the SICP Picture Language. 7 | ; The picture language is inspired by Henderson's work. 8 | 9 | (require (for-syntax syntax/parse) 10 | racket/draw 11 | racket/snip 12 | racket/runtime-path) 13 | 14 | (define-runtime-path einstein-file "einstein2.jpg") 15 | 16 | ;;; 17 | ;;; Vectors 18 | ;;; 19 | 20 | ;; Points and vectors are represented as vect a structure 21 | ;; that holds the x- and the y-coordinate. 22 | 23 | (provide (contract-out 24 | [struct vect ([x real?] [y real?])] ; structure 25 | [vector-xcor (-> vect? real?)] ; access x-coordinate 26 | [vector-ycor (-> vect? real?)] ; access y-coordinate 27 | [vector-add (-> vect? vect? vect?)] ; add two vectors 28 | [vector-sub (-> vect? vect? vect?)] ; subtract two vectors 29 | [vector-scale (-> real? vect? vect?)] ; scale a vector 30 | [zero-vector vect?])) 31 | 32 | (struct vect (x y) 33 | #:extra-constructor-name make-vect 34 | #:transparent) 35 | 36 | (define vector-xcor vect-x) 37 | (define vector-ycor vect-y) 38 | 39 | (define (vector-add v w) 40 | (match* (v w) [((vect vx vy) (vect wx wy)) (vect (+ vx wx) (+ vy wy))])) 41 | 42 | (define (vector-sub v w) 43 | (match* (v w) [((vect vx vy) (vect wx wy)) (vect (- vx wx) (- vy wy))])) 44 | 45 | (define (vector-scale s v) 46 | (match v [(vect vx vy) (vect (* s vx) (* s vy))])) 47 | 48 | (define zero-vector (vect 0. 0.)) 49 | 50 | ;;; 51 | ;;; Frames 52 | ;;; 53 | 54 | (provide (contract-out 55 | [struct frame ([origin vect?] [edge1 vect?] [edge2 vect?])] ; structure 56 | [frame-coord-map (-> frame? (-> vect? vect?))] 57 | [make-relative-frame (-> vect? vect? vect? (-> frame? frame?))])) 58 | 59 | (struct frame (origin edge1 edge2) 60 | #:extra-constructor-name make-frame 61 | #:transparent) 62 | 63 | ; frame-coord-map : frame -> (vect -> vect) 64 | ; Given a frame whose coordinates are given in a coordinate system S, 65 | ; return a procedure that maps coordinates in the frame coordinates to coordinates in S 66 | (define (frame-coord-map a-frame) 67 | (lambda (point-in-frame-coords) 68 | (match* (a-frame point-in-frame-coords) 69 | [((frame origin edge1 edge2) (vect x y)) 70 | (vector-add origin 71 | (vector-add (vector-scale x edge1) 72 | (vector-scale y edge2)))] 73 | [(_ _) (raise-type-error 'frame-coord-map "got" (list a-frame point-in-frame-coords))]))) 74 | 75 | ; make-relative-frame : vect vect vect -> (frame -> frame) 76 | (define (make-relative-frame origin corner1 corner2) 77 | (λ (frame) 78 | (define m (frame-coord-map frame)) 79 | (define new-origin (m origin)) 80 | (make-frame new-origin 81 | (vector-sub (m corner1) new-origin) 82 | (vector-sub (m corner2) new-origin)))) 83 | 84 | ;;; 85 | ;;; Transformations 86 | ;;; 87 | 88 | ;; Affine transformations are represented by 89 | ;; (struct trans (xx xy yx yy x0 y0) ...)) 90 | ;; The point (x,y) is transformed to: 91 | ;; xnew = xx*x + xy*y + x0 92 | ;; ynew = yx*x + yy*y + y0 93 | ;; Think of an affine transformation as a linear transformation followed by a translation. 94 | 95 | ;; Note: The initial matrix has the same order: xx xy yx yy x0 y0 96 | ;; So we could just keep the vector returned from the drawing context by get-initial-matrix 97 | 98 | (provide (contract-out 99 | [struct trans ([xx real?] [xy real?] [yx real?] [yy real?] [x0 real?] [y0 real?])] 100 | [compose-transformation (-> trans? trans? trans?)] 101 | [vector->transformation (-> vector? trans?)] 102 | [transformation->vector (-> trans? vector?)] 103 | [frame->transformation (-> frame? trans?)])) 104 | 105 | (struct trans (xx xy yx yy x0 y0) 106 | #:transparent) 107 | 108 | (define (compose-transformation t1 t2) 109 | ; ((compose-trans t1 t2) v) = (t1 (t2 v)) 110 | ; Use t2 to transform (x0,y0) into (x1,y1) 111 | ; x1 = g x0 + h y0 + k 112 | ; y1 = i x0 + j y0 + l 113 | ; Use t1 to transform (x1,y1) into (x2,y2) 114 | ; x2 = a x1 + b y1 + e 115 | ; y2 = c x1 + d y1 + f 116 | ; The composed transformation is (computed by a CAS): 117 | ; x2 = (a g + b i) x0 + (a h + b j) y0 + ak + bl + e 118 | ; y2 = (c g + d i) x0 + (c h + d j) y0 + ck + dl + f 119 | (match-define (trans a b c d e f) t1) 120 | (match-define (trans g h i j k l) t2) 121 | (trans (+ (* a g) (* b i)) (+ (* a h) (* b j)) 122 | (+ (* c g) (* d i)) (+ (* c h) (* d j)) 123 | (+ (* a k) (* b l) e) (+ (* c k) (* d l) f))) 124 | 125 | (define (vector->transformation v) 126 | (match v [(vector a b c d e f) (trans a c b d e f)])) 127 | 128 | (define (transformation->vector t) 129 | (match t [(trans a b c d e f) (vector a c b d e f)])) 130 | 131 | ; frame->transformation : frame -> tranformation 132 | ; return the transformation that converts coordinates in 133 | ; system given by the frame into the coordinate system 134 | ; in which the coordinates of the origin and edges of 135 | ; the frame are given. 136 | 137 | (define (frame->transformation f) 138 | (match f 139 | [(frame (vect ox oy) (vect e1x e1y) (vect e2x e2y)) 140 | (trans e1x e2x e1y e2y ox oy)])) 141 | 142 | 143 | ;;; 144 | ;;; Segments 145 | ;;; 146 | 147 | (provide (contract-out 148 | [struct segment ([start vect?] [end vect?])] 149 | [vects->segments (-> (sequence/c vect?) (listof segment?))])) 150 | 151 | ; A segment represents a line segment from start point to end point. 152 | ; The start and end points are represented as vects. 153 | 154 | (struct segment (start end) 155 | #:extra-constructor-name make-segment 156 | #:transparent) 157 | 158 | ; vects->segments : sequence-of-vect -> list-of-segment 159 | (define (vects->segments vects) 160 | (for/list ([v vects] [w (sequence-tail vects 1)]) 161 | (segment v w))) 162 | 163 | ;;; 164 | ;;; COLORS, PENS, AND, BRUSHES 165 | ;;; 166 | 167 | (provide (contract-out 168 | [color-object? (-> any/c boolean?)] 169 | [pen-object? (-> any/c boolean?)] 170 | [brush-object? (-> any/c boolean?)] 171 | [new-color any/c] 172 | #;[new-color (or/c (-> real? real? real? color-object?) 173 | (-> (or/c number? string? color-object?) color-object?))] 174 | [new-pen (-> any/c pen-object?)] 175 | [new-brush (-> any/c brush-object?)] 176 | [new-stipple-brush (-> any/c brush-object?)] 177 | [black-color color-object?] 178 | [white-color color-object?] 179 | [black-pen pen-object?] 180 | [black-brush brush-object?] 181 | [transparent-brush brush-object?])) 182 | 183 | (define (color-object? o) (and (object? o) (is-a? o color%))) 184 | (define (pen-object? o) (and (object? o) (is-a? o pen%))) 185 | (define (brush-object? o) (and (object? o) (is-a? o brush%))) 186 | 187 | (define new-color 188 | (let () ; make a cache of colors in order to reuse them 189 | (define colors (make-hash)) 190 | (λ ns 191 | (hash-ref! colors ns 192 | (λ () 193 | (match ns 194 | [(list (? number? n)) (let ([n (inexact->exact (floor n))]) 195 | (make-object color% n n n))] 196 | [(list r g b) (let ([r (inexact->exact (floor r))] 197 | [g (inexact->exact (floor g))] 198 | [b (inexact->exact (floor b))]) 199 | (make-object color% r g b))] 200 | [(list (? string? s)) (make-object color% s)] 201 | [(list (? color-object? c)) c] 202 | [_ (error 'new-color)])))))) 203 | 204 | (define new-pen ; draws lines and outlines 205 | (let () 206 | (define pens (make-hash)) ; make a cache of pens in order to reuse them 207 | (λ (color) (hash-ref! pens color 208 | (λ () ; a pen of width 0 means "as thin as possible" 209 | (new pen% 210 | [color color] 211 | [width 0] 212 | [style 'solid] 213 | [cap 'butt] 214 | [stipple #f])))))) 215 | 216 | (define new-brush ; fill in areas 217 | (let () (define brushes (make-hash)) 218 | (λ (color) (hash-ref! brushes color 219 | (λ () 220 | (new brush% 221 | [color color] 222 | [style 'solid])))))) 223 | 224 | (define new-stipple-brush ; fill in area with bitmap 225 | (let () (define brushes (make-hash)) 226 | (λ (bm) (hash-ref! brushes bm 227 | (λ () (new brush% [style 'solid] [stipple bm])))))) 228 | 229 | ;; Useful pens and brushes 230 | (define black-color (new-color "black")) 231 | (define white-color (new-color "white")) 232 | (define black-pen (new-pen "black")) 233 | (define black-brush (new-brush "black")) 234 | (define transparent-brush (new-brush "transparent")) 235 | 236 | ;;; 237 | ;;; Current Drawing Context 238 | ;;; 239 | 240 | ; A painter needs to paint on something. 241 | ; We will use a parameter current-dc to hold the drawing context 242 | ; of "what is currently being drawn to". 243 | ; In practice this will hold the a drawing context for a bitmap. 244 | 245 | (define current-bm (make-parameter #f)) 246 | (define current-dc (make-parameter #f)) 247 | 248 | (define painter/c (-> frame? any/c)) 249 | 250 | ; To get a painting from a painter, we need to create a new 251 | ; bitmap into which the painter can draw. 252 | (define (paint painter #:width [width 200] #:height [height 200]) 253 | (define-values (bm dc) (make-painter-bitmap width height)) 254 | (parameterize ([current-bm bm] 255 | [current-dc dc]) 256 | (send dc scale 0.99 0.99) ; make the entire unit square visible 257 | (painter (frame (vect 0. 0.) (vect 1. 0.) (vect 0. 1.))) 258 | (make-object image-snip% bm))) 259 | 260 | ; For compatibility with old texts. 261 | (define paint-hi-res paint) 262 | (define paint-hires paint) 263 | 264 | ; Painters assume the image as coordinates (0,0) in the 265 | ; lower left corner and (1,1) in the upper right corner. 266 | ; We therefore need to set the initial transformation matrix 267 | ; such that both axis are scaled and the y-axis is flipped. 268 | ; Flipping the y-axis also implies we need to translate 269 | ; the origin in the y-direction 270 | (define (make-painter-bitmap width height) 271 | (define bm (make-bitmap width height)) 272 | (define dc (new bitmap-dc% [bitmap bm])) 273 | (send dc set-pen black-pen) 274 | (send dc set-brush black-brush) 275 | ; (send dc set-smoothing 'smoothed) 276 | (define w (* 1. width)) 277 | (define h (* 1. height)) 278 | ; Map unit square to screen coordinates - also flip y-axis 279 | ; Initial Matrix (Logical to Device coordinates) 280 | ; xx xy yx yy x0 y0 281 | (send dc set-initial-matrix (vector w 0. 0. (* -1. h) 0. h)) 282 | (values bm dc)) 283 | 284 | 285 | ; For debugging: print the paint expression then paint. 286 | ; This makes it easy to see the expression that was used to produce an image. 287 | (define-syntax (echo stx) 288 | (syntax-parse stx 289 | [(_ painter-expr) 290 | #'(begin (displayln 'painter-expr) 291 | (paint painter-expr))])) 292 | 293 | ;;; 294 | ;;; Syntactic Sugar 295 | ;;; 296 | 297 | ; SYNTAX (with-transformation transformation body ...) 298 | ; Store the initial-matrix of thed rawing context given by current-dc. 299 | ; Install transformation as the initial-matrix 300 | ; Evaluate body 301 | ; Restore the saved initial-matrix 302 | (define-syntax (with-transformation stx) 303 | (syntax-parse stx 304 | [(_with-transformation transformation body ...) 305 | (syntax/loc stx 306 | (let () 307 | (define dc (current-dc)) 308 | (define old-vector (send dc get-initial-matrix)) 309 | (define old-transformation (vector->transformation old-vector)) 310 | (define new-transformation 311 | ; transform frame coordinates into input coordinates of current transform 312 | (compose-transformation old-transformation transformation)) 313 | (send dc set-initial-matrix (transformation->vector new-transformation)) 314 | ; (send dc transform (transformation->vector transformation)) 315 | (begin0 316 | (begin body ...) 317 | (send dc set-initial-matrix old-vector))))])) 318 | 319 | ; SYNTAX (with-frame frame body ...) 320 | ; Evaluate body ... while the initial-matrix of the drawing context current-dc 321 | ; is given by the transformation corresponding to frame. 322 | (define-syntax (with-frame stx) 323 | (syntax-parse stx 324 | [(_with-frame frame #:who who body ...) 325 | (syntax/loc stx 326 | (begin 327 | (unless (current-dc) 328 | (raise-arguments-error 'who "should be called with the paint procedure without supplying a manual frame argument")) 329 | (with-transformation (frame->transformation frame) 330 | body ...)))])) 331 | 332 | ; SYNTAX (with-pen pen body ...) 333 | ; Evaluate body ... while pen is installed in the drawing context given by current-dc 334 | (define-syntax (with-pen stx) 335 | (syntax-parse stx 336 | [(_with-pen pen body ...) 337 | (syntax/loc stx 338 | (let () 339 | (define dc (current-dc)) 340 | (define old-pen (send dc get-pen)) 341 | (send dc set-pen pen) 342 | (begin0 343 | (begin body ...) 344 | (send dc set-pen old-pen))))])) 345 | 346 | ; SYNTAX (with-brush brush body ...) 347 | ; Evaluate body ... while brush is installed in the drawing context given by current-dc 348 | (define-syntax (with-brush stx) 349 | (syntax-parse stx 350 | [(_with-brush brush body ...) 351 | (syntax/loc stx 352 | (let () 353 | (define dc (current-dc)) 354 | (define old-brush (send dc get-brush)) 355 | (send dc set-brush brush) 356 | (begin0 357 | (begin body ...) 358 | (send dc set-brush old-brush))))])) 359 | ;;; 360 | ;;; Primitive Painters 361 | ;;; 362 | 363 | (provide painter/c 364 | ; 365 | with-transformation 366 | with-frame 367 | with-pen 368 | with-brush 369 | ; 370 | paint 371 | paint-hi-res 372 | paint-hires 373 | ; 374 | 375 | (contract-out [number->painter (-> (and/c natural-number/c (<=/c 255)) any/c)] 376 | [color->painter (-> (is-a?/c color%) painter/c)] 377 | [segments->painter (-> (sequence/c segment?) any/c)] 378 | [vects->painter (-> (sequence/c vect?) painter/c)] 379 | [procedure->painter (-> procedure? any/c)] 380 | [bitmap->painter (-> (or/c path-string? 381 | (is-a?/c bitmap%)) any/c)] 382 | [load-painter (-> (or/c path-string? 383 | (is-a?/c bitmap%)) any/c)])) 384 | 385 | ;;; Color Painter 386 | ;;; A color painter fills the unit square with a solid color 387 | (define (color->painter c) 388 | (define color (new-color c)) 389 | (define pen (new-pen color)) 390 | (define brush (new-brush color)) 391 | (λ (frame) 392 | (with-frame frame #:who color->painter 393 | (with-pen pen 394 | (with-brush brush 395 | (send (current-dc) draw-rectangle 0. 0. 1.0 1.0)))))) ; x y w h 396 | 397 | ;;; Number Painter 398 | ;;; A number painter is a color painter that draws a gray color from 0 to 255. 399 | (define (number->painter number-or-color) 400 | (define n number-or-color) 401 | (unless (and (number? n) (<= 0 n 255)) 402 | (raise-type-error 'number->painter "number between 0 and 255" n)) 403 | (color->painter (new-color n))) 404 | 405 | 406 | ;;; Segment Painter 407 | ;;; A segment painter draws a series of line segments. 408 | 409 | (define (segments->painter segments) 410 | (define pen black-pen) 411 | (define brush black-brush) 412 | (λ (frame) 413 | (with-frame frame #:who segments->painter 414 | (with-pen pen 415 | (with-brush brush 416 | (for ([a-segment segments]) 417 | (match-define (segment (vect x1 y1) (vect x2 y2)) a-segment) 418 | (send (current-dc) draw-line x1 y1 x2 y2))))))) 419 | 420 | (define (vects->painter vects) 421 | (segments->painter (vects->segments vects))) 422 | 423 | ;;; Bitmap Painter 424 | ;;; A bitmap painter draws a bitmap. 425 | (define (bitmap->painter bitmap) 426 | (define (new-bm) (if (path-string? bitmap) 427 | (make-object bitmap% bitmap) 428 | bitmap)) 429 | (define bm (new-bm)) 430 | (define bm-dc (new bitmap-dc% [bitmap bm])) 431 | (define flipped-bm (new-bm)) 432 | (define flipped-dc (new bitmap-dc% [bitmap flipped-bm])) 433 | (define w (* 1. (send bm get-width))) 434 | (define h (* 1. (send bm get-height))) 435 | (send flipped-dc set-initial-matrix (vector 1 0 0 -1 0 h)) 436 | (send flipped-dc draw-bitmap bm 0 0) 437 | (λ (frame) 438 | (with-frame frame #:who bitmap->painter 439 | (send (current-dc) draw-bitmap-section-smooth 440 | flipped-bm ; source 441 | 0. 0. ; dest-x dest-y 442 | 1. 1. ; dest-width dest-height 443 | 0. 0. ; src-x src-y 444 | w h ; src-width src-height 445 | )))) 446 | 447 | (define load-painter bitmap->painter) 448 | 449 | ;;; Procedure Painter 450 | (define (procedure->painter f [size 100]) 451 | ; f : vect -> color 452 | (define bm (make-object bitmap% size size)) 453 | (define dc (new bitmap-dc% [bitmap bm])) 454 | (define size.0 (* 1.0 size)) 455 | (for* ([x (in-range size)] [y (in-range size)]) 456 | (define x.0 (/ x size.0)) 457 | (define y.0 (/ y size.0)) 458 | (send dc set-pen (new-pen (new-color (f x.0 y.0)))) 459 | (send dc draw-point x y)) 460 | (λ (frame) 461 | (with-frame frame #:who procedure->painter 462 | (send (current-dc) draw-bitmap-section-smooth 463 | bm 0. 0. 1. 1. 0. 0. size size)))) 464 | 465 | ;;; 466 | ;;; General Utility 467 | ;;; 468 | 469 | (define (repeated f n) 470 | (cond 471 | [(= n 0) identity] 472 | [(= n 1) f] 473 | [else (compose f (repeated f (- n 1)))])) 474 | 475 | ;;; 476 | ;;; Higher Order Painters 477 | ;;; 478 | 479 | ;; See SICP for a description of these painters 480 | (provide transform-painter 481 | flip-horiz flip-vert rotate90 rotate180 rotate270 482 | superpose beside beside3 above3 below) 483 | 484 | (define (transform-painter painter origin corner1 corner2) 485 | (compose painter (make-relative-frame origin corner1 corner2))) 486 | 487 | (define (flip-horiz p) (transform-painter p (vect 1. 0.) (vect 0. 0.) (vect 1. 1.))) 488 | (define (flip-vert p) (transform-painter p (vect 0. 1.) (vect 1. 1.) (vect 0. 0.))) 489 | (define (rotate90 p) (transform-painter p (vect 1. 0.) (vect 1 1) (vect 0. 0.))) 490 | (define rotate180 (repeated rotate90 2)) 491 | (define rotate270 (repeated rotate90 3)) 492 | 493 | (define (superpose . painters) 494 | (λ (frame) 495 | (for ([painter painters]) 496 | (painter frame)))) 497 | 498 | (define (beside painter1 painter2) 499 | (define split-point (vect .5 0.)) 500 | (superpose 501 | (transform-painter painter1 zero-vector split-point (vect 0. 1.)) 502 | (transform-painter painter2 split-point (vect 1 0) (vect .5 1.)))) 503 | 504 | (define (beside3 painter1 painter2 painter3) 505 | (define split-point1 (vect (/ 1. 3) 0.)) 506 | (define split-point2 (vect (/ 2. 3) 0.)) 507 | (superpose 508 | (transform-painter painter1 zero-vector split-point1 (vect 0. 1.)) 509 | (transform-painter painter2 split-point1 split-point2 (vect (/ 1. 3) 1.)) 510 | (transform-painter painter3 split-point2 (vect 1. 0.) (vect (/ 2. 3) 1.)))) 511 | 512 | (define (above3 painter1 painter2 painter3) 513 | (define 1/3. (/ 1. 3.)) 514 | (define 2/3. (/ 2. 3.)) 515 | (superpose 516 | (transform-painter painter1 (vect 0. 2/3.) (vect 1. 2/3.) (vect 0. 1.)) 517 | (transform-painter painter2 (vect 0. 1/3.) (vect 1. 1/3.) (vect 0. 2/3.)) 518 | (transform-painter painter3 (vect 0. 0.) (vect 1. 0.) (vect 0. 1/3.)))) 519 | 520 | (define (below painter1 painter2) 521 | (rotate270 (beside (rotate90 painter2) 522 | (rotate90 painter1)))) 523 | 524 | ;;; 525 | ;;; Predefined Basic Painters 526 | ;;; 527 | (provide black white gray diagonal-shading mark-of-zorro einstein escher) 528 | (provide echo) 529 | 530 | (define black (number->painter 0)) 531 | (define white (number->painter 255)) 532 | (define gray (number->painter 150)) 533 | (define diagonal-shading (procedure->painter (λ (x y) (* 100 (+ x y))))) 534 | (define mark-of-zorro (vects->painter (list (vect .1 .9) (vect .8 .9) (vect .1 .2) (vect .9 .3)))) 535 | (define einstein (bitmap->painter einstein-file)) 536 | 537 | ;;; Escher Example 538 | 539 | ; Henderson's papers: 540 | ; http://users.ecs.soton.ac.uk/ph/funcgeo.pdf 541 | ; http://eprints.soton.ac.uk/257577/1/funcgeo2.pdf 542 | ; Blog: https://goo.gl/18L938 543 | 544 | (define (grid w h segs) 545 | (define (Vect x y) (vect (/ x (* 1.0 w)) (/ y (* 1.0 h)))) 546 | (define (->segment l) (match l [(list (list x1 y1) (list x2 y2)) 547 | (segment (Vect x1 y1) (Vect x2 y2))])) 548 | (segments->painter (map ->segment segs))) 549 | 550 | (define P (grid 16 16 551 | '[(( 4 4) ( 6 0)) (( 0 3) ( 3 4)) (( 3 4) ( 0 8)) 552 | (( 0 8) ( 0 3)) (( 4 5) ( 7 6)) (( 7 6) ( 4 10)) 553 | (( 4 10) ( 4 5)) ((11 0) (10 4)) ((10 4) ( 8 8)) 554 | (( 8 8) ( 4 13)) (( 4 13) ( 0 16)) ((11 0) (14 2)) 555 | ((14 2) (16 2)) ((10 4) (13 5)) ((13 5) (16 4)) 556 | (( 9 6) (12 7)) ((12 7) (16 6)) (( 8 8) (12 9)) 557 | ((12 9) (16 8)) (( 8 12) (16 10)) (( 0 16) ( 6 15)) 558 | (( 6 15) ( 8 16)) (( 8 16) (12 12)) ((12 12) (16 12)) 559 | ((10 16) (12 14)) ((12 14) (16 13)) ((12 16) (13 15)) 560 | ((13 15) (16 14)) ((14 16) (16 15)) ((16 0) (16 8)) 561 | ((16 12) (16 16))])) 562 | (define Q (grid 16 16 563 | '[(( 2 0) ( 4 5)) (( 4 5) ( 4 7)) (( 4 0) ( 6 5)) 564 | (( 6 5) ( 6 7)) (( 6 0) ( 8 5)) (( 8 5) ( 8 8)) 565 | (( 8 0) (10 6)) ((10 6) (10 9)) ((10 0) (14 11)) 566 | ((12 0) (13 4)) ((13 4) (16 8)) ((16 8) (15 10)) 567 | ((15 10) (16 16)) ((16 16) (12 10)) ((12 10) ( 6 7)) 568 | (( 6 7) ( 4 7)) (( 4 7) ( 0 8)) ((13 0) (16 6)) 569 | ((14 0) (16 4)) ((15 0) (16 2)) (( 0 10) ( 7 11)) 570 | (( 9 12) (10 10)) ((10 10) (12 12)) ((12 12) ( 9 12)) 571 | (( 8 15) ( 9 13)) (( 9 13) (11 15)) ((11 15) ( 8 15)) 572 | (( 0 12) ( 3 13)) (( 3 13) ( 7 15)) (( 7 15) ( 8 16)) 573 | (( 2 16) ( 3 13)) (( 4 16) ( 5 14)) (( 6 16) ( 7 15)) 574 | (( 0 0) ( 8 0)) ((12 0) (16 0))])) 575 | 576 | (define R (grid 16 16 577 | '[(( 0 12) ( 1 14)) (( 0 8) ( 2 12)) (( 0 4) ( 5 10)) 578 | (( 0 0) ( 8 8)) (( 1 1) ( 4 0)) (( 2 2) ( 8 0)) 579 | (( 3 3) ( 8 2)) (( 8 2) (12 0)) (( 5 5) (12 3)) 580 | ((12 3) (16 0)) (( 0 16) ( 2 12)) (( 2 12) ( 8 8)) 581 | (( 8 8) (14 6)) ((14 6) (16 4)) (( 6 16) (11 10)) 582 | ((11 10) (16 6)) ((11 16) (12 12)) ((12 12) (16 8)) 583 | ((12 12) (16 16)) ((13 13) (16 10)) ((14 14) (16 12)) 584 | ((15 15) (16 14))])) 585 | 586 | (define S (grid 16 16 587 | '[(( 0 0) ( 4 2)) (( 4 2) ( 8 2)) (( 8 2) (16 0)) 588 | (( 0 4) ( 2 1)) (( 0 6) ( 7 4)) (( 0 8) ( 8 6)) 589 | (( 0 10) ( 7 8)) (( 0 12) ( 7 10)) (( 0 14) ( 7 13)) 590 | (( 8 16) ( 7 13)) (( 7 13) ( 7 8)) (( 7 8) ( 8 6)) 591 | (( 8 6) (10 4)) ((10 4) (16 0)) ((10 16) (11 10)) 592 | ((10 6) (12 4)) ((12 4) (12 7)) ((12 7) (10 6)) 593 | ((13 7) (15 5)) ((15 5) (15 8)) ((15 8) (13 7)) 594 | ((12 16) (13 13)) ((13 13) (15 9)) ((15 9) (16 8)) 595 | ((13 13) (16 14)) ((14 11) (16 12)) ((15 9) (16 10))])) 596 | 597 | 598 | (define (escher) 599 | ; combinators 600 | (define (above p1 p2) 601 | (below p2 602 | p1)) 603 | (define (quartet p1 p2 p3 p4) 604 | (above (beside p1 p2) 605 | (beside p3 p4))) 606 | (define (nonet p1 p2 p3 p4 p5 p6 p7 p8 p9) 607 | (above3 (beside3 p1 p2 p3) 608 | (beside3 p4 p5 p6) 609 | (beside3 p7 p8 p9))) 610 | (define (cycle p1) 611 | (quartet p1 (rot (rot (rot p1))) 612 | (rot p1) (rot (rot p1)))) 613 | (define rot rotate90) 614 | (define b white) ; blank 615 | (define-values (p q r s) (values P Q R S)) 616 | (define t (quartet p q r s)) 617 | (define side1 (quartet b b (rot t) t)) 618 | (define side2 (quartet side1 side1 (rot t) t)) 619 | (define u (cycle (rot q))) 620 | (define corner1 (quartet b b b u)) 621 | (define corner2 (quartet corner1 side1 (rot side1) u)) 622 | (define corner (nonet corner2 side2 side2 623 | (rot side2) u (rot t) 624 | (rot side2) (rot t) q)) 625 | (define square-limit (cycle corner)) 626 | square-limit) 627 | 628 | ;(echo (escher)) 629 | -------------------------------------------------------------------------------- /sicp-pict/test/tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require sicp-pict 4 | rackunit) 5 | 6 | (define (get-pixels painter) 7 | (define obj (send (paint painter) get-bitmap)) 8 | (define width (send obj get-width)) 9 | (define height (send obj get-height)) 10 | (define out (make-bytes (* width height 4))) 11 | (send obj get-argb-pixels 0 0 width height out) 12 | out) 13 | 14 | (define rng '(10000 10100)) 15 | 16 | (check-equal? (apply subbytes (get-pixels einstein) rng) 17 | (apply subbytes (get-pixels (flip-horiz (flip-horiz einstein))) rng)) 18 | 19 | (check-equal? (apply subbytes (get-pixels einstein) rng) 20 | (apply subbytes (get-pixels (flip-vert (flip-vert einstein))) rng)) 21 | 22 | (check-not-equal? (apply subbytes (get-pixels einstein) rng) 23 | (apply subbytes (get-pixels (flip-horiz einstein)) rng)) 24 | 25 | (check-not-equal? (apply subbytes (get-pixels einstein) rng) 26 | (apply subbytes (get-pixels (flip-vert einstein)) rng)) 27 | -------------------------------------------------------------------------------- /sicp/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | #:language 'sicp 3 | -------------------------------------------------------------------------------- /sicp/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/provide 4 | (prefix-in r5rs: r5rs) 5 | (rename-in racket [random racket:random])) 6 | 7 | (provide (filtered-out (λ (name) (regexp-replace #px"^r5rs:" name "")) 8 | (except-out (all-from-out r5rs) r5rs:#%module-begin)) 9 | (rename-out [module-begin #%module-begin])) 10 | 11 | (define-syntax (define+provide stx) 12 | (syntax-case stx () 13 | [(_ (id . args) . body) #'(begin 14 | (provide id) 15 | (define (id . args) . body))] 16 | [(_ id expr) #'(begin 17 | (provide id) 18 | (define id expr))])) 19 | 20 | (provide true) 21 | (provide false) 22 | (provide error) 23 | (provide identity) 24 | (define+provide nil '()) 25 | (define+provide the-empty-stream '()) 26 | (define+provide stream-null? null?) 27 | (define+provide (inc x) (+ x 1)) 28 | (define+provide (dec x) (- x 1)) 29 | (define+provide (runtime) 30 | (inexact->exact (truncate (* 1000 (current-inexact-milliseconds))))) 31 | (define+provide (random n) 32 | (if (and (integer? n) (exact? n)) 33 | (racket:random n) 34 | (* n (racket:random)))) 35 | 36 | (provide cons-stream) 37 | (define-syntax cons-stream 38 | (syntax-rules () 39 | [(_ A B) (r5rs:cons A (r5rs:delay B))])) 40 | 41 | 42 | (provide amb) 43 | 44 | (define (amb-fail) (error "amb tree exhausted")) 45 | (define (set-amb-fail! x) (set! amb-fail x)) 46 | 47 | (define-syntax-rule (explore +prev-amb-fail +sk alt) 48 | (call/cc 49 | (lambda (+fk) 50 | (set-amb-fail! 51 | (thunk 52 | (set-amb-fail! +prev-amb-fail) 53 | (+fk 'fail))) 54 | (+sk alt)))) 55 | 56 | (define-syntax-rule (amb alt ...) 57 | (let ([+prev-amb-fail amb-fail]) 58 | (call/cc 59 | (lambda (+sk) 60 | (explore +prev-amb-fail +sk alt) ... 61 | (+prev-amb-fail))))) 62 | 63 | (define-syntax module-begin 64 | (syntax-rules () 65 | ((_ . forms) 66 | (#%printing-module-begin 67 | (module configure-runtime '#%kernel 68 | (print-as-expression #f) 69 | (print-pair-curly-braces #t) 70 | (print-mpair-curly-braces #f)) 71 | . forms)))) 72 | -------------------------------------------------------------------------------- /sicp/test/amb.rkt: -------------------------------------------------------------------------------- 1 | #lang sicp 2 | 3 | (#%require rackunit) 4 | 5 | (check-equal? (let ([x (amb 0 1 2)]) 6 | (cond 7 | [(= x 0) (amb)] 8 | [(= x 1) -1] 9 | [else -2])) -1) 10 | 11 | (check-equal? (amb (amb) 42 1337) 42) 12 | --------------------------------------------------------------------------------