Commit b70908e8 authored by Dave Cooper's avatar Dave Cooper
Browse files

add svgpanzoom

parent 7f3c8458
Loading
Loading
Loading
Loading
Loading
+3 −1
Original line number Diff line number Diff line
@@ -30,4 +30,6 @@

(define-format svg (vector-graphics)
  :documentation (:author "David J Cooper Jr [Genworks]"
                  :description "Direct SVG for inline inclusion in a web page or application"))
                  :description "Direct SVG for inline inclusion in a web page or application")
  :slots ((id (string (gensym)))))
+48 −22
Original line number Diff line number Diff line
@@ -31,18 +31,27 @@
   (height 300)
   (image-format-default :svg)
   (vector-graphics-onclick? nil)
   (projection-vector (getf *standard-views* :trimetric)))
   (projection-vector (getf *standard-views* :trimetric))

  :computed-slots
  (;; FLAG drive this with a UI form-control
   (background-color (lookup-color (getf *colors-default* :background) :format :decimal))
   (foreground-color (lookup-color (getf *colors-default* :foreground) :format :decimal))

   ;; FLAG drive this with a UI form-control
   (image-format (the image-format-default))
   
   (inner-html (ecase (the image-format)
   )
   
  :computed-slots
  ((div-style (format nil "width: ~apx; height: ~apx;" (the width) (the height)))

   (inner-html (with-cl-who-string ()
                 (str (ecase (the image-format)
                        (:svg (the svg-content))
                        (:png (the png-content))
                        (:jpeg (the jpeg-content))
                        (:x3dom (the x3dom-content))
                        (:a-frame (the a-frame-content))))
                 (:script (str (the viewport-js-text)))))
   
   (svg-content (if (the no-graphics?)
                    (with-cl-who-string ()
@@ -50,14 +59,12 @@
                       (:p "No graphics objects specified")))
                    (with-error-handling ()
                      (with-cl-who-string ()
                        ((:div :id (format nil "svg-viewport-~a" (the base64-encoded-root-path))
                               :style (format nil "width: ~apx; height: ~apx;" (the width) (the height)))
                        (str (with-output-to-string (ss)
                               (with-format (svg ss
						 :id (the svg-id)
                                                 :background-color (the background-color)
                                                 :foreground-color (the foreground-color))
                                  (write-the view-object cad-output)))))))))

                                 (write-the view-object cad-output))))))))

   (png-content  "<p>PNG graphics not implemented yet</p>")
   (jpeg-content "<p>JPEG graphics not implemented yet</p>")
@@ -69,8 +76,24 @@
   (no-graphics? (and (null (the display-list-objects))
                      (null (the display-list-object-roots))))

   (background-color (lookup-color (getf *colors-default* :background) :format :decimal))
   (foreground-color (lookup-color (getf *colors-default* :foreground) :format :decimal)))
   (svg-id (string-append (the dom-id) "-svg-section"))

   (viewport-js-text
    (ecase (the image-format)
      (:svg
       (format nil "
if (document.getElementById('~a')) {
  panZoomSVG~a = svgPanZoom('#~a', {
    zoomEnabled: true,
    controlIconsEnabled: true,
    preventMouseEventsDefault: false,
    fit: true,
    minZoom: 0.01,
    maxZoom: 100,
    center: true
  });
};" (the svg-id) (the dom-id) (the svg-id)))
      ((:png :jpeg :x3dom :a-frame) ""))))
   
  :objects 
  ((view-object :type 'web-drawing
@@ -91,7 +114,8 @@
   (objects (list (the box-1))))
   
  :computed-slots
  ((body (with-lhtml-string ()
  ((use-svgpanzoom? t)
   (body (with-lhtml-string ()
          (:h1 "Test Page with Viewport")
          (:p "This page demonstrates the new viewport-html-div component:")
          (str (the view-1 div))
@@ -106,5 +130,7 @@
	   :display-list-objects (the objects))))



(publish-gwl-app "/test-view" 'test-viewport-page)
(with-all-servers
    (server)
    (publish-gwl-app "/test-view" 'test-viewport-page
		     :server server))
+1 −1
Original line number Diff line number Diff line
@@ -42,7 +42,7 @@
                                           (the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent)
                                                                      :respondent (the parent :respondent)))))
                          
                           ((:svg :id "svg-1" :viewBox (format nil "0 0 ~a ~a" width length)
                           ((:svg :id (format-slot id) :viewBox (format nil "0 0 ~a ~a" width length)
                                  :width width
                                  :class (the svg-class)
                                  :height length