#| -*-Scheme-*-
-$Id: 6001.sf,v 1.12 2001/12/19 21:47:48 cph Exp $
+$Id: 6001.sf,v 1.13 2001/12/20 03:23:58 cph Exp $
Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
(sf-conditionally "make")
(sf-conditionally "nodefs")
+(sf-conditionally "picture")
(sf-conditionally "pic-reco")
(sf-conditionally "pic-imag")
(sf-conditionally "pic-read")
(sf-conditionally "pic-ops")
(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME))))
- (sf-conditionally "arith")
- (sf-conditionally "picture"))
+ (sf-conditionally "arith"))
(fluid-let ((sf/default-syntax-table (->environment '(EDWIN))))
(sf-conditionally "edextra")
#| -*-Scheme-*-
-$Id: pic-ops.scm,v 1.5 1999/01/02 06:06:43 cph Exp $
+$Id: pic-ops.scm,v 1.6 2001/12/20 03:24:10 cph Exp $
-Copyright (c) 1993, 1999 Massachusetts Institute of Technology
+Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
-\f
+
;;; Operations for manipulating pictures
(declare (usual-integrations))
-
+\f
(define-integrable (in-rect? x y width height)
(and (fix:< -1 x) (fix:< x width) (fix:< -1 y) (fix:< y height)))
(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))
+ (flo:vector-set! new-yth-row (fix:- x lf)
+ (flo:vector-ref p2-yth-row x))
(x-loop (fix:+ x 1)))
(y-loop (fix:+ y 1)))))))
(let y-loop ((y 0))
(if (fix:< y hgt1)
(let* ((p1-yth-row (vector-ref p1-data y))
- (new-yth-row (vector-ref new-data
- (fix:+ y p1y-offset))))
+ (new-yth-row (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))
+ (flo:vector-set! new-yth-row (fix:+ x p1x-offset)
+ (flo:vector-ref p1-yth-row x))
(x-loop (fix:+ x 1)))
(y-loop (fix:+ y 1)))))))
(picture-set-data! new-pic new-data)
(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))
+ (flo:vector-set! p2-yth-row (fix:+ x u)
+ (flo:vector-ref p1-yth-row x))
(x-loop (fix:+ x 1)))
(y-loop (fix:+ y 1))))))
(picture-set-data! pic2 p2-data))
(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)))
+ (flo:vector-set! new-yth-row x
+ (flo: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)
(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
- (vector-ref new-data (fix:- ny 1))))
+ (flo:vector-set! new-data ny
+ (flo:vector-copy
+ (vector-ref new-data (fix:- ny 1))))
(let ((yth-row (vector-ref data y-index))
(new-yth-row (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))))
+ (flo:vector-set!
+ new-yth-row nx
+ (flo: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)
(set! new-data (make-initialized-vector
new-hgt
(lambda (n)
- (floating-vector-copy
+ (flo:vector-copy
(vector-ref data n))))))
((and (close-enough? (xcor ur) lx) ; check for
(let x-loop ((nx 0))
(if (fix:< nx new-wid)
(begin
- (floating-vector-set! yth-row nx
- (floating-vector-ref
- (vector-ref
- data (fix:- nx-max nx))
- ny))
+ (flo:vector-set! yth-row nx
+ (flo:vector-ref
+ (vector-ref
+ data (fix:- nx-max nx))
+ ny))
(x-loop (fix:+ nx 1)))
(y-loop (fix:+ ny 1))))))))
(let x-loop ((nx 0))
(if (fix:< nx new-wid)
(begin
- (floating-vector-set! yth-row nx
- (floating-vector-ref
- (vector-ref data nx)
- (fix:- ny-max ny)))
+ (flo:vector-set! yth-row nx
+ (flo:vector-ref
+ (vector-ref data nx)
+ (fix:- ny-max ny)))
(x-loop (fix:+ nx 1)))
(y-loop (fix:+ ny 1))))))))
(let y-loop ((ny 0))
(if (fix:< ny new-hgt)
(begin
- (floating-vector-set! new-data ny
- (list->vector
- (reverse
- (vector->list
- (vector-ref data
- (fix:- ny-max ny))))))
+ (flo:vector-set! new-data ny
+ (list->vector
+ (reverse
+ (vector->list
+ (vector-ref data
+ (fix:- ny-max ny))))))
(y-loop (fix:+ ny 1))))))
(else
(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
- (vector-ref data y) x)
- pic-min))
+ (flo:vector-set! nyth-row nx
+ (if (in-rect? x y wid hgt)
+ (flo:vector-ref
+ (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)
(if (fix:< y hgt)
(begin
(vector-set! new-data y
- (floating-vector-copy
+ (flo:vector-copy
(vector-ref data (fix:- y-max y))))
(y-loop (fix:+ y 1)))))
(picture-set-data! new-pic new-data)
(if (fix:< y hgt)
(begin
(vector-set! new-data y
- (floating-vector-reverse (vector-ref data y)))
+ (flo:vector-reverse (vector-ref data y)))
(y-loop (fix:+ y 1)))))
(picture-set-data! new-pic new-data)
new-pic))
-(define (floating-vector-reverse vector)
- (let* ((length (floating-vector-length vector))
- (new-vector (floating-vector-cons length))
+(define (flo:vector-reverse vector)
+ (let* ((length (flo:vector-length vector))
+ (new-vector (flo:vector-cons length))
(length-1 (- length 1)))
(do
((i 0 (+ i 1)))
((= i length))
- (floating-vector-set! new-vector i
- (floating-vector-ref vector (- length-1 i))))
+ (flo:vector-set! new-vector i
+ (flo:vector-ref vector (- length-1 i))))
new-vector))
#| -*-Scheme-*-
-$Id: pic-read.scm,v 1.5 1999/01/02 06:06:43 cph Exp $
+$Id: pic-read.scm,v 1.6 2001/12/20 03:24:21 cph Exp $
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Procedures to read a file in raw pgm format into a picture
width
(lambda (index)
index ; ignored
- (make-floating-vector length 0.))))) ;initialize to blank
+ (flo:make-vector length 0.))))) ;initialize to blank
(side-effecting-iter
width
(lambda (n)
(side-effecting-iter
length
(lambda (m)
- (floating-vector-set!
+ (flo:vector-set!
nth-row
m
(exact->inexact (char->ascii (read-char port)))))))))
#| -*-Scheme-*-
-$Id: pic-reco.scm,v 1.7 1999/01/02 06:06:43 cph Exp $
+$Id: pic-reco.scm,v 1.8 2001/12/20 03:24:33 cph Exp $
-Copyright (c) 1993, 1999 Massachusetts Institute of Technology
+Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
\f
;;; Representation of pictures using records
height
(lambda (n)
n ; ignored
- (make-floating-vector width initial-val))))
+ (flo:make-vector width initial-val))))
(%picture-set-image! pic #f)
pic))
(fix:< y (picture-height picture))))
(bad-range-signal y 'PICTURE-REF))
(else
- (floating-vector-ref
+ (flo:vector-ref
(vector-ref (picture-data picture) y) x)))))
(define (make-picture-setter bad-type-predicate bad-range-signal)
(fix:< y (picture-height picture))))
(bad-range-signal y 'PICTURE-SET!))
(else
- (floating-vector-set! (vector-ref (picture-data picture) y)
+ (flo:vector-set! (vector-ref (picture-data picture) y)
x (exact->inexact value))
(invalidate-cached-values picture)))))
(let ((yth-row (vector-ref picdata y)))
(let x-loop ((x 0))
(if (< x width)
- (begin (floating-vector-set! yth-row x
- (exact->inexact
- (fn x y)))
+ (begin (flo:vector-set! yth-row x
+ (exact->inexact (fn x y)))
(x-loop (1+ x)))
(y-loop (1+ y))))))
(invalidate-cached-values picture))))
(let* ((picdata (picture-data picture))
(width (picture-width picture))
(height (picture-height picture))
- (current-min (floating-vector-ref (vector-ref picdata 0) 0))
+ (current-min (flo:vector-ref (vector-ref picdata 0) 0))
(current-max current-min))
(let y-loop ((y 0))
(if (< y height)
(let ((yth-row (vector-ref picdata y)))
(let x-loop ((x 0))
(if (< x width)
- (let ((v (floating-vector-ref yth-row x)))
+ (let ((v (flo:vector-ref yth-row x)))
(set! current-min (min current-min v))
(set! current-max (max current-max v))
(x-loop (1+ x)))
#| -*-Scheme-*-
-$Id: picture.scm,v 1.29 1999/02/16 01:00:07 cph Exp $
+$Id: picture.scm,v 1.30 2001/12/20 03:24:45 cph Exp $
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; 6.001 Images
\f
;;;; Miscellaneous Utilities
-(define-primitives
- floating-vector-ref
- floating-vector-set!
- floating-vector-cons
- floating-vector-length)
-
-(define (make-floating-vector length init)
- (let ((result (floating-vector-cons length)))
+(define (flo:make-vector length init)
+ (let ((result (flo:vector-cons length)))
(if (not (= init 0.))
(do ((i 0 (fix:+ i 1)))
((fix:= i length))
- (floating-vector-set! result i init)))
+ (flo:vector-set! result i init)))
result))
-(define (floating-vector-copy vector)
- (let* ((length (floating-vector-length vector))
- (result (floating-vector-cons length)))
+(define (flo:vector-copy vector)
+ (let* ((length (flo:vector-length vector))
+ (result (flo:vector-cons length)))
(do ((i 0 (fix:+ i 1)))
((fix:= i length))
- (floating-vector-set! result i (floating-vector-ref vector i)))
+ (flo:vector-set! result i (flo:vector-ref vector i)))
result))
(define (side-effecting-iter n proc)
(define (up-bound interval-length)
(floor->exact (1+ (/ interval-length 2))))
-(define (floating-vector->list vector)
- (generate-list (floating-vector-length vector)
+(define (flo:vector->list vector)
+ (generate-list (flo:vector-length vector)
(lambda (i)
- (floating-vector-ref vector i))))
+ (flo:vector-ref vector i))))
(define (generate-list n proc) ; ==> ( (proc 0) (proc 1) ... (proc n-1) )
(let loop ((i (- n 1)) (list '()))
(let x-loop ((x 0))
(if (fix:< x width)
(begin
- (floating-vector-set!
+ (flo:vector-set!
out-yth-row x
(exact->inexact
- (f (floating-vector-ref in-yth-row x))))
+ (f (flo:vector-ref in-yth-row x))))
(x-loop (fix:+ 1 x)))
(y-loop (fix:+ 1 y)))))))))
((null? (cddr pic-list))
(let x-loop ((x 0))
(if (fix:< x width)
(begin
- (floating-vector-set!
+ (flo:vector-set!
out-yth-row x
(exact->inexact
- (f (floating-vector-ref in-yth-row1 x)
- (floating-vector-ref in-yth-row2 x))))
+ (f (flo:vector-ref in-yth-row1 x)
+ (flo:vector-ref in-yth-row2 x))))
(x-loop (fix:+ 1 x)))
(y-loop (fix:+ 1 y)))))))))
(else
(let x-loop ((x 0))
(if (fix:< x width)
(begin
- (floating-vector-set!
+ (flo:vector-set!
out-yth-row x
(exact->inexact
(apply f
(map (lambda (row)
- (floating-vector-ref row x))
+ (flo:vector-ref row x))
in-yth-rows))))
(x-loop (fix:+ 1 x)))
(y-loop (fix:+ 1 y))))))))))
(lambda (x)
(ascii->char
(round->exact (* (- x pmin) scale)))))))
- (floating-vector->list (vector-ref data row)))))
+ (flo:vector->list (vector-ref data row)))))
(begin
(write-string (list->string rowvals) port)
(rowloop (- row 1))))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: win32.pkg,v 1.13 2001/08/18 04:52:11 cph Exp $
+$Id: win32.pkg,v 1.14 2001/12/20 03:27:54 cph Exp $
Copyright (c) 1993-2001 Massachusetts Institute of Technology
(global-definitions "../runtime/runtime")
(define-package (win32)
- (parent ())
+ (parent (runtime))
(files "winuser"
"wt_user"
"wf_user"
projects / mit-scheme.git / commitdiff