base-ajax-graphics-sheet.lisp 16.9 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
;;
;; 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 :gwl)

(define-object base-ajax-graphics-sheet 
    (base-ajax-sheet base-html-graphics-sheet)
  
  
  :documentation (:description "This mixes together base-ajax-sheet 
with base-html-graphics-sheet, and adds html-format output-functions 
for several of the new formats such as ajax-enabled png/jpeg and 
Raphael vector graphics."
                  
                  :examples "FLAG -- Fill in!!!")
  
  :input-slots 
  (("Number. Thickness of default border around graphics viewport. 
Default is 1." viewport-border-default 1)
   
   (vector-graphics-onclick? t)
   
   ("Plist of keys and strings. The default formats for graphics display. Defaults to:

 <pre>
 (list :png \"PNG image\"
       :jpeg \"jpeg image\"
       :raphael \"SVG/VML\")
</pre>"
    image-format-plist (list :png "PNG image"
                             :jpeg "jpeg image"
                             :web3d "VRML/X3D"
                             :raphael "SVG/VML"))

   
   ("Keyword symbol, one of the keys from (the image-format-plist). 
Default for the image-format-selector. Defaults to :png."
    image-format-default :png)
   
   
   ("Default view initially in the view-selector which is 
automatically included in the view-controls."
    view-direction-default :trimetric)
   
64
   (zoom-factor-renderer 1)
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
   
   ("Boolean. Include raphael javascript library in the page header? 
Default nil. " 
    use-raphael? nil)
   
   ("Boolean. Include raphael graphing library in the page header? 
Default nil. " 
    use-raphael-graf? nil)
   
   ("List of GDL objects containing geometry. These are the 
actual objects themselves, not nodes which have children or 
other descendants that you want to display. If you want to 
display the leaves of certain nodes, include the objects for 
those nodes in the display-list-object-roots, not here. 
Defaults to nil." 
    display-list-objects nil)
   
   
   ("List of GDL objects. The leaves of each of these objects will 
be included in the geometry display. Defaults to nil." 
    display-list-object-roots nil)
   
   ("3D vector. This is the normal vector of the view plane onto 
which to project the 3D objects. Defaults to 
  (getf *standard-views* (the view-selector value)),
and (the view-selector value) defaults to :top."
    projection-vector (getf *standard-views* (the view-selector value)))
   
   
   ("List of GDL objects. These objects are not used in 
computing the scale or centering for the display list. 
Defaults to nil."
    immune-objects nil)
   
   
   ("Array of three numbers between 0 and 1. RGB Color in decimal 
format. Color to be used for the background of the viewport. 
Defaults to the 
 <tt>:background</tt> from the global <tt>*colors-default*</tt> parameter."
    background-color (lookup-color (getf *colors-default* :background) :format :decimal))

   ("Number in angular degrees. The maximum angle of the view frustrum 
Dave Cooper's avatar
Dave Cooper committed
107
108
for perspective views. Defaults to 45 which is natural human eye field of view. "
    field-of-view-default 45)
109
110
111
112
113
114
115
116
117
118
   
   
   ("Keyword symbol. Determines the default image format. Defaults to the currently selected
value of the image-format-selector, which itself defaults to :raphael."
    image-format (the image-format-selector value))
   
   
   ("Boolean. Indicates whether standard view-controls panel should be included with the graphics."
    include-view-controls? t)
   
Dave Cooper's avatar
Dave Cooper committed
119
120
   (x3dom-view-controls? t)

121
122
123
   ;;
   ;; FLAG -- probably not needed, inherited from skeleton-ui-mixin via base-ajax-sheet, base-html-sheet, sheet-section. 
   ;;
124
125
   (inner-html (with-cl-who-string () (write-the inner-html)))

Dave Cooper's avatar
Dave Cooper committed
126

127
   )
128
129

  
130
  :functions 
Dave Cooper's avatar
Dave Cooper committed
131
  ((set-js-vals! (js-vals) (declare (ignore js-vals))))
132

133
134
  :computed-slots
  (
135

Dave Cooper's avatar
Dave Cooper committed
136
137
138
   (js-to-eval :parse :settable)
   
   (js-always-to-eval nil)
139
140
141
142
143
                     
   
   (raphael-canvas-id (format nil "raphael-~a" (the base64-encoded-root-path)))
   
   (raphael-string  (unless (the no-graphics?)
144
145
146
147
148
149
150
151
		      (with-error-handling ()
			(with-output-to-string (ss)
			  (with-format (raphael ss 
						:page-width (the view-object page-width)
						:page-length (the view-object page-length)
						:background-color (the background-color)
						:foreground-color (the foreground-color))
			    (write-the view-object cad-output))))))
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
   
   
   ("String of valid HTML. This can be used to 
include the PNG or JPG raster-graphics of the geometry."
    raster-graphics 
    (with-cl-who-string () (write-the raster-graphics)))
   
   
   ("String of valid HTML. This can be used to 
include the SVG or VML vector-graphics of the geometry."
    vector-graphics 
    (with-cl-who-string () (write-the vector-graphics)))
   
   ("String of valid HTML. This can be used to 
include the VRML or X3D graphics of the geometry."
    web3d-graphics 
    (with-cl-who-string () (write-the web3d-graphics)))
   
   
   ("String of valid HTML. This includes the image-format-selector, the reset-zoom-button, 
and the view-selector, in a simple table layout. You can override this to make the view-controls
appear any way you want and include different and/or additional form-controls."
    view-controls
    (with-cl-who-string ()
      ((:div (:class "gdlFormControls"))
       (:table (:tr (:td (str (the  view-selector html-string)))
                    (:td (str (the image-format-selector html-string)))
                    (:td (str (the reset-zoom-button form-control-string))))))))
   
   
   ("String of valid HTML. This can be used to 
include the geometry, in the format currently selected by the image-format-selector.
If the include-view-controls? is non-nil, the view-controls will be appended at the 
bottom of the graphics inside a table."
    graphics 
    (with-cl-who-string ()
      (:table (:tr ((:td :align :center)
                    (str (ecase (the image-format-selector value)
                               ((:web3d :vrml) (the web3d-graphics))
                               ((:png :jpeg :jpg) (the raster-graphics))
                               (:raphael (the vector-graphics))))))
              (when (and (member (the image-format) (list :jpeg :jpg :png :raphael))
                         (the include-view-controls?))
                (htm (:tr (:td (str (the view-controls))))))
              (when (and (member (the image-format) (list :vrml :web3d))
                         (the include-view-controls?))
                (htm (:tr (:td (str (the image-format-selector html-string))))))


              ))))

  
  :hidden-objects
  ((view-object :type 'web-drawing
206
207
                :pass-down (projection-vector immune-objects background-color field-of-view-default raphael-canvas-id
					      zoom-factor-renderer)
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
                :page-length (the length)
                :page-width (the width)
                :objects (the display-list-objects)
                :object-roots (the display-list-object-roots))

   ("Object of type menu-form-control. Its value slot can be used to determine the format of image displayed."
    image-format-selector
    :type 'menu-form-control
    :size 1
    :prompt "Format" 
    :onchange (the (gdl-ajax-call :form-controls (list (the-child))))
    :choice-plist (the image-format-plist)
    :default (the image-format-default))

   
   (reset-zoom-button :type 'button-form-control
                      :label "Fit"
                      :onclick (the (gdl-ajax-call :function-key :reset-zoom!)))
   

   (view-selector :type 'menu-form-control
                  :size 1
                  :prompt "View"
                  :onchange (the (gdl-ajax-call :form-controls (list (the-child))))
                  :choice-list (plist-keys (the standard-views))
                  ;;:default :top
                  :default (the view-direction-default)
235
                  ))
Dave Cooper's avatar
Dave Cooper committed
236

237
238
  
  :functions
239
240
241
242
243
244
245
246
  (
   ;;
   ;; FLAG -- copied from base-html-graphics-sheet's logic for dig-point and report-point -- 
   ;;         factor out the repeated code!
   ;;
   ;; FLAG -- standardize on length instead of height for Y coord.
   ;;
   
247
248
249
   (model-x-y (local-x-y)
	      (when local-x-y
		(destructuring-bind (&key x y) local-x-y
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
		  (let ((x (- x (half (the view-object width))))
			(y (let ((y (- (the view-object length) y)))
			     (- y (half (the view-object length))))))
		    (let ((adjusted 
			   (scalar*vector 
			    (the view-object user-scale)
			    (add-vectors (make-point (get-x (the view-object user-center) )
						     (get-y (the view-object user-center)) 0)
					 (scalar*vector (/ (the view-object user-scale))
							(make-point x y 0))))))
		      (let ((model-point (the view-object main-view (model-point adjusted))))
			model-point))))))



   (reset-zoom!
266
    ()
Dave Cooper's avatar
Dave Cooper committed
267
268
269
270
271
272
273
274
275
276
    (the view-object (restore-slot-defaults! (list :user-center :user-scale))))

   ("Void. Writes an embedded X3D tag with content for the <tt>view-object</tt> child of this object. 
The <tt>view-object</tt> child should exist and be of type <tt>web-drawing</tt>."

    write-embedded-x3dom-world
    (&key (include-view-controls? nil))
    (write-the (embedded-x3dom-world :include-view-controls? include-view-controls?)))))


277
278
279
280
281
282
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
(define-lens (html-format base-ajax-graphics-sheet)()
  :output-functions
  ((main-view
    ()
    (with-cl-who ()
      ((:table :border (the viewport-border-default))
       (:tr (:td (str (the graphics)))))))
   
   (vector-graphics
    ()
    (with-cl-who ()
      (when (typep (the :view-object) 'null-part)
        (error "A valid :view-object of type web-drawing is 
required in the sheet to call the :raphael-canvas method."))
     
      (let ((no-graphics? (the no-graphics?)))
        
        (htm ((:div :id (the raphael-canvas-id)
                    :style 
                    (format nil "cursor: ~a; 
height: ~apx;
width: ~apx;
overflow:hidden; 
clip: rect(0px ~apx ~apx 0px); 
position: relative;
"
                            (if (the vector-graphics-onclick?)
                                "crosshair" "arrow")

                            (the view-object length)
                            (the view-object width)
                            (the view-object width)
                            (the view-object length))

                    :onclick (unless (or no-graphics?
                                         (not (the vector-graphics-onclick?)))
                               (the (gdl-ajax-call :function-key :dig-point))))
              (if no-graphics?
                  (htm ((:table :border 1 :cellspacing 0 :cellpadding 0 :bgcolor :white)
                        (:tr
                         ((:td :width (the :view-object :width) :height (the :view-object :length) 
                               :align :center :valign :center)
                          (:big (:b "No Graphics Object Specified"))))))
                (let ((raphael-string (the raphael-string)))
                  (htm ((:script :type "text/javascript")
                        (str raphael-string))))))))))
   
   
Dave Cooper's avatar
Dave Cooper committed
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
   ("Void. Writes an embedded X3D tag and included content for the <tt>view-object</tt> child of this object. 
The <tt>view-object</tt> child should exist and be of type <tt>web-drawing</tt>."

    embedded-x3dom-world
    (&key (include-view-controls? nil))
    
    (declare (ignore include-view-controls?))
    
    ;; (the (restore-slot-default! :js-to-eval))
    
    (cl-who:with-html-output (*stream*)
      
    (when (typep (the :view-object) 'null-part)
      (error "A valid :view-object of type web-drawing is required in the sheet 
to call the :write-embedded-x3d-world function."))
    
    (cond ((the no-graphics?)
	   #+nil
	   (and (null (the :view-object :object-roots))
                (null (the :view-object :objects)))
           (html-stream *stream* 
                        ((:table :cellspacing 0 :cellpadding 0 :bgcolor :white)
                         (:tr
                          ((:td :width (the :view-object :width) :height
                                (the :view-object :height) :align :center :valign :center)
                           (:big (:b "No Graphics Object Specified")))))))
          (t
352
353
354
355


	   (with-cl-who ()
	     (:p
356
357
358
359
360
361
362
363
364
365
366
367
	      ((:span :style "cursor: pointer;")
	       ((:|X3D| :id "the_element"
		  :swfpath "/static/3rdpty/x3dom/x3dom.swf"
		  ;;:width  "100%"
		  ;;:height  "100%"
		  :width (the view-object page-width)
		  :height (the view-object page-length)
		  )
		(:|Scene|
		  (with-format (x3d *stream*) 
		    (let ((*onclick-function* (the onclick-function)))
		      (write-the view-object cad-output)))))))
368
369
370
		
	     ((:script :type "text/javascript" 
		       :src "/static/3rdpty/x3dom/x3dom.js" :id "xdom_script"))
371
	     
372
373
374
375
376
377
378
379
	     (when (the x3dom-view-controls?)
	       (htm (:tr (:td ((:span :style "color: blue; cursor: pointer;" 
				      :onclick "document.getElementById('the_element').runtime.showAll();")
			       "Show All")))))))



	   #+nil
Dave Cooper's avatar
Dave Cooper committed
380
381
382
383
           (with-cl-who ()
             ((:table :cellspacing 0 :cellpadding 0)
              (:tr
               (:td
Dave Cooper's avatar
Dave Cooper committed
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
		(:p
		 ((:|X3D| :id "the_element"
		    :swfpath "/static/3rdpty/x3dom/x3dom.swf"
		    :width (the view-object page-width)
		    :height (the view-object page-length))
		  
		  (:|Scene|
		    (with-format (x3d *stream*) (write-the view-object cad-output)))))
		
		((:script :type "text/javascript" 
			  :src "/static/3rdpty/x3dom/x3dom.js" :id "xdom_script"))))

	      (when (the x3dom-view-controls?)
		(htm (:tr (:td ((:span :style "color: blue; cursor: pointer;" 
				       :onclick "document.getElementById('the_element').runtime.showAll();")
399
400
401
				"Show All")))))))

	   )))
Dave Cooper's avatar
Dave Cooper committed
402

403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
   (web3d-graphics
    ()
    
    (with-cl-who ()
      (cond ((and (null (the :view-object :object-roots)) (null (the :view-object :objects)))
             (htm ((:table :border 1 :cellspacing 0 :cellpadding 0 :bgcolor :white)
                   (:tr
                    ((:td :width (the :view-object :width) :height (the :view-object :length) 
                          :align :center :valign :center)
                     (:big (:b "No Graphics Object Specified")))))))
            
            (t (let ((vrml-url (the vrml-url)))
                 (htm ((:table :border 0 :cellspacing 0 :cellpadding 0)
                       (:tr
                        ((:td) ;;:bgcolor :yellow) --FLAG! -- SvdE @ 13-08-09 -- removed bgcolor to blend in with viewport
                         ((:embed :src vrml-url :width (the view-object page-width) 
                                  :vrml_dashboard "false"
                                  :height (the view-object page-length))))))))))))
   
   
   (raster-graphics
    ()
    (when (typep (the :view-object) 'null-part)
      (error "A valid :view-object of type web-drawing is 
required in the sheet to call the :write-geometry method."))
    (with-cl-who ()
      (cond ((and (null (the :view-object :object-roots)) (null (the :view-object :objects)))
             (htm ((:table :border 1 :cellspacing 0 :cellpadding 0 :bgcolor :white)
                   (:tr
                    ((:td :width (the :view-object :width) :height (the :view-object :length) 
                          :align :center :valign :center)
                     (:big (:b "No Graphics Object Specified")))))))
          
            ((typep (the image-url) 'error)
             (the (set-slot! :view-toggle nil))
             (write-the geometry-error))
          
            (t
             (let ((image-url (the image-url)))
               (htm ((:table :border 0 :cellspacing 0 :cellpadding 0)
                     (:tr
                      ((:td) ;;:bgcolor :yellow) --FLAG! -- SvdE @ 13-08-09 -- removed bgcolor to blend in with viewport
                       ((:img :id "myimage"
                              :style "cursor: crosshair;"
                              :src image-url 
                              :onclick (the (gdl-ajax-call :function-key :dig-point))
                              :border 0 :width (the :view-object :page-width) 
                              :height (the :view-object :page-length))))))))))))))