/examples/perlin-noise/lib/source.scm
Scheme | 242 lines | 119 code | 47 blank | 76 comment | 0 complexity | cd3138030b412fe6abd23da98f42446c MD5 | raw file
Possible License(s): BSD-3-Clause
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)