File: pdf-geom.lisp

package info (click to toggle)
cl-pdf 166-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 1,520 kB
  • ctags: 639
  • sloc: lisp: 6,902; makefile: 39
file content (205 lines) | stat: -rw-r--r-- 7,985 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
;;; cl-pdf copyright 2002-2003 Marc Battyani see license.txt for details.
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

(in-package #:pdf)

;;; Geometry functions contributed by Eduardo Mu�oz

;;; Exported functions

(defconstant +2pi+ (* 2 pi))
(defconstant +pi/2+ (/ pi 2))

(defun arc (center-x center-y radius start extent)
  (move-to (+ center-x (* radius (cos start)))
           (+ center-y (* radius (sin start))))
  (arc-to center-x center-y radius start extent))

(defun pie (center-x center-y radius start extent)
  (move-to center-x center-y)
  (line-to (+ center-x (* radius (cos start)))
           (+ center-y (* radius (sin start))))
  (arc-to center-x center-y radius start extent)
  (line-to center-x center-y))

(defun circle (center-x center-y radius)
  (move-to (+ center-x radius) center-y)
  (arc-to center-x center-y radius 0 +2pi+))


(defun ellipse (center-x center-y radius-a radius-b)
  (move-to (+ center-x radius-a) center-y)
  (let ((kappa (* 4 (/ (- (sqrt 2) 1) 3.0))))
    (bezier-to (+ center-x radius-a) (+ center-y (* kappa radius-b))
               (+ center-x (* kappa radius-a)) (+ center-y radius-b)
               center-x (+ center-y radius-b))
    (bezier-to (- center-x (* kappa radius-a)) (+ center-y radius-b)
               (- center-x radius-a) (+ center-y (* kappa radius-b))
               (- center-x radius-a) center-y)
    (bezier-to (- center-x radius-a) (- center-y (* kappa radius-b))
               (- center-x (* kappa radius-a)) (- center-y radius-b)
               center-x (- center-y radius-b))
    (bezier-to (+ center-x (* kappa radius-a)) (- center-y radius-b)
               (+ center-x radius-a) (- center-y (* kappa radius-b))
               (+ center-x radius-a) center-y)))

(defun rectangle (x y dx dy &key (radius 0))
  (if (zerop radius)
      (basic-rect x y dx dy)
      (progn
        (move-to (+ x dx) (- (+ y dy) radius))
        (polyline (list (list x y) (list (+ x dx) y)
                        (list (+ x dx) (+ y dy)) (list x (+ y dy)))
                  :radius radius :closed t))))

(defun polyline (points &key (radius 0) (closed nil))
  (if (zerop radius)
      (destructuring-bind ((x1 y1) . other-points) points
        (move-to x1 y1)
        (loop for (x y) in other-points
              do (line-to x y)
              finally (when closed (line-to x1 y1))))
      (progn
          (when closed
            (let ((break-point (midpoint (first points) (first (last points)) 0.5)))
              (setf points `(,break-point ,@points ,break-point))))
          (move-to (first (first points)) (second (first points)))
          (dotimes (i (- (length points) 2))
            (let ((p1 (nth i points))
                  (p2 (nth (1+ i) points))
                  (p3 (nth (+ 2 i) points)))
              (fillet p2 p1 p3 radius)))
          (line-to (first (first (last points)))
                   (second (first (last points)))))))

(defun regular-polygon (center-x center-y radius sides &key (fillet-radius 0))
  (polyline (loop with step-angle = (/ +2pi+ sides)
		  repeat sides
		  for current-angle from +pi/2+ by step-angle
		  collect (list (+ center-x (* radius (cos current-angle)))
				(+ center-y (* radius (sin current-angle)))))
	    :radius fillet-radius :closed t))

(defun star (center-x center-y ext-radius int-radius sides
             &key (fillet-radius 0))
  (let* ((current-angle +pi/2+)
         (step-angle (/ +2pi+ sides))
         (half-step (/ step-angle 2.0))
         (points '()))
    (dotimes (i sides)
      (push (list (+ center-x (* ext-radius (cos current-angle)))
                  (+ center-y (* ext-radius (sin current-angle))))
            points)
      (push (list (+ center-x (* int-radius (cos (+ current-angle half-step))))
                  (+ center-y (* int-radius (sin (+ current-angle half-step)))))
                  points)
      (setf current-angle (+ current-angle step-angle)))
    (polyline points :radius fillet-radius :closed t)))



;;; Non exported functions

(defun arc-to (center-x center-y radius start extent)
  ;; An arc of extent zero will generate an error at bezarc (divide by zero).
  ;; This case may be given by two aligned points in a polyline.
  ;; Better do nothing.
  (unless (zerop extent)
    (if (<= (abs extent) (/ pi 2.0))
        (multiple-value-bind (x1 y1 x2 y2 x3 y3)
            (bezarc center-x center-y radius start extent)
          (bezier-to x1 y1 x2 y2 x3 y3))
        (let ((half-extent (/ extent 2.0)))
          (arc-to center-x center-y radius start half-extent)
          (arc-to center-x center-y radius (+ start half-extent) half-extent)))))

(defun bezarc (center-x center-y radius start extent)
  ;; start and extent should be in radians.
  ;; Returns first-control-point-x first-control-point-y
  ;;         second-control-point-x second-control-point-y
  ;;         end-point-x end-point-y
  (let* ((end (+ start extent))
         (s-start (sin start)) (c-start (cos start))
         (s-end (sin end)) (c-end (cos end))
         (ang/2 (/ extent 2.0))
         (kappa (* (/ 4.0 3.0)
                   (/ (- 1 (cos ang/2))
                      (sin ang/2))))
	 (x1 (- c-start (* kappa s-start)))
	 (y1 (+ s-start (* kappa c-start)))
	 (x2 (+ c-end   (* kappa s-end)))
	 (y2 (- s-end   (* kappa c-end))))
    (values (+ (* x1 radius) center-x)(+ (* y1 radius) center-y)
	    (+ (* x2 radius) center-x)(+ (* y2 radius) center-y)
	    (+ (* c-end radius) center-x)(+ (* s-end radius) center-y))))


(defun distance (p1 p2)
  (sqrt (+ (expt (- (first p2)  (first p1))  2)
           (expt (- (second p2) (second p1)) 2))))

(defun angle (p1 p2)
  (if (zerop (distance p1 p2))
      0.0
      (atan (- (second p2) (second p1)) (- (first p2) (first p1)))))


;;;============================================================================;
;;;
;;; (angle-3points <point> <point> <point>)
;;;
;;; Devuelve el angulo en radianes entre tres puntos.  Se considera el punto
;;; 'pt1' como vertice del angulo.  El rango del angulo de salida es [+Pi -Pi)
;;;

(defun angle-3points (pt1 pt2 pt3)
  (let ((ang (- (angle pt1 pt3) (angle pt1 pt2))))
    (if	(or (> ang pi) (<= ang (- pi)))
        (- ang (* (signum ang) +2pi+))
        ang)))


;;;============================================================================;
;;;
;;; (midpoint <point> <point> <real>)
;;;
;;; Devuelve un punto situado entre los dos que se dan como argumento. El
;;; factor de posici�n indica la relaci�n de las distancias entre los puntos
;;; de entrada y el de salida.
;;;

(defun midpoint (pt1 pt2 ratio)
  (let ((x1 (first pt1))(y1 (second pt1))
	(x2 (first pt2))(y2 (second pt2)))
    (list (+ x1 (* ratio (- x2 x1)))
          (+ y1 (* ratio (- y2 y1))))))


;; This function is the support to create rounded polylines
;;
;; p1 = corner
;; p2 = start
;; p3 = end
;; -> no usefull return value
(defun fillet (p1 p2 p3 radius)
  (let* ((gamma (/ (abs (angle-3points p1 p2 p3)) 2))
         (dist-p1-t (/ radius (tan gamma)))
         (dist-p1-s (/ (sqrt (+ (expt radius 2) (expt dist-p1-t 2)))
                       (cos gamma)))
         (dist-p1-p2 (distance p1 p2))
         (dist-p1-p3 (distance p1 p3)))
    (if (or (< dist-p1-p2 dist-p1-t)
            (< dist-p1-p3 dist-p1-t))
        ;; Radius is too large, so we aren't going to draw the arc.
        (line-to (first p1) (second p1))
        ;; Else, draw the arc.
        (let ((t2 (midpoint p1 p2 (/ dist-p1-t dist-p1-p2)))
              (t3 (midpoint p1 p3 (/ dist-p1-t dist-p1-p3)))
              (center (midpoint (midpoint p1 p2 (/ dist-p1-s dist-p1-p2))
                                (midpoint p1 p3 (/ dist-p1-s dist-p1-p3))
                                0.5)))
          (line-to (first t2) (second t2))
          (arc-to (first center) (second center) radius
                  (angle center t2) (angle-3points center t2 t3))))))