Commit 92e5f63b authored by Dave Cooper's avatar Dave Cooper

updated for better x3dom behavior in growlr.

parent d2589088
This diff is collapsed.
......@@ -42,45 +42,6 @@
))
(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
(with-translated-state (:pdf (make-point (- (get-x view-center)) (- (get-y view-center))))
(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))
(write-the-object child-view (cad-output rotation))))))) (the views))))))))
#+nil
(define-lens (pdf base-drawing)()
:output-functions
((cad-output
......@@ -115,17 +76,11 @@
(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 ()
(let ((*dxf-entity-id* 107))
(mapc #'(lambda(view) (write-the-object view cad-output)) (the views))))))
(define-lens (pdf base-view)()
:output-functions
((cad-output
(&optional rotation)
()
(set-format-slot view self)
......@@ -134,22 +89,16 @@
(view-center (scalar*vector (the view-scale-total)
(keyed-transform*vector (the view-transform)
(the view-center)))))
(with-translated-state (:pdf center)
(pdf:rotate rotation)
;;
;; 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))
......@@ -166,6 +115,17 @@
(define-lens (dxf base-drawing)()
:output-functions
((cad-output ()
(let ((*dxf-entity-id* 107))
(mapc #'(lambda(view) (write-the-object view cad-output)) (the views))))))
(define-lens (dxf base-view)()
:output-functions
((cad-output
......
......@@ -34,6 +34,8 @@ a rendered perspective view, as in VRML.")
:input-slots
(
(camera-distance-discount 0.8)
"List of GDL Objects. Roots of the leaf objects to be displayed in this renderer view."
object-roots
......@@ -73,9 +75,11 @@ Defaults to 0.1 (which results in a near parallel projection with virtually no p
(matrix:transpose-matrix transform)))
(max-extent (max (- (get-x (second 2d-box)) (get-x (first 2d-box)))
(- (get-y (second 2d-box)) (get-y (first 2d-box)))))
(camera-distance
(* (+ (/ max-extent (tan (degree (the field-of-view-default))))
(getf (the bounding-sphere) :radius)) (/ (the zoom-factor-renderer)))))
(camera-distance
(* (the camera-distance-discount)
(* (+ (/ max-extent (tan (degree (the field-of-view-default))))
(getf (the bounding-sphere) :radius)) (/ (the zoom-factor-renderer)))))
)
(list key (list :point (translate-along-vector
(the 3d-box-center) vector camera-distance)
......
......@@ -56,7 +56,8 @@
(field-of-view (degree (getf viewpoint :field-of-view))))
(cl-who:htm
((:|Viewpoint|
((:|Viewpoint|
:|id| (format nil "view-~a" (string key))
:|position| (format nil "~a ~a ~a" (get-x position) (get-y position) (get-z position))
:|orientation| (format nil "~a ~a ~a ~a"
(get-x orientation)
......@@ -74,7 +75,7 @@
(plist-values (the viewpoints)))
(let ((background (lookup-color (the background-color))))
(cl-who:htm (:|Background| :|skyColor| (format nil "~a ~a ~a"
(cl-who:htm (:|background| :|skycolor| (format nil "~a ~a ~a"
(to-double-float (get-x background))
(to-double-float (get-y background))
(to-double-float (get-z background))))))
......
......@@ -173,12 +173,6 @@ 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 can be used to
include the x3dom tag content for the geometry."
x3dom-graphics
......@@ -204,14 +198,13 @@ bottom of the graphics inside a table."
(with-cl-who-string ()
(:table (:tr ((:td :align :center)
(str (ecase (the image-format-selector value)
;;((:web3d :vrml) (the web3d-graphics))
(:x3dom (the x3dom-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 :x3dom))
(when (and (member (the image-format) (list :x3dom))
(the include-view-controls?))
(htm (:tr (:td (str (the image-format-selector html-string))))))
......@@ -226,7 +219,34 @@ bottom of the graphics inside a table."
("List representing GDL root-path. This is the root path of the dragged and/or dropped object.
This is not tested to see if it is part of the same object tree as current self."
dropped-object nil :settable))
dropped-object nil :settable)
(viewport-script
(progn
(the inner-html)
(cond ((eql (the image-format-selector value) :x3dom)
(with-cl-who-string ()
(:div
((:script :type "text/javascript")
(fmt
"
function x3draw ()
{
x3dom.reload();
var elem = document.getElementById('view-~(~a~)');
if (elem) elem.setAttribute('set_bind', 'true');
//xruntime = document.getElementById('x3dom-1').runtime;
//xruntime.resetView();
}
if (x3dom.type != 'undefined') x3draw();
"
(the view-selector value)
)))))
(t "")))))
......@@ -416,81 +436,39 @@ to call the :write-embedded-x3d-world function."))
(the :view-object :height) :align :center :valign :center)
(:big (:b "No Graphics Object Specified")))))))
(t
(let ((*display-controls* (the display-controls-hash)))
(with-cl-who ()
(:p
((:span :style "cursor: pointer;")
((:|X3D| :id "the_element"
:swfpath "/static/3rdpty/x3dom/x3dom.swf"
;;:width "100%"
;;:height "100%"
:width (format nil "~apx" (the view-object page-width))
:height (format nil "~apx" (the view-object page-length))
)
(:|Scene|
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output)))))))
((:script :type "text/javascript")
;;"x3dom.reload(); document.getElementById('the_element').runtime.debug(true); document.getElementById('the_element').runtime.statistics(true); "
"x3dom.reload(); "
)
#+nil
(when (the x3dom-view-controls?)
(htm (:tr (:td ((:span :style "color: blue; cursor: pointer;"
:onclick "document.getElementById('the_element').runtime.showAll();")
"Show All"))))))))
#+nil
(with-cl-who ()
((:table :cellspacing 0 :cellpadding 0)
(:tr
(:td
(:p
((:|X3D| :id "the_element"
:swfpath "/static/3rdpty/x3dom/x3dom.swf"
:width (the view-object page-width)
:height (the view-object page-length))
(:span
((:|X3D| :id "x3dom-1" :style "background: #d3d3d3"
:width (format nil "~apx" (the view-object page-width))
:height (format nil "~apx" (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"))))
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.1"))
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))
((:script :type "text/javascript")
(when (the x3dom-view-controls?)
(htm (:tr (:td ((:span :style "color: blue; cursor: pointer;"
:onclick "document.getElementById('the_element').runtime.showAll();")
"Show All")))))))
;;"x3draw();"
#+nil
(fmt
"
x3dom.reload();
// document.getElementById('view-~(~a~)').setAttribute('set_bind', 'true');
// xruntime = document.getElementById('x3dom-1').runtime;
//xruntime.resetView();
"
(the view-selector value)
)
)))
)))))))
(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
()
......
......@@ -39,14 +39,25 @@
(with-html-output (*stream*)
((:div
:onmousedown (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))
:onmousedown (when (the parent vector-graphics-onclick?)
(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) :width width :height length
)
(with-translated-state (:svg (make-point (- (get-x view-center))
(- (get-y view-center))))
(write-the-object child-view cad-output))))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(write-the-object child-view cad-output)))
((:script :type "text/javascript")
"
var panZoomSVG1 = svgPanZoom('#svg-1', {
zoomEnabled: true,
controlIconsEnabled: true,
fit: true,
minZoom: 0.01,
maxZoom: 100,
center: true});"))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(the views))))))))
......
......@@ -215,7 +215,12 @@
:computed-slots
((security-ok? (the respondent root do-security-check))
(replace-lists (mapsend (the html-sections) :replace-list))
(html-sections-stale (remove-if-not #'(lambda(object) (the-object object stale?))
(list-elements (the html-sections))))
(replace-lists (mapsend (the html-sections-stale) :replace-list))
(html-section-objects (the respondent html-sections))
(mismatch? (< (length (the js-to-eval-previi)) (length (the replace-lists)))))
......@@ -241,26 +246,32 @@
(when *debug?* (print-variables (socket:remote-host (net.aserve:request-socket (the req)))))
(:document
(mapc #'(lambda(replace-pair js-to-eval-status)
(declare (ignore js-to-eval-status)) ;; this can play into the flag
(destructuring-bind (&key dom-id inner-html js-to-eval) replace-pair
(let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval "")))))
(when (or inner-html js-to-eval?)
(htm
(:html-section (:|replaceId| (str dom-id))
(:|newHTML| (str (if inner-html
(wrap-cdata (if (the security-ok?) inner-html
(with-cl-who-string ()
(:i "Security Error")))) "")))
(:|jsToEval| (str (if (and js-to-eval? (the security-ok?))
(wrap-cdata js-to-eval) "")))))))))
(the replace-lists) (the js-to-eval-previi)))))))))
(mapc #'(lambda(replace-pair js-to-eval-status)
(declare (ignore js-to-eval-status)) ;; this can play into the flag
(print-variables (base64-decode-safe (getf replace-pair :dom-id)))
(destructuring-bind (&key dom-id inner-html js-to-eval) replace-pair
(let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval "")))))
(when (or inner-html js-to-eval?)
(htm
(:html-section (:|replaceId| (str dom-id))
(:|newHTML| (str (if inner-html
(wrap-cdata (if (the security-ok?) inner-html
(with-cl-who-string ()
(:i "Security Error")))) "")))
(:|jsToEval| (str (if (and js-to-eval? (the security-ok?))
(wrap-cdata js-to-eval) "")))))))))
(the replace-lists) (the js-to-eval-previi)))))))))
(define-object html-replacement-section ()
:input-slots (section js-to-eval-previous)
:computed-slots ((status (the section (slot-status :inner-html)))
(js-status (the section (slot-status :js-to-eval)))
(stale? (or (eql (the status) :unbound)
(eql (the js-status) :unbound)))
......@@ -295,7 +306,7 @@ You can reload to get previous state" *ajax-timeout*))
(when *debug?* (print-variables (the stale?) (the section root-path)))
(when (the stale?)
(when t ;; (the stale?) ;; already filtering for stale? before calling now.
(list :dom-id (the dom-id)
:inner-html (the inner-html)
:js-to-eval (the js-to-eval)))))))
......
......@@ -194,9 +194,11 @@ Default nil."
use-jquery? nil :settable)
(use-raphael? nil)
(use-svgpanzoom? nil)
(use-x3dom? nil)
(use-fontawesome? nil)
(use-anyresize? nil)
(include-default-favicon? t)
......@@ -243,117 +245,135 @@ interface. Defaults to nil."
development-links
(with-cl-who-string () (write-the development-links))))
:objects ((standard-javascript-section
:type 'sheet-section
:js-to-eval :parse
:inner-html (with-cl-who-string (:indent t)
(when (the use-jquery?)
(htm
((:script :src "/static/3rdpty/jquery/js/jquery.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery-ui.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery.layout.min.js"))
((:script :src "/static/3rdpty/jquery/js/superfish.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery.bgiframe.js"))))
:objects
((standard-javascript-section
:type 'sheet-section
:js-to-eval :parse
:inner-html
(with-cl-who-string (:indent t)
(when (the use-jquery?)
(htm
((:script :src "/static/3rdpty/jquery/js/jquery.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery-ui.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery.layout.min.js"))
((:script :src "/static/3rdpty/jquery/js/superfish.min.js"))
((:script :src "/static/3rdpty/jquery/js/jquery.bgiframe.js"))))
(when (the use-x3dom?)
(htm ((:script :src (if (the local-assets?)
"/static/3rdpty/x3dom/x3dom.js"
"https://www.x3dom.org/download/1.7.2/x3dom.js")
:id "x3dom_script"))))
(when (the use-raphael?)
(htm ((:script :id "raphael-script"
:src (if (the local-assets?)
"/static/3rdpty/raphael/js/raphael-min.js"
"https://cdnjs.cloudflare.com/ajax/libs/raphael/2.2.7/raphael.min.js")))))
(when (the use-fontawesome?)
(htm ((:link :id "fontawesome-css"
:rel "stylesheet"
:href (if (the local-assets?)
"/static/3rdpty/fa/css/all.min.css"
"https://use.fontawesome.com/releases/v5.3.1/css/all.css")
:integrity (unless (the local-assets?)
"sha384-mzrmE5qonljUremFsqc01SB46JvROS7bZs3IO2EmfFsd15uHvIt+Y8vEf7N7fWAU")
:crossorigin "anonymous"))))
(when (the use-anyresize?)
(htm ((:script :id "anyresize-script"
:src (if (the local-assets?)
"/static/3rdpty/resize/any-resize-event.js"
"https://is.gd/sAeEPt")))))
((:script) (fmt "~%var gdliid = '~a';" (the instance-id)))
(when (the use-x3dom?)
(htm ((:script :src (if (the local-assets?)
"/static/3rdpty/x3dom/x3dom.js"
"https://www.x3dom.org/download/1.7.2/x3dom.js")
:id "x3dom_script"))
#+nil
((:link :href (if (the local-assets?)
"/static/3rdpty/x3dom/x3dom.css"
"https://www.x3dom.org/download/1.7.2/x3dom.css")
:rel "stylesheet"))))
(when (the use-raphael?)
(htm ((:script
:id "raphael-script"
:src (if (the local-assets?)
"/static/3rdpty/raphael/js/raphael-min.js"
"https://cdnjs.cloudflare.com/ajax/libs/raphael/2.2.7/raphael.min.js")))))
(when (the use-svgpanzoom?)
(htm ((:script
:id "svg-panzoom"
:src (if (the local-assets?)
"/static/3rdpty/svgpanzoom/svg-pan-zoom.min.js"
"https://cdn.jsdelivr.net/npm/svg-pan-zoom@3.5.0/dist/svg-pan-zoom.min.js")))))
(when (the use-fontawesome?)
(htm ((:link :id "fontawesome-css"
:rel "stylesheet"
:href (if (the local-assets?)
"/static/3rdpty/fa/css/all.min.css"
"https://use.fontawesome.com/releases/v5.3.1/css/all.css")
:integrity (unless (the local-assets?)
"sha384-mzrmE5qonljUremFsqc01SB46JvROS7bZs3IO2EmfFsd15uHvIt+Y8vEf7N7fWAU")
:crossorigin "anonymous"))))
(when (the use-anyresize?)
(htm ((:script :id "anyresize-script"
:src (if (the local-assets?)
"/static/3rdpty/resize/any-resize-event.js"
"https://is.gd/sAeEPt")))))
((:script) (fmt "~%var gdliid = '~a';" (the instance-id)))
((:script :src (if (the local-assets?)
"/static/gwl/js/gdlajax1593.js"
"https://genworks.com/static/gwl/js/gdlajax1593.js")))
((:script :src (if (the local-assets?)
"/static/gwl/js/gdlajax1593.js"
"https://genworks.com/static/gwl/js/gdlajax1593.js")))
(when (the ui-specific-layout-js)
(htm
((:script :type "text/javascript"
:src (the ui-specific-layout-js))))))))
(when (the ui-specific-layout-js)
(htm
((:script :type "text/javascript"
:src (the ui-specific-layout-js))))))))
:functions ((prepend-url-depth
(string)
(prepend-url-depth string (the url-depth)))
:functions ((prepend-url-depth
(string)
(prepend-url-depth string (the url-depth)))
(back-link
(&key (display-string "&lt;-Back"))
(w-c-w-s
()
((:a :href (the return-object url)) (str display-string))))
(back-link
(&key (display-string "&lt;-Back"))
(w-c-w-s
()
((:a :href (the return-object url)) (str display-string))))
(update-root! ()
(unpublish-instance-urls (the instance-id) (the url))
(the root update!)
(the url)
)
(reset-html-sections!
()
;;(the (restore-slot-default! :%html-sections%))
)
(update-root! ()
(unpublish-instance-urls (the instance-id) (the url))
(the root update!)
(the url)
)
(reset-html-sections!
()
;;(the (restore-slot-default! :%html-sections%))
)
(self-link
(&key (display-string (the strings-for-display))
(display-color nil)
(target nil)
(title nil)
class id
on-click
on-mouse-over on-mouse-out
local-anchor)
(with-cl-who-string ()
(write-the (self-link
:display-string display-string
:display-color display-color
:target target
:title title
:class class
:id id
:on-click on-click
:on-mouse-over on-mouse-over
:on-mouse-out on-mouse-out
:local-anchor local-anchor))))
(self-link
(&key (display-string (the strings-for-display))
(display-color nil)
(target nil)
(title nil)
class id
on-click
on-mouse-over on-mouse-out
local-anchor)
(with-cl-who-string ()
(write-the (self-link
:display-string display-string
:display-color display-color
:target target
:title title
:class class
:id id
:on-click on-click
:on-mouse-over on-mouse-over
:on-mouse-out on-mouse-out
:local-anchor local-anchor))))
(set-self ()
(if *break-on-set-self?*
(progn (set-self self)
(let ((*package* (symbol-package (the type)))) (break)))
(progn
(set-self self))))
("Void. This is a hook function which applications can use to restore automatically
(set-self ()
(if *break-on-set-self?*
(progn (set-self self)
(let ((*package* (symbol-package (the type)))) (break)))
(progn
(set-self self))))
("Void. This is a hook function which applications can use to restore automatically
from a saved snapshot file."
custom-snap-restore!
()
custom-snap-restore!
()
)
)
))
))
(define-lens (html-format base-ajax-sheet)()
......
......@@ -276,10 +276,8 @@ form-controls (default of these is also nil) will be respected. Default is nil."
(print-variables self)
(print-messages %html-section-root-paths%))
(let ((html-sections (copy-list (the %html-section-root-paths%))))
(the (set-slot! :%html-section-root-paths% (pushnew (the-object section root-path)
html-sections
:test #'equalp)
(let ((html-sections (reverse (copy-list (the %html-section-root-paths%)))))
(the (set-slot! :%html-section-root-paths% (reverse (pushnew (the-object section root-path) html-sections :test #'equalp))
;;:remember? nil
:warn-on-non-toplevel? nil)))
......@@ -456,7 +454,7 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
(main-div
()
(with-cl-who ()
((:div :id (the dom-id) :class (the div-class))
((:div :id (the dom-id) :class (the div-class))
(str (the inner-html)))))))
......
This diff is collapsed.
This diff is collapsed.
gwl/static/gwl/images/favicon.ico

7.23 KB | W: | H:

gwl/static/gwl/images/favicon.ico

4.58 KB | W: | H:

gwl/static/gwl/images/favicon.ico
gwl/static/gwl/images/favicon.ico
gwl/static/gwl/images/favicon.ico
gwl/static/gwl/images/favicon.ico
  • 2-up
  • Swipe
  • Onion skin
......@@ -85,7 +85,6 @@ function gdlAjax1 (params, asynch)
function gdlAjax (evt, params, asynch)
{
if (evt)
{
var target;
......@@ -152,8 +151,6 @@ function gdlUpdate (request) {