PageRenderTime 33ms CodeModel.GetById 9ms app.highlight 18ms RepoModel.GetById 2ms app.codeStats 0ms

/trunk/Examples/guile/matrix/matrix.scm

#
Lisp | 210 lines | 142 code | 34 blank | 34 comment | 0 complexity | 6a02dced5b9bcb328d4c1c8050dda5e2 MD5 | raw file
  1#!./matrix \
  2-e do-test -s
  3!#
  4;;; Authors: David Beazley <beazley@cs.uchicago.edu>, 1999
  5;;;          Martin Froehlich <MartinFroehlich@ACM.org>, 2000
  6;;;
  7;;; PURPOSE OF THIS FILE: This file is an example for how to use the guile
  8;;;   scripting options with a little more than trivial script. Example
  9;;;   derived from David Beazley's matrix evaluation example.  David
 10;;;   Beazley's annotation: >>Guile script for testing out matrix
 11;;;   operations. Disclaimer : I'm not a very good scheme
 12;;;   programmer<<. Martin Froehlich's annotation: >>I'm not a very good
 13;;;   scheme programmer, too<<.
 14;;;
 15;;; Explanation: The three lines at the beginning of this script are
 16;;; telling the kernel to load the enhanced guile interpreter named
 17;;; "matrix"; to execute the function "do-test" (-e option) after loading
 18;;; this script (-s option). There are a lot more options wich allow for
 19;;; even finer tuning. SEE ALSO: Section "Guile Scripts" in the "Guile
 20;;; reference manual -- Part I: Preliminaries".
 21;;;
 22;;;
 23;;; This program is distributed in the hope that it will be useful, but
 24;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 25;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 26
 27;;; Create a zero matrix
 28
 29(define (zero M)
 30  (define (zero-loop M i j)
 31    (if (< i 4)
 32	(if (< j 4) (begin
 33		      (set-m M i j 0.0)
 34		      (zero-loop M i (+ j 1)))
 35	    (zero-loop M (+ i 1) 0))))
 36  (zero-loop M 0 0))
 37
 38;;; Create an identity matrix
 39
 40(define (identity M)
 41  (define (iloop M i)
 42    (if (< i 4) (begin
 43		  (set-m M i i 1.0)
 44		  (iloop M (+ i 1)))))
 45  (zero M)
 46  (iloop M 0))
 47
 48;;; Rotate around x axis
 49
 50(define (rotx M r)
 51  (define temp (new-matrix))
 52  (define rd (/ (* r 3.14159) 180.0))
 53  (zero temp)
 54  (set-m temp 0 0 1.0)
 55  (set-m temp 1 1 (cos rd))
 56  (set-m temp 1 2 (- 0 (sin rd)))
 57  (set-m temp 2 1 (sin rd))
 58  (set-m temp 2 2 (cos rd))
 59  (set-m temp 3 3 1.0)
 60  (mat-mult M temp M)
 61  (destroy-matrix temp))
 62
 63;;; Rotate around y axis
 64
 65(define (roty M r)
 66  (define temp (new-matrix))
 67  (define rd (/ (* r 3.14159) 180.0))
 68  (zero temp)
 69  (set-m temp 1 1 1.0)
 70  (set-m temp 0 0 (cos rd))
 71  (set-m temp 0 2 (sin rd))
 72  (set-m temp 2 0 (- 0 (sin rd)))
 73  (set-m temp 2 2 (cos rd))
 74  (set-m temp 3 3 1.0)
 75  (mat-mult M temp M)
 76  (destroy-matrix temp))
 77
 78;;; Rotate around z axis
 79
 80(define (rotz M r)
 81  (define temp (new-matrix))
 82  (define rd (/ (* r 3.14159) 180.0))
 83  (zero temp)
 84  (set-m temp 0 0 (cos rd))
 85  (set-m temp 0 1 (- 0 (sin rd)))
 86  (set-m temp 1 0 (sin rd))
 87  (set-m temp 1 1 (cos rd))
 88  (set-m temp 2 2 1.0)
 89  (set-m temp 3 3 1.0)
 90  (mat-mult M temp M)
 91  (destroy-matrix temp))
 92
 93;;; Scale a matrix
 94
 95(define (scale M s)
 96  (define temp (new-matrix))
 97  (define (sloop m i s)
 98    (if (< i 4) (begin
 99		  (set-m m i i s)
100		  (sloop m (+ i 1) s))))
101  (zero temp)
102  (sloop temp 0 s)
103  (mat-mult M temp M)
104  (destroy-matrix temp))
105
106;;; Make a matrix with random elements
107
108(define (randmat M)
109  (define (rand-loop M i j)
110    (if (< i 4)
111	(if (< j 4)
112            (begin
113              (set-m M i j (drand48))
114              (rand-loop M i (+ j 1)))
115	    (rand-loop M (+ i 1) 0))))
116  (rand-loop M 0 0))
117
118;;; stray definitions collected here
119
120(define (rot-test M v t i)
121  (if (< i 360) (begin
122		  (rotx M 1)
123		  (rotz M -0.5)
124		  (transform M v t)
125		  (rot-test M v t (+ i 1)))))
126
127(define (create-matrix)		; Create some matrices
128  (let loop ((i 0) (result '()))
129    (if (< i 200)
130	(loop (+ i 1) (cons (new-matrix) result))
131	result)))
132
133(define (add-mat M ML)
134  (define (add-two m1 m2 i j)
135    (if (< i 4)
136	(if (< j 4)
137            (begin
138              (set-m m1 i j (+ (get-m m1 i j) (get-m m2 i j)))
139              (add-two m1 m2 i (+ j 1)))
140	    (add-two m1 m2 (+ i 1) 0))))
141  (if (null? ML) () (begin
142		      (add-two M (car ML) 0 0)
143		      (add-mat M (cdr ML)))))
144
145(define (cleanup ML)
146  (if (null? ML) () (begin
147		      (destroy-matrix (car ML))
148		      (cleanup (cdr ML)))))
149
150(define (make-random ML)		; Put random values in them
151  (if (null? ML) () (begin
152		      (randmat (car ML))
153		      (make-random (cdr ML)))))
154
155(define (mul-mat m ML)
156  (if (null? ML) () (begin
157		      (mat-mult m (car ML) m)
158		      (mul-mat m (cdr ML)))))
159
160;;; Now we'll hammer on things a little bit just to make
161;;; sure everything works.
162(define M1 (new-matrix))		; a matrix
163(define v (createv 1 2 3 4))		; a vector
164(define t (createv 0 0 0 0))		; the zero-vector
165(define M-list (create-matrix))		; get list of marices
166(define M (new-matrix))			; yet another matrix
167
168(display "variables defined\n")
169(define (do-test x)
170  (display "Testing matrix program...\n")
171
172  (identity M1)
173  (print-matrix M1)
174  (display "Rotate-x 45 degrees\n")
175  (rotx M1 45)
176  (print-matrix M1)
177  (display "Rotate y 30 degrees\n")
178  (roty M1 30)
179  (print-matrix M1)
180  (display "Rotate z 15 degrees\n")
181  (rotz M1 15)
182  (print-matrix M1)
183  (display "Scale 0.5\n")
184  (scale M1 0.5)
185  (print-matrix M1)
186
187  ;; Rotating ...
188  (display "Rotating...\n")
189  (rot-test M1 v t 0)
190  (printv t)
191
192  (make-random M-list)
193
194  (zero M1)
195
196  (display "Adding them together (in Guile)\n")
197
198  (add-mat M1 M-list)
199  (print-matrix M1)
200
201  (display "Doing 200 multiplications (mostly in C)\n")
202  (randmat M)
203
204  (mul-mat M M-list)
205
206  (display "Cleaning up\n")
207
208  (cleanup M-list))
209
210;;; matrix.scm ends here