--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.cbf,v 1.1 1991/08/22 17:44:50 arthur Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(compile-directory ".")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.1 1991/08/22 17:42:15 arthur Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(fluid-let ((sf/default-syntax-table syntax-table/system-internal))
+ (for-each sf-conditionally
+ '("arith" "nodefs" "picture" "pic-record" "pic-image" "pic-read"
+ "pic-ops")))
+
+;; Guarantee that the package modeller is loaded.
+(if (not (name->package '(CROSS-REFERENCE)))
+ (with-working-directory-pathname "/scheme/800/cref"
+ (lambda ()
+ (load "make"))))
+
+(cref/generate-all "6001")
+(sf "6001.con")
+(sf "6001.ldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/arith.scm,v 1.1 1991/08/22 17:42:25 arthur Exp $
+
+Copyright (c) 1989-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Scheme Arithmetic for 6.001
+;;; package: (student number)
+
+(declare (usual-integrations))
+\f
+(define-integrable (int:->flonum n)
+ ((ucode-primitive integer->flonum 2) n #b10))
+
+(define-integrable (flonum? object)
+ (object-type? (ucode-type big-flonum) object))
+
+(declare (integrate flo:integer?))
+(define (flo:integer? x)
+ (flo:= x (flo:round x)))
+
+(define (flo:->integer x)
+ (if (not (flo:integer? x))
+ (error:wrong-type-argument x "integer" 'FLONUM->INTEGER))
+ (flo:truncate->exact x))
+
+(define-integrable (guarantee-integer object procedure)
+ (if (not (int:integer? object))
+ (error:wrong-type-argument object "number" procedure)))
+
+(let-syntax
+ ((define-standard-unary
+ (macro (name flo:op int:op)
+ `(DEFINE (,name X)
+ (IF (FLONUM? X)
+ (,flo:op X)
+ (,int:op X))))))
+ (define-standard-unary rational? (lambda (x) x true) int:integer?)
+ (define-standard-unary integer? flo:integer? int:integer?)
+ (define-standard-unary exact? (lambda (x) x false)
+ (lambda (x)
+ (guarantee-integer x 'EXACT?)
+ true))
+ (define-standard-unary zero? flo:zero? int:zero?)
+ (define-standard-unary negative? flo:negative? int:negative?)
+ (define-standard-unary positive? flo:positive? int:positive?)
+ (define-standard-unary abs flo:abs int:abs)
+ (define-standard-unary floor flo:floor (lambda (x) x))
+ (define-standard-unary ceiling flo:ceiling (lambda (x) x))
+ (define-standard-unary truncate flo:truncate (lambda (x) x))
+ (define-standard-unary round flo:round (lambda (x) x))
+ (define-standard-unary exact->inexact (lambda (x) x) int:->flonum)
+ (define-standard-unary inexact->exact
+ (lambda (x)
+ (if (not (flo:integer? x))
+ (error:bad-range-argument x 'INEXACT->EXACT))
+ (flo:truncate->exact x))
+ (lambda (x)
+ (guarantee-integer x 'INEXACT->EXACT)
+ x)))
+\f
+(let-syntax
+ ((define-standard-binary
+ (macro (name flo:op int:op)
+ `(DEFINE (,name X Y)
+ (IF (FLONUM? X)
+ (IF (FLONUM? Y)
+ (,flo:op X Y)
+ (,flo:op X (INT:->FLONUM Y)))
+ (IF (FLONUM? Y)
+ (,flo:op (INT:->FLONUM X) Y)
+ (,int:op X Y)))))))
+ (define-standard-binary real:+ flo:+ int:+)
+ (define-standard-binary real:- flo:- int:-)
+ (define-standard-binary rationalize
+ flo:rationalize
+ int:rationalize))
+
+(define (int:rationalize q e)
+ (int:simplest-rational (int:- q e) (int:+ q e)))
+
+(define (int:simplest-rational x y)
+ (let ((x<y
+ (lambda (x y)
+ (cond ((int:positive? x) x)
+ ((int:negative? y) y)
+ (else 0)))))
+ (cond ((int:< x y) (x<y x y))
+ ((int:< y x) (x<y y x))
+ (else x))))
+
+(define (real:* x y)
+ (cond ((flonum? x)
+ (cond ((flonum? y) (flo:* x y))
+ ((int:zero? y) y)
+ (else (flo:* x (int:->flonum y)))))
+ ((int:zero? x) x)
+ ((flonum? y) (flo:* (int:->flonum x) y))
+ (else (int:* x y))))
+
+(define (real:/ x y)
+ (let ((y (if (flonum? y) y (int:->flonum y))))
+ (cond ((flonum? x) (flo:/ x y))
+ ((int:zero? x) x)
+ (else (flo:/ (int:->flonum x) y)))))
+\f
+(define (real:= x y)
+ (if (flonum? x)
+ (if (flonum? y)
+ (flo:= x y)
+ (begin
+ (guarantee-integer y '=)
+ (and (flo:= x (flo:truncate x))
+ (int:= (flo:truncate->exact x) y))))
+ (if (flonum? y)
+ (begin
+ (guarantee-integer x '=)
+ (and (flo:= y (flo:truncate y))
+ (int:= x (flo:truncate->exact y))))
+ (int:= x y))))
+
+(define (real:< x y)
+ (if (flonum? x)
+ (if (flonum? y)
+ (flo:< x y)
+ (flo/int:< x y))
+ (if (flonum? y)
+ (int/flo:< x y)
+ (int:< x y))))
+
+(define (real:max x y)
+ (if (flonum? x)
+ (if (flonum? y)
+ (if (flo:< x y) y x)
+ (if (flo/int:< x y) (int:->flonum y) x))
+ (if (flonum? y)
+ (if (int/flo:< x y) y (int:->flonum x))
+ (if (int:< x y) y x))))
+
+(define (real:min x y)
+ (if (flonum? x)
+ (if (flonum? y)
+ (if (flo:< x y) x y)
+ (if (flo/int:< x y) x (int:->flonum y)))
+ (if (flonum? y)
+ (if (int/flo:< x y) (int:->flonum x) y)
+ (if (int:< x y) x y))))
+
+(define-integrable (flo/int:< x y)
+ (let ((ix (flo:truncate->exact x)))
+ (cond ((int:< ix y) true)
+ ((int:< y ix) false)
+ (else (flo:< x (flo:truncate x))))))
+
+(define-integrable (int/flo:< x y)
+ (let ((iy (flo:truncate->exact y)))
+ (cond ((int:< x iy) true)
+ ((int:< iy x) false)
+ (else (flo:< (flo:truncate y) y)))))
+\f
+(define (even? n)
+ (int:even? (if (flonum? n) (flo:->integer n) n)))
+
+(let-syntax
+ ((define-integer-binary
+ (macro (name operator)
+ `(DEFINE (,name N M)
+ (IF (FLONUM? N)
+ (INT:->FLONUM
+ (,operator (FLO:->INTEGER N)
+ (IF (FLONUM? M) (FLO:->INTEGER M) M)))
+ (IF (FLONUM? M)
+ (INT:->FLONUM (,operator N (FLO:->INTEGER M)))
+ (,operator N M)))))))
+ (define-integer-binary quotient int:quotient)
+ (define-integer-binary remainder int:remainder)
+ (define-integer-binary modulo int:modulo)
+ (define-integer-binary real:gcd int:gcd)
+ (define-integer-binary real:lcm int:lcm))
+
+(define (numerator q)
+ (if (flonum? q)
+ (int:->flonum (rat:numerator (flo:->rational q)))
+ (begin
+ (guarantee-integer q 'NUMERATOR)
+ q)))
+
+(define (denominator q)
+ (if (flonum? q)
+ (int:->flonum (rat:denominator (flo:->rational q)))
+ (begin
+ (guarantee-integer q 'DENOMINATOR)
+ 1)))
+
+(let-syntax
+ ((define-transcendental-unary
+ (macro (name hole? hole-value function)
+ `(DEFINE (,name X)
+ (IF (,hole? X)
+ ,hole-value
+ (,function (REAL:->FLONUM X)))))))
+ (define-transcendental-unary exp real:exact0= 1 flo:exp)
+ (define-transcendental-unary log real:exact1= 0 flo:log)
+ (define-transcendental-unary sin real:exact0= 0 flo:sin)
+ (define-transcendental-unary cos real:exact0= 1 flo:cos)
+ (define-transcendental-unary tan real:exact0= 0 flo:tan)
+ (define-transcendental-unary asin real:exact0= 0 flo:asin)
+ (define-transcendental-unary acos real:exact1= 0 flo:acos)
+ (define-transcendental-unary real:atan real:exact0= 0 flo:atan))
+
+(define (real:atan2 y x)
+ (if (and (real:exact0= y) (exact? x))
+ 0
+ (flo:atan2 (real:->flonum y) (real:->flonum x))))
+
+(define-integrable (real:exact0= x)
+ (if (flonum? x) false (int:zero? x)))
+
+(define-integrable (real:exact1= x)
+ (if (flonum? x) false (int:= 1 x)))
+
+(define (real:->flonum x)
+ (if (flonum? x)
+ x
+ (int:->flonum x)))
+\f
+(define (sqrt x)
+ (if (flonum? x)
+ (begin
+ (if (flo:negative? x)
+ (error:bad-range-argument x 'SQRT))
+ (flo:sqrt x))
+ (int:sqrt x)))
+
+(define (int:sqrt x)
+ (if (int:negative? x)
+ (error:bad-range-argument x 'SQRT))
+ (let ((guess (flo:sqrt (int:->flonum x))))
+ (let ((n (flo:round->exact guess)))
+ (if (int:= x (int:* n n))
+ n
+ guess))))
+
+(define (expt x y)
+ (let ((general-case
+ (lambda (x y)
+ (cond ((flo:zero? y) 1.)
+ ((flo:zero? x)
+ (if (not (flo:positive? y))
+ (error:divide-by-zero 'EXPT (list x y)))
+ x)
+ (else
+ (if (and (flo:negative? x)
+ (not (flo:integer? y)))
+ (error:bad-range-argument x 'EXPT))
+ (flo:expt x y))))))
+ (if (flonum? x)
+ (if (flonum? y)
+ (general-case x y)
+ (let ((exact-method
+ (lambda (y)
+ (if (int:= 1 y)
+ x
+ (let loop ((x x) (y y) (answer 1.))
+ (let ((qr (int:divide y 2)))
+ (let ((x (flo:* x x))
+ (y (integer-divide-quotient qr))
+ (answer
+ (if (int:zero?
+ (integer-divide-remainder qr))
+ answer
+ (flo:* answer x))))
+ (if (int:= 1 y)
+ (flo:* answer x)
+ (loop x y answer)))))))))
+ (cond ((int:positive? y) (exact-method y))
+ ((int:negative? y)
+ (flo:/ 1. (exact-method (int:negate y))))
+ (else 1.))))
+ (if (flonum? y)
+ (general-case (int:->flonum x) y)
+ (int:expt x y)))))
+\f
+(define number? rational?)
+(define complex? rational?)
+(define real? rational?)
+
+(define (inexact? z)
+ (not (exact? z)))
+
+(define (odd? n)
+ (not (even? n)))
+
+(define (= . zs)
+ (reduce-comparator real:= zs))
+
+(define (< . xs)
+ (reduce-comparator real:< xs))
+
+(define (> . xs)
+ (reduce-comparator (lambda (x y) (real:< y x)) xs))
+
+(define (<= . xs)
+ (reduce-comparator (lambda (x y) (not (real:< y x))) xs))
+
+(define (>= . xs)
+ (reduce-comparator (lambda (x y) (not (real:< x y))) xs))
+
+(define (max x . xs)
+ (reduce-max/min real:max x xs))
+
+(define (min x . xs)
+ (reduce-max/min real:min x xs))
+
+(define (+ . zs)
+ (cond ((null? zs) 0)
+ ((null? (cdr zs)) (car zs))
+ ((null? (cddr zs)) (real:+ (car zs) (cadr zs)))
+ (else
+ (real:+ (car zs)
+ (real:+ (cadr zs)
+ (reduce real:+ 0 (cddr zs)))))))
+
+(define (* . zs)
+ (cond ((null? zs) 1)
+ ((null? (cdr zs)) (car zs))
+ ((null? (cddr zs)) (real:* (car zs) (cadr zs)))
+ (else
+ (real:* (car zs)
+ (real:* (cadr zs)
+ (reduce real:* 1 (cddr zs)))))))
+
+(define (- z1 . zs)
+ (cond ((null? zs)
+ (if (flonum? z1) (flo:negate z1) (int:negate z1)))
+ ((null? (cdr zs))
+ (real:- z1 (car zs)))
+ (else
+ (real:- z1
+ (real:+ (car zs)
+ (real:+ (cadr zs)
+ (reduce real:+ 0 (cddr zs))))))))
+
+(define (/ z1 . zs)
+ (cond ((null? zs)
+ (flo:/ 1. (if (flonum? z1) z1 (int:->flonum z1))))
+ ((null? (cdr zs))
+ (real:/ z1 (car zs)))
+ (else
+ (real:/ z1
+ (real:* (car zs)
+ (real:* (cadr zs)
+ (reduce real:* 1 (cddr zs))))))))
+
+(define (gcd . integers)
+ (reduce real:gcd 0 integers))
+
+(define (lcm . integers)
+ (reduce real:lcm 1 integers))
+
+(define (atan z #!optional x)
+ (if (default-object? x) (real:atan z) (real:atan2 z x)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/make.scm,v 1.1 1991/08/22 17:42:30 arthur Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; 6.001: System Construction
+
+(declare (usual-integrations))
+
+(package/system-loader "6001" '() 'QUERY)
+((access initialize-package! (->environment '(student scode-rewriting))))
+(add-system! (make-system "6.001" 15 0 '()))
+(in-package (->environment '(edwin))
+ (using-syntax (access edwin-syntax-table (->environment '(edwin)))
+ (set-variable! enable-transcript-buffer true)))
+(ge '(student))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/nodefs.scm,v 1.1 1991/08/22 17:42:36 arthur Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode rewriting for 6.001
+;;; package: (student scode-rewriting)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! hook/repl-eval student/repl-eval)
+ unspecific)
+
+(define (student/repl-eval repl s-expression environment syntax-table)
+ (let ((scode (rewrite-scode (syntax s-expression syntax-table) repl)))
+ (with-new-history (lambda () (extended-scode-eval scode environment)))))
+
+(define (rewrite-scode expression repl)
+ (let ((expression
+ (if (open-block? expression)
+ (open-block-components expression unscan-defines)
+ expression)))
+ (check-for-illegal-definitions expression)
+ (make-sequence
+ (map (lambda (expression)
+ (if (definition? expression)
+ (let ((name (definition-name expression))
+ (value (definition-value expression)))
+ (make-sequence
+ (list expression
+ (make-combination write-definition-value
+ (list name
+ (make-variable name))))))
+ expression))
+ (sequence-actions expression)))))
+
+(define (write-definition-value name value)
+ (let ((port (nearest-cmdl/output-port)))
+ (fresh-line port)
+ (write-string ";" port)
+ (write name port)
+ (write-string ": " port)
+ (write value port)))
+\f
+(define (check-for-illegal-definitions expression)
+ (walk/expression (if (open-block? expression)
+ (open-block-components expression unscan-defines)
+ expression)
+ 'LEGAL))
+
+(define (walk/expression expression context)
+ ((scode-walk walker expression) expression context))
+
+(define-integrable (walk/no-definitions expression)
+ (walk/expression expression 'ILLEGAL))
+
+(define (walk/lambda expression context)
+ context
+ (let loop
+ ((expressions
+ (sequence-actions
+ (lambda-components expression
+ (lambda (name required optional rest auxiliary declarations body)
+ name required optional rest
+ (unscan-defines auxiliary declarations body))))))
+ (if (definition? (car expressions))
+ (begin
+ (walk/no-definitions (definition-value (car expressions)))
+ (if (not (null? (cdr expressions)))
+ (loop (cdr expressions))))
+ (for-each walk/no-definitions expressions))))
+
+(define (walk/definition expression context)
+ (case context
+ ((ILLEGAL)
+ (error "Definition appears in illegal context:"
+ (unsyntax expression)))
+ ((UNUSUAL)
+ (warn "Definition appears in unusual context:"
+ (unsyntax expression))))
+ (walk/no-definitions (definition-value expression)))
+
+(define (walk/sequence expression context)
+ (for-each (lambda (expression)
+ (walk/expression expression context))
+ (sequence-actions expression)))
+
+(define (walk/constant expression context)
+ expression context
+ unspecific)
+
+(define (walk/access expression context)
+ context
+ (walk/no-definitions (access-environment expression)))
+
+(define (walk/assignment expression context)
+ context
+ (walk/no-definitions (assignment-value expression)))
+
+(define (walk/combination expression context)
+ context
+ (walk/no-definitions (combination-operator expression))
+ (for-each walk/no-definitions (combination-operands expression)))
+
+(define (walk/comment expression context)
+ (walk/expression (comment-expression expression) context))
+
+(define (walk/conditional expression context)
+ (walk/no-definitions (conditional-predicate expression))
+ (let ((context (if (eq? 'LEGAL context) 'UNUSUAL context)))
+ (walk/expression (conditional-consequent expression) context)
+ (walk/expression (conditional-alternative expression) context)))
+
+(define (walk/delay expression context)
+ context
+ (walk/no-definitions (delay-expression expression)))
+
+(define (walk/disjunction expression context)
+ (walk/no-definitions (disjunction-predicate expression))
+ (walk/expression (disjunction-alternative expression)
+ (if (eq? 'LEGAL context) 'UNUSUAL context)))
+
+(define (walk/in-package expression context)
+ context
+ (walk/no-definitions (in-package-environment expression))
+ (check-for-illegal-definitions (in-package-expression expression)))
+
+(define walker
+ (make-scode-walker
+ walk/constant
+ `((ACCESS ,walk/access)
+ (ASSIGNMENT ,walk/assignment)
+ (COMBINATION ,walk/combination)
+ (COMMENT ,walk/comment)
+ (CONDITIONAL ,walk/conditional)
+ (DEFINITION ,walk/definition)
+ (DELAY ,walk/delay)
+ (DISJUNCTION ,walk/disjunction)
+ (IN-PACKAGE ,walk/in-package)
+ (LAMBDA ,walk/lambda)
+ (SEQUENCE ,walk/sequence))))
\ No newline at end of file
--- /dev/null
+;;; Procedure to build an image given a picture and the magnification factors
+
+(declare (usual-integrations))
+
+(define (build-image pic window h-sf v-sf pic-min pic-max)
+ (let* ((colormap-size (colormap-size (get-visual-info window)))
+ (pic-height (picture-height pic)) ;py
+ (pic-width (picture-width pic)) ;x
+ (pic-data (picture-data pic))
+ (image-width (fix:* h-sf pic-width)) ;x
+ (image-height (fix:* v-sf pic-height)) ;iy
+ (image (graphics-operation window 'create-image
+ image-width image-height))
+ (byte-string (make-string (fix:* image-width image-height)))
+ (py-max (- pic-height 1))
+ (rect-index-height (fix:* v-sf image-width))
+ (range (flo:- pic-max pic-min))
+ (mul (if (flo:< range 1e-12)
+ 0.
+ (/ colormap-size (flo:* (flo:+ 1. 7.142e-8) ; 1+epsilon
+ range)))))
+
+ ;; The range was slightly adjusted so that an illegal grey level would
+ ;; never be generated. epsilon was carefully chosen so that no error would
+ ;; be incurred in transforming to actual grey levels up to a colormap-size
+ ;; of 2^24. In general, choose epsilon such that:
+ ;; colormap-size < (/ (1+ epsilon) epsilon)
+
+ (cond ((and (fix:= 1 h-sf) (fix:= 1 v-sf))
+ (let y-loop ((py py-max) (iy-index 0))
+ (if (fix:<= 0 py)
+ (begin
+ (let ((pic-row (floating-vector-ref pic-data py)))
+ (let x-loop ((px 0))
+ (if (fix:< px pic-width)
+ (begin
+ (vector-8b-set!
+ byte-string
+ (fix:+ px iy-index)
+ (flo:floor->exact
+ (flo:* mul
+ (flo:- (floating-vector-ref pic-row px)
+ pic-min))))
+ (x-loop (fix:+ px 1))))))
+ (y-loop (fix:- py 1) (fix:+ iy-index rect-index-height))))))
+
+ ((and (fix:= 2 h-sf) (fix:= 2 v-sf))
+ (let y-loop ((py py-max) (iy-index 0))
+ (if (fix:<= 0 py)
+ (let ((pic-row (floating-vector-ref pic-data py)))
+ (let x-loop ((px 0) (ix 0))
+ (if (fix:< px pic-width)
+ (let* ((n-is-0 (fix:+ ix iy-index))
+ (n-is-1 (fix:+ n-is-0 image-width))
+ (v (flo:floor->exact
+ (flo:* mul
+ (flo:- (floating-vector-ref pic-row px)
+ pic-min)))))
+ (vector-8b-set! byte-string n-is-0 v)
+ (vector-8b-set! byte-string (fix:+ n-is-0 1) v)
+ (vector-8b-set! byte-string n-is-1 v)
+ (vector-8b-set! byte-string (fix:+ n-is-1 1) v)
+ (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+ (y-loop (fix:- py 1)
+ (fix:+ iy-index rect-index-height))))))))
+
+ ((and (fix:= 3 h-sf) (fix:= 3 v-sf))
+ (let y-loop ((py py-max) (iy-index 0))
+ (if (fix:<= 0 py)
+ (let ((pic-row (floating-vector-ref pic-data py)))
+ (let x-loop ((px 0) (ix 0))
+ (if (fix:< px pic-width)
+ (let* ((row0 (fix:+ ix iy-index))
+ (row1 (fix:+ row0 image-width))
+ (row2 (fix:+ row1 image-width))
+ (v (flo:floor->exact
+ (flo:* mul
+ (flo:- (floating-vector-ref pic-row px)
+ pic-min)))))
+ (vector-8b-set! byte-string row0 v)
+ (vector-8b-set! byte-string (fix:+ row0 1) v)
+ (vector-8b-set! byte-string (fix:+ row0 2) v)
+ (vector-8b-set! byte-string row1 v)
+ (vector-8b-set! byte-string (fix:+ row1 1) v)
+ (vector-8b-set! byte-string (fix:+ row1 2) v)
+ (vector-8b-set! byte-string row2 v)
+ (vector-8b-set! byte-string (fix:+ row2 1) v)
+ (vector-8b-set! byte-string (fix:+ row2 2) v)
+ (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+ (y-loop (fix:- py 1)
+ (fix:+ iy-index rect-index-height))))))))
+
+ ((and (fix:= 4 h-sf) (fix:= 4 v-sf))
+ (let y-loop ((py py-max) (iy-index 0))
+ (if (fix:<= 0 py)
+ (let ((pic-row (floating-vector-ref pic-data py)))
+ (let x-loop ((px 0) (ix 0))
+ (if (fix:< px pic-width)
+ (let* ((row0 (fix:+ ix iy-index))
+ (row1 (fix:+ row0 image-width))
+ (row2 (fix:+ row1 image-width))
+ (row3 (fix:+ row2 image-width))
+ (v (flo:floor->exact
+ (flo:* mul
+ (flo:- (floating-vector-ref pic-row px)
+ pic-min)))))
+ (vector-8b-set! byte-string row0 v)
+ (vector-8b-set! byte-string (fix:+ row0 1) v)
+ (vector-8b-set! byte-string (fix:+ row0 2) v)
+ (vector-8b-set! byte-string (fix:+ row0 3) v)
+ (vector-8b-set! byte-string row1 v)
+ (vector-8b-set! byte-string (fix:+ row1 1) v)
+ (vector-8b-set! byte-string (fix:+ row1 2) v)
+ (vector-8b-set! byte-string (fix:+ row1 3) v)
+ (vector-8b-set! byte-string row2 v)
+ (vector-8b-set! byte-string (fix:+ row2 1) v)
+ (vector-8b-set! byte-string (fix:+ row2 2) v)
+ (vector-8b-set! byte-string (fix:+ row2 3) v)
+ (vector-8b-set! byte-string row3 v)
+ (vector-8b-set! byte-string (fix:+ row3 1) v)
+ (vector-8b-set! byte-string (fix:+ row3 2) v)
+ (vector-8b-set! byte-string (fix:+ row3 3) v)
+ (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+ (y-loop (fix:- py 1)
+ (fix:+ iy-index rect-index-height))))))))
+
+ (else
+ (let y-loop ((py py-max) (iy-index 0))
+ (if (fix:<= 0 py)
+ (let ((pic-row (floating-vector-ref pic-data py)))
+ (let x-loop ((px 0) (ix 0))
+ (if (fix:< px pic-width)
+ (let* ((v (flo:floor->exact
+ (flo:* mul
+ (flo:- (floating-vector-ref pic-row px)
+ pic-min))))
+ (n-start (fix:+ ix iy-index))
+ (n-end (fix:+ n-start rect-index-height)))
+ (let n-loop ((n n-start))
+ (if (fix:< n n-end)
+ (let ((m-end (fix:+ n h-sf)))
+ (let m-loop ((m n))
+ (if (fix:< m m-end)
+ (begin
+ (vector-8b-set! byte-string
+ m v)
+ (m-loop (fix:+ m 1)))
+ (n-loop (fix:+ n image-width)))))
+ (x-loop (fix:+ px 1) (fix:+ ix h-sf)))))
+ (y-loop (fix:- py 1)
+ (fix:+ iy-index rect-index-height)))))))))
+
+ (x-image/fill-from-byte-vector image byte-string)
+ (1d-table/put! (graphics-device/properties window) image #t)
+ image))
+
--- /dev/null
+
+;;; Operations for manipulating pictures
+(declare (usual-integrations))
+
+(define-integrable (in-rect? x y width height)
+ (and (fix:< -1 x) (fix:< x width) (fix:< -1 y) (fix:< y height)))
+
+(define make-pt cons)
+(define xcor car)
+(define ycor cdr)
+
+(define (picture-overlap pic1 pic2 u v)
+ (let* ((wid1 (picture-width pic1))
+ (hgt1 (picture-height pic1))
+ (p1-data (picture-data pic1))
+ (wid2 (picture-width pic2))
+ (hgt2 (picture-height pic2))
+ (p2-data (picture-data pic2))
+ (u (floor->exact u))
+ (v (floor->exact v))
+ (lf (min 0 u))
+ (dn (min 0 v))
+ (rt (max wid2 (fix:+ wid1 u)))
+ (up (max hgt2 (fix:+ hgt1 v)))
+ (p1x-offset (fix:- u lf))
+ (p1y-offset (fix:- v dn))
+ (new-min (min (picture-min pic1) (picture-min pic2)))
+ (new-pic (make-picture (fix:- rt lf) (fix:- up dn) new-min))
+ (new-data (picture-data new-pic)))
+
+;; place pic2 in its proper place on the resulting picture
+ (let y-loop ((y 0))
+ (if (fix:< y hgt2)
+ (let* ((p2-yth-row (floating-vector-ref p2-data y))
+ (new-yth-row (floating-vector-ref new-data (fix:- y dn))))
+ (let x-loop ((x 0))
+ (if (fix:< x wid2)
+ (begin
+ (floating-vector-set! new-yth-row (fix:- x lf)
+ (floating-vector-ref p2-yth-row x))
+ (x-loop (fix:+ x 1)))
+ (y-loop (fix:+ y 1)))))))
+
+ ;; overlay pic1 in its proper location in the result
+ (let y-loop ((y 0))
+ (if (fix:< y hgt1)
+ (let* ((p1-yth-row (floating-vector-ref p1-data y))
+ (new-yth-row (floating-vector-ref new-data
+ (fix:+ y p1y-offset))))
+ (let x-loop ((x 0))
+ (if (fix:< x wid1)
+ (begin
+ (floating-vector-set! new-yth-row (fix:+ x p1x-offset)
+ (floating-vector-ref p1-yth-row x))
+ (x-loop (fix:+ x 1)))
+ (y-loop (fix:+ y 1)))))))
+ (picture-set-data! new-pic new-data)
+ new-pic))
+
+(define (picture-paste! pic1 pic2 u v)
+ (let ((wid1 (picture-width pic1))
+ (hgt1 (picture-height pic1))
+ (p1-data (picture-data pic1))
+ (wid2 (picture-width pic2))
+ (hgt2 (picture-height pic2))
+ (p2-data (picture-data pic2))
+ (u (floor->exact u))
+ (v (floor->exact v)))
+ (if (in-rect? u v wid2 hgt2)
+ (if (and (fix:<= (fix:+ u wid1) wid2) (fix:<= (fix:+ v hgt1) hgt2))
+ (let y-loop ((y 0))
+ (if (fix:< y hgt1)
+ (let ((p1-yth-row (floating-vector-ref p1-data y))
+ (p2-yth-row (floating-vector-ref p2-data (fix:+ y v))))
+ (let x-loop ((x 0))
+ (if (fix:< x wid1)
+ (begin
+ (floating-vector-set! p2-yth-row (fix:+ x u)
+ (floating-vector-ref p1-yth-row x))
+ (x-loop (fix:+ x 1)))
+ (y-loop (fix:+ y 1))))))
+ (picture-set-data! pic2 p2-data))
+ (error "Picture too large -- PICTURE-PASTE!"))
+ (error "Coordinates out of bounds -- PICTURE-PASTE!"))))
+
+(define (picture-cut pic u v cut-wid cut-hgt)
+ (let* ((wid (picture-width pic))
+ (hgt (picture-height pic))
+ (data (picture-data pic))
+ (u (floor->exact u))
+ (v (floor->exact v))
+ (cut-wid (floor->exact cut-wid))
+ (cut-hgt (floor->exact cut-hgt))
+ (new-pic (make-picture cut-wid cut-hgt))
+ (new-data (picture-data new-pic)))
+ (if (not (in-rect? u v wid hgt))
+ (error "Coordinates out of bounds -- PICTURE-CUT"))
+ (if (not (fix:<= (fix:+ u cut-wid) wid))
+ (error:bad-range-argument cut-wid 'PICTURE-CUT))
+ (if (not (fix:<= (fix:+ v cut-hgt) hgt))
+ (error:bad-range-argument cut-hgt 'PICTURE-CUT))
+ (let y-loop ((y 0))
+ (if (fix:< y cut-hgt)
+ (let ((new-yth-row (floating-vector-ref new-data y))
+ (old-yth-row (floating-vector-ref data (fix:+ v y))))
+ (let x-loop ((x 0))
+ (if (fix:< x cut-wid)
+ (begin
+ (floating-vector-set! new-yth-row x
+ (floating-vector-ref old-yth-row (fix:+ u x)))
+ (x-loop (fix:+ x 1)))
+ (y-loop (fix:+ y 1))))))
+ (picture-set-data! new-pic new-data)
+ new-pic)))
+
+(define (picture-scale pic xsf ysf)
+ (let* ((wid (floor->exact (* xsf (picture-width pic))))
+ (hgt (floor->exact (* ysf (picture-height pic))))
+ (data (picture-data pic))
+ (new-pic (make-picture wid hgt))
+ (new-data (picture-data new-pic))
+ (->discrete-y (if (flo:> ysf 1.)
+ floor->exact
+ ceiling->exact))
+ (->discrete-x (if (flo:> xsf 1.)
+ floor->exact
+ ceiling->exact)))
+ (let y-loop ((ny 0) (old-y-index -1))
+ (if (fix:< ny hgt)
+ (let ((y-index (->discrete-y (/ ny ysf))))
+ (if (fix:= y-index old-y-index) ; don't recompute the row
+ (floating-vector-set! new-data ny
+ (floating-vector-copy
+ (floating-vector-ref new-data (fix:- ny 1))))
+ (let ((yth-row (floating-vector-ref data y-index))
+ (new-yth-row (floating-vector-ref new-data ny)))
+ (let x-loop ((nx 0))
+ (if (fix:< nx wid)
+ (begin
+ (floating-vector-set! new-yth-row nx
+ (floating-vector-ref yth-row
+ (->discrete-x (/ nx xsf))))
+ (x-loop (fix:+ nx 1)))))))
+ (y-loop (fix:+ ny 1) y-index))))
+ (picture-set-data! new-pic new-data)
+ new-pic))
+
+(define (picture-rotate pic angle)
+ (define (rotate-pt-by theta)
+ (lambda (x y)
+ (let ((c (cos theta)) (s (sin theta)))
+ (make-pt (- (* c x) (* s y))
+ (+ (* s x) (* c y))))))
+
+ (define (close-enough? a b)
+ (fix:= (round->exact a) (round->exact b)))
+
+ (let* ((wid (picture-width pic))
+ (hgt (picture-height pic))
+ (data (picture-data pic))
+ (pic-min (picture-min pic))
+ (lf (lo-bound wid))
+ (rt (fix:- (up-bound wid) 1))
+ (dn (lo-bound hgt))
+ (up (fix:- (up-bound hgt) 1))
+ (rotate-by-angle (rotate-pt-by angle))
+ (rotate-by-neg-angle (rotate-pt-by (- angle)))
+ (ll (rotate-by-angle lf dn)) ;rotate each
+ (lr (rotate-by-angle rt dn)) ;corner
+ (ul (rotate-by-angle lf up)) ;of the
+ (ur (rotate-by-angle rt up)) ;picture
+ (lx (min (xcor ll) (xcor lr) (xcor ul) (xcor ur))) ;compute
+ (ly (min (ycor ll) (ycor lr) (ycor ul) (ycor ur))) ;extreme
+ (ux (max (xcor ll) (xcor lr) (xcor ul) (xcor ur))) ;coordinate
+ (uy (max (ycor ll) (ycor lr) (ycor ul) (ycor ur))) ;values
+ (new-wid (round->exact (1+ (- ux lx))))
+ (new-hgt (round->exact (1+ (- uy ly))))
+ (nx-max (fix:- new-wid 1))
+ (ny-max (fix:- new-hgt 1))
+ (new-lf (lo-bound new-wid))
+ (new-dn (lo-bound new-hgt))
+ (new-pic (make-picture new-wid new-hgt))
+ (new-data (picture-data new-pic)))
+ ;; Special cases are rotations of 90 degrees (both directions) and 180
+ ;; degrees.
+
+ (cond ((and (close-enough? (xcor ur) ux) ; check for
+ (close-enough? (ycor ur) uy)) ; 0 degrees
+ (set! new-data (make-initialized-vector
+ new-hgt
+ (lambda (n)
+ (floating-vector-copy
+ (floating-vector-ref data n))))))
+
+ ((and (close-enough? (xcor ur) lx) ; check for
+ (close-enough? (ycor ur) uy)) ; 90 degrees anti-clockwise
+ (let y-loop ((ny 0))
+ (if (fix:< ny new-hgt)
+ (let ((yth-row (floating-vector-ref new-data ny)))
+ (let x-loop ((nx 0))
+ (if (fix:< nx new-wid)
+ (begin
+ (floating-vector-set! yth-row nx
+ (floating-vector-ref
+ (floating-vector-ref
+ data (fix:- nx-max nx))
+ ny))
+ (x-loop (fix:+ nx 1)))
+ (y-loop (fix:+ ny 1))))))))
+
+ ((and (close-enough? (xcor ur) ux) ; check for
+ (close-enough? (ycor ur) ly)) ; 90 degrees clockwise
+ (let y-loop ((ny 0))
+ (if (fix:< ny new-hgt)
+ (let ((yth-row (floating-vector-ref new-data ny)))
+ (let x-loop ((nx 0))
+ (if (fix:< nx new-wid)
+ (begin
+ (floating-vector-set! yth-row nx
+ (floating-vector-ref
+ (floating-vector-ref data nx)
+ (fix:- ny-max ny)))
+ (x-loop (fix:+ nx 1)))
+ (y-loop (fix:+ ny 1))))))))
+
+ ((and (close-enough? (xcor ur) lx) ; check for
+ (close-enough? (ycor ur) ly)) ; 180 degrees
+ (let y-loop ((ny 0))
+ (if (fix:< ny new-hgt)
+ (begin
+ (floating-vector-set! new-data ny
+ (list->vector
+ (reverse
+ (vector->list
+ (floating-vector-ref data
+ (fix:- ny-max ny))))))
+ (y-loop (fix:+ ny 1))))))
+
+ (else
+ (let* ((rot-bot-lef (rotate-by-neg-angle new-lf new-dn))
+ (x-start (exact->inexact
+ (- (xcor rot-bot-lef) lf))) ; in "vector
+ (y-start (exact->inexact
+ (- (ycor rot-bot-lef) dn))) ; coordinates"
+ (c (cos angle))
+ (s (sin angle)))
+ (let y-loop ((ny 0) (outer-x x-start) (outer-y y-start))
+ (if (fix:< ny new-hgt)
+ (let ((nyth-row (floating-vector-ref new-data ny)))
+ (let x-loop ((nx 0) (inner-x outer-x) (inner-y outer-y))
+ (if (fix:< nx new-wid)
+ (let ((x (round->exact inner-x))
+ (y (round->exact inner-y)))
+ (floating-vector-set! nyth-row nx
+ (if (in-rect? x y wid hgt)
+ (floating-vector-ref
+ (floating-vector-ref data y) x)
+ pic-min))
+ (x-loop (fix:+ nx 1)
+ (flo:+ inner-x c) (flo:- inner-y s)))
+ (y-loop (fix:+ ny 1)
+ (flo:+ outer-x s)
+ (flo:+ outer-y c))))))))))
+ (picture-set-data! new-pic new-data)
+ new-pic))
+
+(define (picture-v-reflect pic)
+ (let* ((wid (picture-width pic))
+ (hgt (picture-height pic))
+ (data (picture-data pic))
+ (new-pic (make-picture wid hgt))
+ (new-data (picture-data new-pic))
+ (y-max (fix:- hgt 1)))
+ (let y-loop ((y 0))
+ (if (fix:< y hgt)
+ (begin
+ (floating-vector-set! new-data y
+ (floating-vector-copy
+ (floating-vector-ref data (fix:- y-max y))))
+ (y-loop (fix:+ y 1)))))
+ (picture-set-data! new-pic new-data)
+ new-pic))
+
+(define (picture-h-reflect pic)
+ (let* ((wid (picture-width pic))
+ (hgt (picture-height pic))
+ (data (picture-data pic))
+ (new-pic (make-picture wid hgt))
+ (new-data (picture-data new-pic)))
+ (let y-loop ((y 0))
+ (if (fix:< y hgt)
+ (begin
+ (floating-vector-set! new-data y
+ (list->vector
+ (reverse
+ (vector->list (floating-vector-ref data y)))))
+ (y-loop (fix:+ y 1)))))
+ (picture-set-data! new-pic new-data)
+ new-pic))
+
--- /dev/null
+;; Procedures to read a file in raw pgm format into a picture
+
+(declare (usual-integrations))
+
+(define (pgm-file->picture filename)
+ (let* ((path-name (->pathname filename))
+ (file-name (if (pathname-type path-name)
+ path-name
+ (if (file-exists? path-name)
+ path-name
+ (pathname-new-type path-name "pgm")))))
+
+ (call-with-input-file file-name (lambda (port)
+ (get-body port (get-header port))))))
+
+(define (get-line port result) ; read a line of data
+ (let ((c (read-char port)))
+ (cond ((eof-object? c) (reverse result))
+ ((eq? c #\Linefeed)
+ (let ((res (reverse result)))
+ (if (eq? (car res) #\#) ; ignore comments
+ (get-line port '())
+ res)))
+ (else (get-line port (cons c result))))))
+
+(define (get-header port)
+ (let* ((type (list->string (get-line port '())))
+ (dims (list->string (get-line port '())))
+ (no-of-greys (string->number
+ (list->string (get-line port '()))))
+ (spc-index (string-find-next-char dims #\space))
+ (length (string->number
+ (string-head dims spc-index)))
+ (width (string->number
+ (string-tail dims (1+ spc-index)))))
+ (if (not (equal? type "P5")) ; P5 is the magic number for raw PGM format
+ (error "Unrecognized format. (Convert to raw PGM) -- PICTURE-READ")
+ (vector type length width no-of-greys))))
+
+(define (get-body port attributes)
+ (let* ((length (vector-ref attributes 1))
+ (width (vector-ref attributes 2))
+ (max-grey (vector-ref attributes 3))
+ (pic (make-picture length width))
+ (data (make-initialized-vector
+ width
+ (lambda (index)
+ index ; ignored
+ (make-floating-vector length 0.))))) ;initialize to blank
+
+ (side-effecting-iter
+ width
+ (lambda (n)
+ (let ((nth-row (floating-vector-ref data (- width n 1))))
+ (side-effecting-iter
+ length
+ (lambda (m)
+ (floating-vector-set! nth-row m
+ (exact->inexact (char->ascii (read-char port)))))))))
+ (picture-set-data! pic data)
+;; (%picture-set-min! pic 0.) ; set min, max of picture according to
+;; (%picture-set-max! pic (exact->inexact max-grey)) ; information in file
+ pic))
+
+;;; Procedure to read in a picture that was previously saved using
+;;; picture-write.
+
+(define (picture-read filename)
+ (let* ((path-name (->pathname filename))
+ (pic-mimic (fasload (if (pathname-type path-name)
+ path-name
+ (if (file-exists? path-name)
+ path-name
+ (pathname-new-type path-name "pic"))))))
+ (if (not (record? pic-mimic))
+ (error "Object loaded is not a picture -- PICTURE-READ"))
+
+ (define mimic-type (record-type-descriptor pic-mimic))
+
+ (if (not (equal? (record-type-field-names mimic-type)
+ (record-type-field-names picture-type)))
+ (error "Object loaded is not a picture -- PICTURE-READ"))
+
+ (define mimic-width (record-accessor mimic-type 'width))
+ (define mimic-height (record-accessor mimic-type 'height))
+ (define mimic-data (record-accessor mimic-type 'data))
+ (define mimic-min (record-accessor mimic-type 'min))
+ (define mimic-max (record-accessor mimic-type 'max))
+
+ (define new-pic (make-picture (mimic-width pic-mimic)
+ (mimic-height pic-mimic)))
+ (picture-set-data! new-pic (mimic-data pic-mimic))
+ (%picture-set-min! new-pic (mimic-min pic-mimic))
+ (%picture-set-max! new-pic (mimic-max pic-mimic))
+ new-pic))
+
--- /dev/null
+;;; Representation of pictures using records
+
+(declare (usual-integrations))
+
+(define picture-type (make-record-type
+ 'picture
+ '(width
+ height
+ data
+ min
+ max
+ image)))
+
+(define %make-picture (record-constructor picture-type '(width height)))
+
+(define %picture-min (record-accessor picture-type 'min))
+(define %picture-max (record-accessor picture-type 'max))
+(define %picture-set-data! (record-updater picture-type 'data))
+(define %picture-set-image! (record-updater picture-type 'image))
+(define %picture-set-min! (record-updater picture-type 'min))
+(define %picture-set-max! (record-updater picture-type 'max))
+
+(define (make-picture width height #!optional initial-val)
+ (let ((pic (%make-picture width height))
+ (initial-val (if (default-object? initial-val)
+ 0.
+ (exact->inexact initial-val))))
+ (%picture-set-min! pic initial-val)
+ (%picture-set-max! pic initial-val)
+ (%picture-set-data! pic
+ (make-initialized-vector
+ height
+ (lambda (n)
+ n ; ignored
+ (make-floating-vector width initial-val))))
+ (%picture-set-image! pic #f)
+ pic))
+
+(define picture? (record-predicate picture-type))
+
+(define picture-width
+ (record-accessor picture-type 'width))
+
+(define picture-height
+ (record-accessor picture-type 'height))
+
+(define picture-data
+ (record-accessor picture-type 'data))
+
+(define picture-image
+ (record-accessor picture-type 'image))
+
+(define (picture-set-image! picture image)
+ (let ((img (picture-image picture)))
+ (if (x-image? img)
+ (x-image/destroy img))
+ (%picture-set-image! picture image)))
+
+(define (picture-min picture)
+ (let ((pic-min (%picture-min picture)))
+ (if (not pic-min)
+ (begin (find-min-max picture)
+ (%picture-min picture))
+ pic-min)))
+
+(define (picture-max picture)
+ (let ((pic-max (%picture-max picture)))
+ (if (not pic-max)
+ (begin (find-min-max picture)
+ (%picture-max picture))
+ pic-max)))
+
+(define (make-picture-referencer bad-type-predicate bad-range-signal)
+ (lambda (picture x y)
+ (cond ((bad-type-predicate x)
+ (error:wrong-type-argument x "picture X coordinate" 'PICTURE-REF))
+ ((bad-type-predicate y)
+ (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-REF))
+ ((not (and (fix:>= x 0)
+ (fix:< x (picture-width picture))))
+ (bad-range-signal x 'PICTURE-REF))
+ ((not (and (fix:>= y 0)
+ (fix:< y (picture-height picture))))
+ (bad-range-signal y 'PICTURE-REF))
+ (else
+ (floating-vector-ref
+ (floating-vector-ref (picture-data picture) y) x)))))
+
+(define (make-picture-setter bad-type-predicate bad-range-signal)
+ (lambda (picture x y value)
+ (cond ((bad-type-predicate x)
+ (error:wrong-type-argument x "picture X coordinate" 'PICTURE-SET!))
+ ((bad-type-predicate y)
+ (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-SET!))
+ ((not (and (fix:>= x 0)
+ (fix:< x (picture-width picture))))
+ (bad-range-signal x 'PICTURE-SET!))
+ ((not (and (fix:>= y 0)
+ (fix:< y (picture-height picture))))
+ (bad-range-signal y 'PICTURE-SET!))
+ (else
+ (floating-vector-set! (floating-vector-ref (picture-data picture) y)
+ x (exact->inexact value))
+ (invalidate-cached-values picture)))))
+
+(define picture-ref (make-picture-referencer
+ (lambda (var)
+ (declare (integrate var))
+ (not (fix:fixnum? var)))
+ error:bad-range-argument))
+
+(define no-error-picture-ref (make-picture-referencer
+ (lambda (var)
+ (declare (integrate var))
+ var ;ignored
+ false)
+ (lambda (var proc-name)
+ var proc-name ;ignored
+ false)))
+
+(define picture-set! (make-picture-setter
+ (lambda (var)
+ (declare (integrate var))
+ (not (fix:fixnum? var)))
+ error:bad-range-argument))
+
+(define no-error-picture-set! (make-picture-setter
+ (lambda (var)
+ (declare (integrate var))
+ var ;ignored
+ false)
+ (lambda (var proc-name)
+ var proc-name ;ignored
+ false)))
+
+(define (picture-map! picture fn)
+ (let ((picdata (picture-data picture))
+ (width (picture-width picture))
+ (height (picture-height picture)))
+ (let y-loop ((y 0))
+ (if (< y height)
+ (let ((yth-row (floating-vector-ref picdata y)))
+ (let x-loop ((x 0))
+ (if (< x width)
+ (begin (floating-vector-set! yth-row x
+ (exact->inexact
+ (fn x y)))
+ (x-loop (1+ x)))
+ (y-loop (1+ y))))))
+ (invalidate-cached-values picture))))
+
+(define (picture-set-data! picture data)
+ (%picture-set-data! picture data)
+ (invalidate-cached-values picture))
+
+;;; Note that picture-data and picture-set-data! are both unsafe operations
+;;; in the sense that both of them do not ensure that only floating point
+;;; numbers are ever stored in the picture array.
+
+
+(define (invalidate-cached-values picture)
+ (%picture-set-min! picture #f)
+ (%picture-set-max! picture #f)
+ (let ((img (picture-image picture)))
+ (if (x-image? img)
+ (x-image/destroy img))
+ (%picture-set-image! picture '())))
+
+(define (find-min-max picture)
+ (let* ((picdata (picture-data picture))
+ (width (picture-width picture))
+ (height (picture-height picture))
+ (current-min (floating-vector-ref (floating-vector-ref picdata 0) 0))
+ (current-max current-min))
+ (let y-loop ((y 0))
+ (if (< y height)
+ (let ((yth-row (floating-vector-ref picdata y)))
+ (let x-loop ((x 0))
+ (if (< x width)
+ (let ((v (floating-vector-ref yth-row x)))
+ (set! current-min (min current-min v))
+ (set! current-max (max current-max v))
+ (x-loop (1+ x)))
+ (y-loop (1+ y)))))))
+ (%picture-set-min! picture current-min)
+ (%picture-set-max! picture current-max)))
projects / mit-scheme.git / commitdiff