/examples/perlin-noise/lib/source.scm

  1;;               Scheme library used for Assignement #1
  2;;                      for the course comp-521
  3;;
  4;;                        by David St-Hilaire
  5;;                            winter 2008
  6;;
  7;;
  8;; This library source file contains various well known and less well
  9;; known functions used in functionnal programming. Authors referrence
 10;; will not be cited but most of the code here was not invented by the
 11;; author of this file. Also, these functions will not be documented
 12;; because names and uses of these are trivial for any functionnal
 13;; programmer.
 14
 15
 16; Compiler declarations for optimizations
 17;; (declare (standard-bindings)
 18;;          (extended-bindings)
 19;;          (block)
 20;;          (not safe)
 21;;          (fixnum))
 22
 23
 24;;;;;;;;;;;;;;;;;;;;;;; list operations ;;;;;;;;;;;;;;;;;;;;;;;;;;
 25
 26(define (list-remove comparator el list)
 27  (let loop ((list list)
 28             (acc '()))
 29    (if (not (pair? list))
 30        (reverse acc)
 31        (if (comparator (car list) el)
 32            (loop (cdr list) acc)
 33            (loop (cdr list) (cons (car list) acc))))))
 34
 35(define (filter pred list)
 36  (cond
 37   ((not (pair? list)) '())
 38   ((pred (car list)) (cons (car list) (filter pred (cdr list))))
 39   (else (filter pred (cdr list)))))
 40
 41(define (exists pred list)
 42  (let loop ((list list) (acc #f))
 43    (if (not (pair? list))
 44        acc
 45        (loop (cdr list) (or acc (pred (car list)))))))
 46
 47(define (forall pred list)
 48  (let loop ((list list) (acc #t))
 49    (if (not (pair? list))
 50        acc
 51        (loop (cdr list) (and acc (pred (car list)))))))
 52
 53(define (fold-l f acc list)
 54  (if (not (pair? list))
 55      acc
 56      (fold-l f (f acc (car list)) (cdr list))))
 57
 58(define (cleanse lst)
 59  (cond
 60   ((not (pair? lst)) '())
 61   ((null? (car lst)) (cleanse (cdr lst)))
 62   (else (cons (car lst) (cleanse (cdr lst))))))
 63
 64(define (union l1 l2)
 65  (let loop ((l1 l1) (acc l2))
 66    (if (not (pair? l1))
 67        acc
 68        (if (member (car l1) l2)
 69            (loop (cdr l1) acc)
 70            (loop (cdr l1) (cons (car l1) acc))))))
 71
 72
 73;; (define-macro (extremum-fonction comparator opposite-extremum)
 74;;   (let ((lst-sym (gensym 'lst-sym))
 75;;         (extremum-sym (gensym 'extremum-sym))
 76;;         (loop-sym (gensym 'loop-sym)))
 77;;     `(lambda (,lst-sym) 
 78;;        (let ,loop-sym ((,lst-sym ,lst-sym)
 79;;                        (,extremum-sym ,opposite-extremum))
 80;;             (cond
 81;;              ((not (pair? ,lst-sym)) ,extremum-sym)
 82;;              ((,comparator (car ,lst-sym) ,extremum-sym)
 83;;               (,loop-sym (cdr ,lst-sym) (car ,lst-sym)))
 84;;              (else
 85;;               (,loop-sym (cdr ,lst-sym) ,extremum-sym)))))))
 86
 87(define-syntax extremum-fonction
 88  (syntax-rules ()
 89    ((extremum-fonction comparator opposite-extremum)
 90     (lambda (lst)
 91       (let loop ((lst lst)
 92                  (extremum opposite-extremum))
 93         (cond ((not (pair? lst)) extremum)
 94               ((comparator (car lst) extremum)
 95                (loop (cdr lst) (car lst)))
 96               (else
 97                (loop (cdr lst) extremum))))))))
 98
 99;;;;;;;;;;;;;;;;;;;;;;;;;;;; Math stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100
101(define maximum (extremum-fonction > -inf.0))
102(define minimum (extremum-fonction < +inf.0))
103
104(define (average sample)
105  (/ (apply + sample) (length sample)))
106
107(define (variance sample)
108  (define mean (average sample))
109  (define N (length sample))
110  (/ (fold-l (lambda (acc n) (+ (expt (- n mean) 2) acc))
111             0
112             sample)
113     N))
114
115(define (standard-deviation sample) (sqrt (variance sample)))
116
117(define (complex-conjugate z)
118  (make-rectangular (real-part z) (- (imag-part z))))
119
120(define pi (* 2 (asin 1)))
121
122;;;;;;;;;;;;;;;;;;;;;; Boolean operation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123
124;; (define-macro (xor b1 b2) `(not (eq? ,b1 ,b2)))
125
126(define-syntax xor
127  (syntax-rules ()
128    ((xor b1 b2)
129     (not (eq? b1 b2)))))
130
131;;;;;;;;;;;;;;;;;;;;;;;; Simple macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
132
133;; (define-macro (for var init-val condition true . false)
134;;   (let ((loop (gensym)))
135;;     `(let ,loop ((,var ,init-val))
136;;           (if ,condition
137;;               (begin ,true (,loop (+ ,var 1)))
138;;               ,(if (not (null? false))
139;;                    false)))))
140
141(define-syntax for
142  (syntax-rules ()
143
144    ((for var init-val condition true false)
145     (let loop ((var init-val))
146       (if condition
147           (begin
148             true
149             (loop (+ var 1)))
150           (begin
151             false))))
152
153    ((for var init-val condition true)
154     (for var init-val condition true #f))
155
156    ))
157
158;; (define-macro (make-vector2d height width . init-val)
159;;   (let ((vector-sym (gensym))
160;;         (row-sym (gensym)))
161;;     `(let ((,vector-sym (make-vector ,height #f)))
162;;        (for ,row-sym 0 (< ,row-sym ,height)
163;;             (vector-set! ,vector-sym ,row-sym
164;;                          (make-vector ,width ,(if (pair? init-val)
165;;                                                   (car init-val)
166;;                                                   #f))))
167;;        ,vector-sym)))
168
169(define-syntax make-vector2d
170  (syntax-rules ()
171
172    ((make-vector2d height width init-val)
173     (let ((vector (make-vector height #f)))
174       (for row 0 (< row height)
175            (vector-set! vector row
176                         (make-vector width init-val)))
177       vector))
178
179    ((make-vector-2d height width)
180     (make-vector-2d height width #f))
181
182    ))
183
184;; (define-macro (vector2d-ref vector row col)
185;;   `(vector-ref (vector-ref ,vector ,row) ,col))
186
187(define-syntax vector2d-ref
188  (syntax-rules ()
189    ((vector2d-ref vector row col)
190     (vector-ref (vector-ref vector row) col))))
191
192;; (define-macro (vector2d-set! vector row col val)
193;;   `(vector-set! (vector-ref ,vector ,row) ,col ,val))
194
195(define-syntax vector2d-set!
196  (syntax-rules ()
197    ((vector2d-set! vector row col val)
198     (vector-set! (vector-ref vector row) col val))))
199
200;; (define-macro (make-vector3d i-length j-length k-length . init-val)
201;;   (let ((vector-sym (gensym))
202;;         (i-sym (gensym))
203;;         (j-sym (gensym)))
204;;     `(let ((,vector-sym (make-vector2d ,i-length ,j-length #f)))
205;;        (for ,i-sym 0 (< ,i-sym ,i-length)
206;;             (for ,j-sym 0 (< ,j-sym ,j-length)
207;;                  (vector2d-set! ,vector-sym ,i-sym ,j-sym
208;;                                 (make-vector ,k-length ,(if (pair? init-val)
209;;                                                             (car init-val)
210;;                                                             #f)))))
211;;        ,vector-sym)))
212
213(define-syntax make-vector3d
214  (syntax-rules ()
215    ((make-vector3d i-length j-length k-length init-val)
216     (let ((vector (make-vector2d i-length j-length #f)))
217       (for i 0 (< i i-length)
218            (for j 0 (< j j-length)
219                 (vector2d-set! vector i j (make-vector k-length init-val))))
220       vector))
221
222    ((make-vector3d i-length j-length k-length)
223     (make-vector3d i-length j-length k-length #f))))
224
225;; (define-macro (vector3d-ref vector i j k)
226;;   `(vector-ref (vector2d-ref ,vector ,i ,j) ,k))
227
228(define-syntax vector3d-ref
229  (syntax-rules ()
230    ((vector3d-ref vector i j k)
231     (vector-ref (vector2d-ref vector i j) k))))
232
233;; (define-macro (vector3d-set! vector i j k val)
234;;   `(vector-set! (vector2d-ref ,vector ,i ,j) ,k ,val))
235
236(define-syntax vector3d-set!
237  (syntax-rules ()
238    ((vector3d-set! vector i j k val)
239     (vector-set! (vector2d-ref vector i j) k val))))
240
241; Randomize current mrg's seed
242;; (random-source-randomize! default-random-source)