(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)
             proc
          (+ s0 1)
       f0))))

(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)
                                          #t)
                co))

(define (sphere x y)
"For ray-tracing a sphere"
(if (>= (+ (* x x)
        (* y y))
  1.0)
0
(let* ((z (sqrt (- 1
                (+ (* x x)
                (* y y)))))
 (dot (+ (* x xl)
      (* y yl)
   (* z zl))))
(max 0.02 dot))))

(define xl 0.2)

(define yl 0.3)

(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))))
(lambda (s f)
(fn (* (- f w)
    scale)
 (* (- w s)
 scale)))))

(define (top-sphere size)
(define image (make-image size))
(image-compute! image
             (rescale sphere
                   (image-size image)
                2)
    0 0)
(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)
)
    V  
FFT-test.scheme
Copyright س 1991 by Xerox Corporation.  All rights reserved.

 ‌ت>  •NewlineDelimiter
–(cedarcode) style™ ™Jڑœ
دeœ1™<—J™ کJک'کJکJک(—Jک —ک*JکLک!کJک#Jک+——Jک —کJکCکJکJک—Jک —کJکJک —ک)JککککJک—کککJک—————Jک —کJJک —کJککDک-Jک——Jک —کJکککJک—JکککJکککJک———Jک——Jک —کJک —کJک —ک
ککJک——Jک —ک"Jک_کJک!ککJک
کJک————Jک —کJک ککک%کJک————ک+Jک—JکJک —ک.Jک —ککککJک0Jک——JکJک ——ک-کJکJک"ک&ککJک—JکJک(Jک/—ک
کJکJکJکJکJکJکJکJکJکJکJک ————Jک —کک>کEک>Jک8———Jک —کککIکFک2ک#Jک1—Jک!—————Jک JڑœûکûJڑœ•ک•JڑœھکھJڑœwکwJک JکJڑœکJڑœکJڑœکJڑœکJڑœکJڑœکڑœکJک Jک —ڑœ)ک)Jڑœ-ک-Jڑœ/ک/JڑœOکOJڑœکJڑœکJک —کIdefaultڑœکKڑœکKڑœکKڑœ`ک`KڑœکJڑœکJک0JکJک —کKڑœکJڑœ1ک1KڑœhکhKڑœکKڑœ;ک;JکJک—Jک کJک#Jڑœ4ک4JڑœکJک—— …—    ن  x  