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

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

parametric-curve: added perturbation term to curve structure

File size: 7.9 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 perturb-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-map)
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, interpolating
58;; spline, and perturbation function.
59(define-record-type peq (make-peq fn xmin xmax ymin ymax spl pfn)
60  peq? 
61  (fn      peq-fn )
62  (xmin    peq-xmin)
63  (xmax    peq-xmax)
64  (ymin    peq-ymin)
65  (ymax    peq-ymax)
66  (spl     peq-spl)
67  (pfn     peq-pfn)
68  )
69
70
71(define-record-printer (peq x out)
72  (fprintf out "#(peq fn=~A xmin=~A xmax=~A ymin=~A ymax=~A spl=~A pfn=~A)"
73           (peq-fn x)
74           (peq-xmin x)
75           (peq-xmax x)
76           (peq-ymin x)
77           (peq-ymax x)
78           (peq-spl x)
79           (peq-pfn x)
80           ))
81
82
83
84;; A N-dimensional parametric curve is a set of N parametric equations.
85(define (parametric-curve? x) (every peq? x))
86
87
88;; Defines a simple parametric equation.
89(define (simple-peq n k fn xmin xmax)
90  (if (> xmin xmax)
91
92      (simple-peq n k fn xmax xmin)
93
94      (let ((dx (/ (- xmax xmin) n)))
95
96        (let* ((x (list-tabulate (+ 1 n) (lambda (i) (+ xmin (* i dx)))))
97               (y (map fn x))
98               (ymin (fold min +inf.0 y))
99               (ymax (fold max -inf.0 y))
100               (xv (list->f64vector x))
101               (yv (list->f64vector y))
102               )
103
104          (let ((spl
105                 (let-values (((d d2 constr errc diagn)
106                               (bvsp-spline:compute n k xv yv)))
107                   (if (zero? errc)
108                       (make-spline n k xv yv d d2) 
109                       (error 'simple-peq "unable to compute interpolating spline"))
110                   ))
111                )
112
113              (make-peq fn xmin xmax ymin ymax spl #f)
114              ))
115          ))
116      )
117
118
119;; Samples a parametric equation at the given point of interest.
120(define (sample-peq c)
121  (let ((s (peq-spl c))
122        (p (peq-pfn c))
123        (min (peq-xmin c))
124        (max (peq-xmax c)))
125    (lambda (xp)
126      (and (>= xp min) (<= xp max)
127           (let ((v (bvsp-spline:evaluate (spline-n s) (spline-k s) 
128                                          (spline-x s) (spline-y s) 
129                                          (spline-d s) (spline-d2 s) 
130                                          (f64vector xp) 0)))
131             (and v (or (and p (p (f64vector-ref v 0)))
132                        (f64vector-ref v 0))))
133           ))
134    ))
135
136
137;; Samples a parametric equation at the given points of interest.
138(define (sample-peq* c)
139  (let ((s (peq-spl c))
140        (p (peq-pfn c)))
141    (lambda (xps)
142      (let ((xpsv (if (list? xps) (list->f64vector xps) xps)))
143        (let ((res (bvsp-spline:evaluate (spline-n s) (spline-k s) 
144                                         (spline-x s) (spline-y s) 
145                                         (spline-d s) (spline-d2 s) 
146                                         xpsv 0)))
147          (or (and p (f64vector-map p res)) res)
148          ))
149      ))
150  )
151
152
153
154;; Samples a parametric equation at regular intervals in the range xmin..xmax inclusive.
155(define (iterate-peq c n)
156  (let* (
157         (f     (sample-peq* c))
158         (xmin  (peq-xmin c))
159         (xmax  (peq-xmax c))
160         (delta (- xmax xmin))
161         (dx    (if (zero? delta) 0
162                    (if (< n 2)
163                        (error 'iterate-peq "number of iterations must be >= 2")
164                        (/ (- xmax xmin) (- n 1)))))
165         )
166    (f (list-tabulate n (lambda (i) (+ xmin (* dx i)))))
167    ))
168
169
170;; Transforms an equation using the given function.
171(define (map-peq f x)
172  (let ((fx (sample-peq x)) (splx (peq-spl x)))
173    (let ((f1 (lambda (u) (f (fx u)))))
174      (simple-peq (spline-n splx) (spline-k splx) f1 (peq-xmin x) (peq-xmax x))
175      )))
176
177
178;; Adds a perturbation term to an equation using the given function.
179(define (perturb-peq f x)
180  (make-peq (peq-fn x) (peq-xmin x) (peq-xmax x) (peq-ymin x) (peq-ymax x) (peq-spl x) f)
181  )
182
183
184;; Combines two equations using the given function.
185(define (compose-peq f x y)
186  (let ((fx   (sample-peq x)) 
187        (splx (peq-spl x)) 
188        (fy   (sample-peq y)))
189    (let ((f1 (lambda (u) (f (fx u) (fy u)))))
190      (simple-peq (spline-n splx) (spline-k splx) f1 (peq-xmin x) (peq-xmax x))
191      )))
192
193
194;; Translates a parametric equation.
195(define (translate-peq x p) (map-peq (lambda (v) (+ x v)) p))
196
197
198;; Scales a parametric equation. 
199(define (scale-peq s p) (map-peq (lambda (v) (* s v)) p))
200
201
202;; Defines a simple parametric curve.
203(define (simple-curve n k fs tmin tmax)
204  (if (null? fs) '()
205      (let ((c (simple-peq n k (car fs) tmin tmax)))
206        (cons c (simple-curve n k (cdr fs) tmin tmax))
207        )))
208 
209 
210;; Samples a curve at the given point
211(define (sample-curve s)
212  (let ((scs (map sample-peq s)))
213    (lambda (t) (map (lambda (sc) (sc t)) scs))
214    ))
215
216;; Samples a curve at the given points
217(define (sample-curve* s)
218  (let ((scs (map sample-peq* s)))
219    (lambda (ts) (map (lambda (sc) (sc ts)) scs))
220    ))
221
222
223;; Linear curve of the form c1 * x + c2
224;; Argument coeffs supplies c1 and c2 for the different dimensions
225(define (linear-curve n coeffs tmin tmax )
226  (simple-curve n 1 (map (lambda (s) 
227                           (let ((c1 (car s)) (c2 (cadr s)))
228                             (cond ((and (zero? c2) (zero? c1)) (lambda (x) 0.0))
229                                   ((zero? c1) (lambda (x) c2))
230                                   (else (lambda (x) (+ (* c1 x) c2))))))
231                           coeffs)
232                tmin tmax))
233
234
235;; Line segment curve of the form (x1,xn) defined on the parameter range 0.0 .. 1.0
236(define (line-segment n coeffs )
237  (simple-curve n 1 (map (lambda (s) (lambda (x) (* x s))) coeffs) 0.0 1.0))
238
239
240;; Maps the given functions to the parametric curve.
241(define (map-curve fs c)
242  (map (lambda (f p) (map-peq f p)) fs c))
243
244
245;; Translates a parametric curve.
246(define (translate-curve xs c)
247  (map (lambda (x p) (translate-peq x p)) xs c))
248
249                         
250;; Scales a parametric curve.
251(define (scale-curve xs c)
252  (map (lambda (x p) (scale-peq x p)) xs c))
253
254                         
255;; Adds perturbation terms to a parametric curve.
256(define (perturb-curve fs c) (map perturb-peq fs c))
257
258                         
259;; Obtain the bounding box of a curve
260(define (bbox-curve c) (append (map peq-ymin c) (map peq-ymax c)))
261
262
263;; Samples a parametric curve at regular intervals in the range xmin..xmax inclusive.
264(define (iterate-curve c n) (map (lambda (p) (iterate-peq p n)) c))
265
266;; Computes the arc length of the parametric curve given step dx
267(define (arc-length c dx)
268  (let* ((n (inexact->exact (round (/ 1.0 dx))))
269         (v (iterate-curve c n)))
270    (let recur ((i 1) (l 0.0) 
271                (s (map (lambda (x) (f64vector-ref x 0)) v)))
272      (if (< i n)
273          (let ((s1 (map (lambda (x) (f64vector-ref x i)) v)))
274            (recur (+ 1 i)
275                   (+ l (sqrt (fold (lambda (x x1 l) (+ l (expt (- x1 x) 2))) 0.0 s s1)))
276                   s1))
277          l))
278    ))
279           
280   
281 
282
283)
Note: See TracBrowser for help on using the repository browser.