source: project/release/4/parametric-curve/trunk/parametric-curve.scm @ 30630

Last change on this file since 30630 was 30630, checked in by Ivan Raikov, 7 years ago

parametric-curve: more work on fold routines

File size: 8.1 KB
Line 
1
2;; An implementation of parametric curves.
3;;
4;; This code is inspired by the Haskell rsagl library.
5;;
6;; Copyright 2012-2014 Ivan Raikov and the Okinawa Institute of
7;; Science and Technology.
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23(module parametric-curve
24
25        (
26         parametric-curve?
27         simple-curve linear-curve line-segment
28         map-curve translate-curve scale-curve
29         sample-curve sample-curve*
30         iterate-curve fold-curve bbox-curve
31         arc-length
32         )
33       
34        (import scheme chicken data-structures)
35 
36        (require-library srfi-1 srfi-4 srfi-4-utils extras bvsp-spline)
37
38        (import (only srfi-1 fold every list-tabulate zip concatenate)
39                (only srfi-4 f64vector make-f64vector list->f64vector f64vector->list f64vector-length f64vector-ref f64vector-set!)
40                (only srfi-4-utils f64vector-fold)
41                (only extras fprintf pp)
42                (prefix bvsp-spline bvsp-spline:)
43                )
44
45;; A boundary-value preserving spline
46(define-record-type spline (make-spline n k x y d d2)
47  spline? 
48  (n spline-n)
49  (k spline-k)
50  (x spline-x)
51  (y spline-y)
52  (d spline-d)
53  (d2 spline-d2)
54  )
55
56
57;; A parametric equation with an associated interval and interpolating spline
58(define-record-type peq (make-peq fn xmin xmax ymin ymax spl)
59  peq? 
60  (fn      peq-fn )
61  (xmin    peq-xmin)
62  (xmax    peq-xmax)
63  (ymin    peq-ymin)
64  (ymax    peq-ymax)
65  (spl     peq-spl)
66  )
67
68
69(define-record-printer (peq x out)
70  (fprintf out "#(peq fn=~A xmin=~A xmax=~A ymin=~A ymax=~A spl=~A)"
71           (peq-fn x)
72           (peq-xmin x)
73           (peq-xmax x)
74           (peq-ymin x)
75           (peq-ymax x)
76           (peq-spl x)
77           ))
78
79
80
81;; A N-dimensional parametric curve is a set of N parametric equations.
82(define (parametric-curve? x) (every peq? x))
83
84
85;; Defines a simple parametric equation.
86(define (simple-peq n k fn xmin xmax)
87
88  (if (> xmin xmax)
89
90      (simple-peq n k fn xmax xmin)
91
92      (let ((dx (/ (- xmax xmin) n)))
93
94        (let* ((x (list-tabulate (+ 1 n) (lambda (i) (+ xmin (* i dx)))))
95               (y (map fn x))
96               (ymin (fold min +inf.0 y))
97               (ymax (fold max -inf.0 y))
98               (xv (list->f64vector x))
99               (yv (list->f64vector y))
100               )
101
102          (let ((spl
103                 (let-values (((d d2 constr errc diagn)
104                               (bvsp-spline:compute n k xv yv)))
105                   (if (zero? errc)
106                       (make-spline n k xv yv d d2) 
107                       (error 'simple-peq "unable to compute interpolating spline"))
108                   ))
109                )
110
111              (make-peq fn xmin xmax ymin ymax spl)
112              ))
113          ))
114      )
115
116
117;; Samples a parametric equation at the given point of interest.
118(define (sample-peq c)
119  (let ((s (peq-spl c))
120        (min (peq-xmin c))
121        (max (peq-xmax c)))
122    (lambda (xp)
123      (and (>= xp min) (<= xp max)
124           (let ((v (bvsp-spline:evaluate (spline-n s) (spline-k s) 
125                                          (spline-x s) (spline-y s) 
126                                          (spline-d s) (spline-d2 s) 
127                                          (f64vector xp) 0)))
128             (and v (f64vector-ref v 0)))
129           ))
130    ))
131
132
133;; Samples a parametric equation at the given points of interest.
134(define (sample-peq* c)
135  (let ((s (peq-spl c)))
136    (lambda (xps)
137      (let ((xpsv (if (list? xps) (list->f64vector xps) xps)))
138        (let ((res (bvsp-spline:evaluate (spline-n s) (spline-k s) 
139                                         (spline-x s) (spline-y s) 
140                                         (spline-d s) (spline-d2 s) 
141                                         xpsv 0)))
142          res
143          ))
144      ))
145  )
146
147
148
149;; Samples a parametric equation at regular intervals in the range xmin..xmax inclusive.
150(define (iterate-peq c n)
151  (let* (
152         (f     (sample-peq* c))
153         (xmin  (peq-xmin c))
154         (xmax  (peq-xmax c))
155         (delta (- xmax xmin))
156         (dx    (if (zero? delta) 0
157                    (if (< n 2)
158                        (error 'iterate-peq "number of iterations must be >= 2")
159                        (/ (- xmax xmin) (- n 1)))))
160         )
161    (f (list-tabulate n (lambda (i) (+ xmin (* dx i)))))
162    ))
163
164
165;; Folds a parametric equation at regular intervals in the range xmin..xmax inclusive.
166(define (fold-peq c n f init)
167  (let* (
168         (g     (sample-peq* c))
169         (xmin  (peq-xmin c))
170         (xmax  (peq-xmax c))
171         (delta (- xmax xmin))
172         (dx    (if (zero? delta) 0
173                    (if (< n 2)
174                        (error 'fold-peq "number of iterations must be >= 2")
175                        (/ (- xmax xmin) (- n 1)))))
176         )
177    (let ((res (g (list-tabulate n (lambda (i) (+ xmin (* dx i)))))))
178    (f64vector-fold f init res)
179    )))
180
181
182;; Transforms an equation using the given function.
183(define (map-peq f x)
184  (let ((fx (sample-peq x)) 
185        (splx (peq-spl x)))
186    (let ((f1 (lambda (u) (f (fx u)))))
187      (simple-peq (spline-n splx) (spline-k splx) f1 (peq-xmin x) (peq-xmax x))
188      )))
189
190
191
192
193;; Combines two equations using the given function.
194(define (compose-peq f x y)
195  (let ((fx   (sample-peq x)) 
196        (splx (peq-spl x)) 
197        (fy   (sample-peq y)))
198    (let ((f1 (lambda (u) (f (fx u) (fy u)))))
199      (simple-peq (spline-n splx) (spline-k splx) f1 (peq-xmin x) (peq-xmax x))
200      )))
201
202
203;; Translates a parametric equation.
204(define (translate-peq x p) (map-peq (lambda (v) (+ x v)) p))
205
206
207;; Scales a parametric equation. 
208(define (scale-peq s p) (map-peq (lambda (v) (* s v)) p))
209
210
211;; Defines a simple parametric curve.
212(define (simple-curve n k fs tmin tmax)
213  (if (null? fs) '()
214      (let ((c (simple-peq n k (car fs) tmin tmax)))
215        (cons c (simple-curve n k (cdr fs) tmin tmax))
216        )))
217 
218 
219;; Samples a curve at the given point
220(define (sample-curve s)
221  (let ((scs (map sample-peq s)))
222    (lambda (t) (map (lambda (sc) (sc t)) scs))
223    ))
224
225;; Samples a curve at the given points
226(define (sample-curve* s)
227  (let ((scs (map sample-peq* s)))
228    (lambda (ts) (map (lambda (sc) (sc ts)) scs))
229    ))
230
231
232;; Linear curve of the form c1 * x + c2
233;; Argument coeffs supplies c1 and c2 for the different dimensions
234(define (linear-curve n coeffs tmin tmax )
235  (simple-curve n 1 (map (lambda (s) 
236                           (let ((c1 (car s)) (c2 (cadr s)))
237                             (cond ((and (zero? c2) (zero? c1)) (lambda (x) 0.0))
238                                   ((zero? c1) (lambda (x) c2))
239                                   (else (lambda (x) (+ (* c1 x) c2))))))
240                           coeffs)
241                tmin tmax))
242
243
244;; Line segment curve of the form (x1,xn) defined on the parameter range 0.0 .. 1.0
245(define (line-segment n coeffs )
246  (simple-curve n 1 (map (lambda (s) (lambda (x) (* x s))) coeffs) 0.0 1.0))
247
248
249;; Maps the given functions to the parametric curve.
250(define (map-curve fs c)
251  (map (lambda (f p) (map-peq f p)) fs c))
252
253
254;; Translates a parametric curve.
255(define (translate-curve xs c)
256  (map (lambda (x p) (translate-peq x p)) xs c))
257
258                         
259;; Scales a parametric curve.
260(define (scale-curve xs c)
261  (map (lambda (x p) (scale-peq x p)) xs c))
262
263                         
264;; Obtain the bounding box of a curve
265(define (bbox-curve c) (append (map peq-ymin c) (map peq-ymax c)))
266
267
268;; Samples a parametric curve at regular intervals in the range xmin..xmax inclusive.
269(define (iterate-curve c n) (map (lambda (p) (iterate-peq p n)) c))
270
271
272;; Folds a parametric curve at regular intervals in the range xmin..xmax inclusive.
273(define (fold-curve c n fs inits) (map (lambda (p f init) (fold-peq p n f init)) c fs inits))
274
275
276;; Computes the arc length of the parametric curve given step dx
277(define (arc-length c dx)
278  (let* ((n (inexact->exact (round (/ 1.0 dx))))
279         (v (iterate-curve c n)))
280    (let recur ((i 1) (l 0.0) 
281                (s (map (lambda (x) (f64vector-ref x 0)) v)))
282      (if (< i n)
283          (let ((s1 (map (lambda (x) (f64vector-ref x i)) v)))
284            (recur (+ 1 i)
285                   (+ l (sqrt (fold (lambda (x x1 l) (+ l (expt (- x1 x) 2))) 0.0 s s1)))
286                   s1))
287          l))
288    ))
289           
290   
291 
292
293)
Note: See TracBrowser for help on using the repository browser.