source: project/release/5/yasos/trunk/points.scm @ 36339

Last change on this file since 36339 was 36339, checked in by iraikov, 4 months ago

yasos: rename yasos based data structure models to yasos-<name> to avoid collisions with other eggs

File size: 2.0 KB
Line 
1
2(module yasos-points
3       
4        (point? make-point-cartesian make-point-polar x y rho theta
5        translate! scale! rotate! distance)
6
7(import scheme (chicken base) (chicken format)
8        (except yasos object object-with-ancestors operate-as))
9                 
10(define-predicate point?)
11(define-operation (x obj))
12(define-operation (y obj))
13(define-operation (rho obj))
14(define-operation (theta obj))
15(define-operation (translate! obj dx dy))
16(define-operation (scale! obj factor))
17(define-operation (rotate! obj angle))
18(define-operation (distance obj other))
19
20;; internal
21(define pi (acos -1))
22(define (normalize theta)
23  (/ (remainder (floor (round (* 10E12 theta)))
24                (floor (round (* 20E12 pi))))
25     10E12))
26(define (r2 x) ; round to precision 2
27 (/ (round (* x 100)) 100))
28(define (point-maker %x %y %rho %theta)
29  (operations ()
30    ((point? self) #t)
31    ((size self) 2)
32    ((show self . optional-arg)
33     (if (null? optional-arg)
34       (show self #t)
35       (format (car optional-arg)
36               "#,(point x: ~s y: ~s rho: ~s theta: ~s)~%"
37               (r2 %x) (r2 %y) (r2 %rho) (r2 %theta))))
38    ((x self) %x)
39    ((y self) %y)
40    ((rho self) %rho)
41    ((theta self) %theta)
42    ((distance self other)
43     (let ((dx (- %x (x other))) (dy (- %y (y other))))
44       (sqrt (+ (* dx dx) (* dy dy)))))
45    ((translate! self dx dy)
46     (set! %x (+ %x dx))
47     (set! %y (+ %y dy))
48     (set! %rho (sqrt (+ (* %x %x) (* %y %y))))
49     (set! %theta (atan %y %x)))
50    ((scale! self factor)
51     (set! %rho (* %rho factor))
52     (set! %x (* %rho (cos %theta)))
53     (set! %y (* %rho (sin %theta))))
54    ((rotate! self angle)
55     (set! %theta (normalize (+ %theta angle)))
56     (set! %x (* %rho (cos %theta)))
57     (set! %y (* %rho (sin %theta))))
58    ))
59
60(define (make-point-cartesian x y)
61  (point-maker x y (sqrt (+ (* x x) (* y y))) (atan y x)))
62
63(define (make-point-polar rho theta)
64  (point-maker (* rho (cos theta)) (* rho (sin theta)) rho (normalize theta)))
65
66) ; points
67
Note: See TracBrowser for help on using the repository browser.