FFT-test.scheme
Copyright Ó 1991 by Xerox Corporation. All rights reserved.
(define (const-list size val)
"makes a list of all the same constant"
(if (zero? size)
'()
(cons val (const-list (- size 1) val))))
(define (vector-compute! vector proc s f0)
"(vector-set! vector f (proc s f)) for f: f0 <= f < (vector-length vector))"
(if (< f0 (vector-length vector))
(begin
(vector-set! vector f0 (proc s f0))
(vector-compute! vector proc s (+ f0 1)))))
(define (make-image size)
"An image is a list of complex-vectors, to form a square 2-d array"
(map make-complex-vector
(const-list size size)
(const-list size 0)))
(define (image-size image)
(vector-length (car image)))
(define (image-compute! image proc s0 f0)
"For ray-tracing"
(if (pair? image)
(begin
(vector-compute! (car image)
proc s0 f0)
(image-compute! (cdr image)
(define co (make-gray-linear-color-operator 255 0 '())) ; A color operator
(define (drawpm pm i)
"Draws layer i of a pixelmap"
(draw-colored-texture (pixelmap->pixel-array (pixelmap-extract pm i)
(define (sphere x y)
"For ray-tracing a sphere"
(if (>= (+ (* x x)
0
(let* ((z (sqrt (- 1
(max 0.02 dot))))
(define zl
(- 1
(+ (* xl xl)
(* yl yl))))
(define (rescale fn pixels border)
"takes a function expecting x y in [-1..1] and makes a function expecting s f in [0..pixels-1]"
(let* ((w (/ pixels 2))
(scale (/ 1.0 (- w border))))
(define (top-sphere size)
(define image (make-image size))
(drawpm (pixelmap-from-complex-image image)
0)
image)
(define rgb-co (make-rgb-color-operator 1000))
(define (make-rgb-color r g b)
(make-constant-color
(list->vector
(map
(lambda (x) (inexact->exact (round (* x 1000))))
(list r g b)))
rgb-co))
(define (make-hsv-color hue saturation value)
(if (or (= saturation 0)
(= value 0))
(make-rgb-color value value value)
(let* ((ihue (modulo (floor (* hue 6))
6))
(fhue (- (* hue 6)
ihue))
(m (* value (- 1 saturation)))
(n (* value (- 1 (* saturation fhue))))
(k (* value (- 1 (* saturation (- 1 fhue))))))
(case ihue
((0)
(make-rgb-color value k m))
((1)
(make-rgb-color n value m))
((2)
(make-rgb-color m value k))
((3)
(make-rgb-color m n value))
((4)
(make-rgb-color k m value))
((5)
(make-rgb-color value m n))))))
(define hue-co
(delay (make-map-color-operator (list->vector (map (lambda (i)
(make-hsv-color (/ i 256)
1 1))
(interval 0 255))))))
(define (tile pm k)
(do-save (lambda ()
(set-colored-texture (pixelmap->pixel-array (pixelmap-extract pm
k)
#t)
(make-scale 2)
(if (= k 0) co (force hue-co)))
(mask-rectangle 0 0 2000 2000))))
(define (make-text-pm string s-size f-size) (let* ((pm (make-pixelmap s-size f-size (quote (1)))) (ctx (make-bitmap-context pm))) (set-xy 2 (/ s-size 2) ctx) (set-font (find-font "xerox/xc1-2-2/classic" (- s-size 2)) ctx) (show-string string ctx) pm))
(define (make-box-pm s-size f-size) (let* ((pm (make-pixelmap s-size f-size (quote (1)))) (ctx (make-bitmap-context pm))) (mask-box 0 0 4 4 ctx) pm))
(define (fft image inverse) (let ((i1 (transpose image))) (f-f-transform-rows! i1 inverse) (let ((i2 (transpose i1))) (f-f-transform-rows! i2 inverse) (destroy! i1) i2)))
(define (destroy! lst) (if (pair? lst) (let ((d (cdr lst))) (set-car! lst #f) (set-cdr! lst (quote ())) (destroy! d))))
(define w '())
(define imagepm #f)
(define image #f)
(define t1 #f)
(define freqpm #f)
(define bif #f)
(define initial-image #f)
(define initial-image-f #f)
(define (text-setup string s-size f-size)
(set! t1 (make-text-pm string s-size f-size))
(set! image (complex-image-from-pixelmap t1 0))
(set! bif (fft (complex-image-from-pixelmap (make-box-pm s-size f-size) 0) #f))
'(t1 image bif)
)
(define (setup image)
(set! initial-image image)
(set! image (fft image #f))
(set! initial-image-f image)
(for-each (lambda (v w) (complex-vector-transfer-magnitude! v w 0 (vector-length v))) image bif)
(set! image (fft image #t))
(set! w (list image))
(drawpm (pixelmap-from-complex-image (car w)) 0)
)
(define (improve image)
(set! image (fft image #f))
(set! freqpm (pixelmap-from-complex-image image))
(for-each (lambda (v w) (complex-vector-transfer-angle! v w 0 (vector-length v))) image initial-image-f)
(set! image (fft image #t))
(for-each (lambda (v) (complex-vector-clip! v 0.01)) image)
image
)
(define (step)
(set! w (cons (improve (car w)) w))
(set! imagepm (pixelmap-from-complex-image (car w)))
(tile imagepm 0)
)