lenses.lisp 14.7 KB
Newer Older
1
;;
2
;; Copyright 2002-2011 Genworks International 
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
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

(in-package :geom-base)

(defparameter *fixed-scale?* nil)

(eval-when (compile load eval) (export '*fixed-scale?*))

;;
;; FLAG -- the basic PDF views from here will go back to internal codebase.
;;

(defmacro with-translated-state ((format center) &body body)
  (ecase format
    (:pdf `(pdf:with-saved-state (pdf:translate (get-x ,center) (get-y ,center)) ,@body))
    (:dxf `(let ((*dxf-translation* (add-vectors (subseq ,center 0 2)  *dxf-translation*))) ,@body))
    (:raphael `(let ((*raphael-translation* (add-vectors (subseq ,center 0 2)  *raphael-translation*))) ,@body))))

             

(define-lens (pdf base-drawing)()
  :output-functions
  ((cad-output
    ()
    (with-format-slots (view)
      (let ((view-center (if (the user-center) 
                             (scalar*vector (the user-scale) (the user-center)) 
                           (make-point 0 0 0))))
        
        
        (pdf:with-saved-state
            (when view (unless *fixed-scale?* (pdf:scale (the-object view view-scale-total) 
                                                         (the-object view view-scale-total))))
        
          (mapc #'(lambda(child-view) 
                    (let ((width (the-object child-view width))
                          (length (the-object child-view length))
                          (center (the-object child-view center)))
                      
                      (pdf:with-saved-state
                          (let ((rotation (angle-between-vectors-d 
                                           +rear-vector+ 
                                           (the-object child-view (face-normal-vector :rear)) 
                                           +top-vector+)))
                            (pdf:rotate rotation)
                          
                            (pdf:basic-rect (+ (get-x center) (- (half width)))
                                            (+ (get-y center) (- (half length)))
                                            width length)
                            (pdf:clip-path) 
                            (if (the-object child-view border-box?) (pdf:stroke) 
                              (pdf:end-path-no-op))
                            (with-translated-state (:pdf  (make-point (- (get-x view-center)) (- (get-y view-center))))
                              (write-the-object child-view cad-output)))))) (the views))))))))


(define-lens (dxf base-drawing)()
  :output-functions
  ((cad-output () (mapc #'(lambda(view) (write-the-object view cad-output)) (the views)))))


(define-lens (pdf base-view)()
  :output-functions
  ((cad-output
    ()
    
    (set-format-slot view self)
    
    (let ((center (the center)) 

          (view-center (scalar*vector (the view-scale-total)
                                      (keyed-transform*vector (the view-transform)
                                                              (the view-center)))))
      (with-translated-state (:pdf center)
        
        
        ;;
        ;; FLAG - look into capturing this translate in the
        ;; vertex-array-2d-scaled in view-object-cache.  so it will
        ;; become unecessary here.
        ;;
        (with-translated-state (:pdf (make-vector (- (get-x view-center)) (- (get-y view-center))))
          
          (dolist (cache (list-elements (the object-caches))) (write-the-object cache lines-and-curves)))

        (dolist (cache (list-elements (the object-caches))) (write-the-object cache object cad-output))
        
        (with-format-slots (view)
          (set-format-slot view nil)
          (dolist (cache (list-elements (the annotation-caches)))
            (write-the-object cache object cad-output) 
            (write-the-object cache lines-and-curves))
          (set-format-slot view view))
      ))
    
    (set-format-slot view nil))))
    


(define-lens (dxf base-view)()
  :output-functions
  ((cad-output
    ()
    (set-format-slot view self)
    (let ((center (the center))(view-center (scalar*vector (the view-scale-total)
                                                           (keyed-transform*vector (the view-transform)
                                                                                   (the view-center)))))
      (with-translated-state (:dxf center)
        (with-format-slots (view)
          (set-format-slot view nil)
          (dolist (cache (list-elements (the annotation-caches)))
            (write-the-object cache object cad-output) (write-the-object cache lines-and-curves))
          (set-format-slot view view))
        (dolist (cache (list-elements (the object-caches))) 
          
          (write-the-object cache object cad-output))
        ;;
        ;; FLAG - look into capturing this translate in the
        ;; vertex-array-2d-scaled in view-object-cache.  so it will
        ;; become unecessary here.
        ;;
        (with-translated-state (:dxf (make-vector (- (get-x view-center)) 
                                                  (- (get-y view-center))))
          (dolist (cache (list-elements (the object-caches))) 
            (write-the-object cache lines-and-curves))))))))


(define-lens (pdf view-object-cache)()
  :output-functions
  ((lines-and-curves
    ()
Dave Cooper's avatar
Dave Cooper committed
151
152
153
154
155
156
    (when (typep (the object) 'gdl::gdl-basis)
      (let ((object (the object)) (2d-vertices (the vertex-array-2d-scaled)))
	;;
	;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
	;;
	(unless (typep object 'global-filleted-polyline)
157
      
Dave Cooper's avatar
Dave Cooper committed
158
159
	  (let ((line-index-pairs (the-object object %line-vertex-indices%))
		(curve-index-quadruples (the-object object %curve-vertex-indices%)))
160
        
Dave Cooper's avatar
Dave Cooper committed
161
	    (pdf:with-saved-state (write-the-object object line-thickness-setting)
162
          
Dave Cooper's avatar
Dave Cooper committed
163
				  (write-the-object object dash-pattern-setting)
164
          
Dave Cooper's avatar
Dave Cooper committed
165
				  (write-the-object object rgb-stroke-setting)
166
167

            
Dave Cooper's avatar
Dave Cooper committed
168
169
170
171
172
173
				  (mapc #'(lambda(line-index-pair)
					    (destructuring-bind (start-index end-index) line-index-pair
					      (let ((start (svref 2d-vertices start-index)) 
						    (end (svref 2d-vertices end-index)))
						(pdf:move-to (%get-x% start) (%get-y% start))
						(pdf:line-to (%get-x% end)(%get-y% end))))) line-index-pairs)
174
175
            
            
Dave Cooper's avatar
Dave Cooper committed
176
				  (let (start end prev-end)
177
              
Dave Cooper's avatar
Dave Cooper committed
178
179
180
181
				    (mapc #'(lambda(curve-index-quadruple)
					      (destructuring-bind (start-index c1-index c2-index end-index) 
						  curve-index-quadruple
						(declare (ignorable start-index))
182
                          
Dave Cooper's avatar
Dave Cooper committed
183
184
185
						(setq prev-end end)
						(setq start (svref 2d-vertices start-index)
						      end (svref 2d-vertices end-index))
186
                          
Dave Cooper's avatar
Dave Cooper committed
187
188
						(let ((c1 (svref 2d-vertices c1-index))
						      (c2 (svref 2d-vertices c2-index)))
189

Dave Cooper's avatar
Dave Cooper committed
190
191
						  (unless (and start prev-end (coincident-point? start prev-end))
						    (pdf:move-to (%get-x% start) (%get-y% start)))
192
                            
Dave Cooper's avatar
Dave Cooper committed
193
194
195
						  (pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2) 
								 (%get-y% c2) (%get-x% end) (%get-y% end)))))
					  curve-index-quadruples))
196
197
            
            
Dave Cooper's avatar
Dave Cooper committed
198
199
200
				  (if (the-object object fill-color-decimal)
				      (pdf:fill-and-stroke)
				      (pdf:stroke))))))))))
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281


(define-lens (dxf view-object-cache)()
  :output-functions
  ((lines-and-curves
    ()
    
    (let ((2d-vertices (the vertex-array-2d-scaled))) 
      (let ((line-index-pairs (the object %line-vertex-indices%)))
        (let ((2d-vertices (map 'vector #'(lambda(vertex) (add-vectors (subseq vertex 0 2) *dxf-translation*)) 
                                2d-vertices)))
          
          (mapc #'(lambda(line-index-pair)
                    (destructuring-bind (start-index end-index) line-index-pair
                      (let ((start (svref 2d-vertices start-index)) (end   (svref 2d-vertices end-index)))
                        (format *stream* "  0~%LINE~% 10~%~3,16f~% 20~%~3,16f~% 11~%~3,16f~% 21~%~3,16f~%"
                                (get-x start) (get-y start) (get-x end) (get-y end))))
                    
                    (write-the object line-thickness-setting)
                    (write-the object dash-pattern-setting)
                    (write-the object rgb-stroke-setting))
                    
                line-index-pairs)))
      
      (mapc #'(lambda(arc 2d-arc-center)
                
                (let ((angle-correction 
                       (angle-between-vectors-d +rear-vector+
                                                (the object (face-normal-vector :rear))
                                                +top-vector+)))
                  (let ((start-angle (+ (radians-to-degrees 
                                         (the-object arc start-angle-normalized)) angle-correction))
                        (end-angle (+ (radians-to-degrees 
                                       (the-object arc end-angle-normalized)) angle-correction))
                        (radius (* (the-object arc radius) (the view-scale)))

                        (center (add-vectors *dxf-translation* 2d-arc-center))
                          
                        (top-vector (the-object arc (face-normal-vector :top))))
                      
                    (if (>= (- end-angle start-angle) 360)
                        (format *stream* "  0~%CIRCLE~% 10~%~3,16f~% 20~%~3,16f~% 30~%~3,16f~% 40~%~3,15f
  210~%~3,15f~% 220~%~3,15f~% 230~%~3,15f~%" 
                                (get-x center) (get-y center) 0 radius 
                                (get-x top-vector) (get-y top-vector) (get-z top-vector))
                      (format *stream* "  0~%ARC~% 10~%~3,16f~% 20~%~3,16f~% 30~%~3,16f~% 40~%~3,15f
 50~%~3,15f~% 51~%~3,15f~% 210~%~3,15f~% 220~%~3,15f~% 230~%~3,15f~%" 
                              (get-x center) (get-y center) 0 radius start-angle end-angle
                              (get-x top-vector) (get-y top-vector) (get-z top-vector)))))
                  
                  
                (write-the object line-thickness-setting)
                (write-the object dash-pattern-setting)
                (write-the object rgb-stroke-setting))

            (the object %arcs%) (the arcs-array-2d-scaled))))))



(define-lens (jpeg base-drawing)()
  :output-functions
  ((cad-output
    ()
    (let ((temp-dir (glisp:temporary-folder))
          (temp-name (format nil "~a-~a" (glisp:get-pid) (gensym))))
      (let ((temp-pdf (make-pathname :directory (pathname-directory temp-dir)
                                     :device (pathname-device temp-dir)
                                     :name temp-name
                                     :type "pdf"))
            
            (temp-jpeg (make-pathname :directory (pathname-directory temp-dir)
                                      :device (pathname-device temp-dir)
                                      :name temp-name
                                      :type "jpg")))
        (with-format-slots (page-width page-length foreground-color background-color)
          (with-format (pdf temp-pdf :page-width page-width :page-length page-length
                            :foreground-color foreground-color :background-color background-color) 
            (write-the cad-output)))
        
        
        (let ((command 
282
		(format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE  \"~a\""
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
                       *gs-path* "jpeg"  temp-jpeg *gs-text-alpha-bits* 
                       *gs-graphics-alpha-bits* temp-pdf)))
          (glisp:run-gs command))
        
        (when *stream*
          (with-open-file (image-stream temp-jpeg :element-type '(unsigned-byte 8))
            (do ((val (read-byte image-stream nil nil)
                      (read-byte image-stream nil nil)))
                ((null val))
              (write-byte val *stream*))))
                                         
        (delete-file temp-pdf)
        (delete-file temp-jpeg))))))


(defparameter *command* nil)

(define-lens (png base-drawing)()
  :output-functions
  ((cad-output
    ()
    (let ((temp-dir (glisp:temporary-folder))
          (temp-name (format nil "~a-~a" (glisp:get-pid) (gensym))))

      (let ((temp-pdf (make-pathname :directory (pathname-directory temp-dir)
                                     :device (pathname-device temp-dir)
                                     :name temp-name
                                     :type "pdf"))
            
            (temp-png (make-pathname :directory (pathname-directory temp-dir)
                                     :device (pathname-device temp-dir)
                                     :name temp-name
                                     :type "png")))
        (with-format-slots (page-width page-length background-color foreground-color)
          (with-format (pdf temp-pdf :page-width page-width :page-length page-length 
                            :background-color background-color :foreground-color foreground-color) (write-the cad-output)))
        
        (let ((command 
               (format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE  \"~a\""
                               *gs-path* "png16m"  temp-png *gs-text-alpha-bits* 
                               *gs-graphics-alpha-bits* temp-pdf)))
          (glisp:run-gs command))
        
        (when *stream*
          (with-open-file (image-stream temp-png :element-type 'unsigned-byte)
            (do ((val (read-byte image-stream nil nil)
                      (read-byte image-stream nil nil)))
                ((null val))
              (write-byte val *stream*))))
                                         
        (delete-file temp-pdf)

        (delete-file temp-png))))))


(defparameter *current-vrml-requests* nil)