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

rejiggering geysr to work with end-user apps e.g. cbi-tank

parent f2894b19
......@@ -69,7 +69,11 @@ x 1. Update welcome message to reflect empty object and refer to File->New.
(:p (fmt
"Geysr is for inspecting Genworks GDL models
while you're developing them. You can see your
model structure in the tree at the upper left.")))))
model structure in the tree at the upper left."))))
(menu-div-class nil)
(menu-div-style nil)
)
:computed-slots
......@@ -200,6 +204,8 @@ x 1. Update welcome message to reflect empty object and refer to File->New.
(str (if (the user-mode?) (the user-inputs main-div)
(the inspector main-div)))))
(menu :type 'menu
:div-class (the menu-div-class)
:div-style (the div-style)
:pass-down (design-mode? local-assets? click-mode expand-mode)
:user-mode? (the user-mode?-default)
:set-click-mode-func #'(lambda(mode) (the (set-slot! :click-mode mode)))
......@@ -382,243 +388,8 @@ x 1. Update welcome message to reflect empty object and refer to File->New.
;;
;; FLAG -- get rid of patches below on next rebuild!
;;
;; Following is confirmed merged.
(in-package :svg)
#+nil
(excl:without-redefinition-warnings
(excl:without-package-locks
(define-lens (svg base-drawing)()
:output-functions
((cad-output
()
(let ((view-center (if (the user-center)
(scalar*vector (the user-scale) (the user-center))
(make-point 0 0 0))))
(with-format-slots (view)
(let ((parent-scale (when view (the-object view view-scale-total))))
(mapc #'(lambda(child-view)
(let ((old-scale (the-object child-view user-scale)))
(when parent-scale (the-object child-view (set-slot! :user-scale parent-scale)))
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(with-html-output (*stream*)
((:div
:width "100%" :height "100%"
: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)))
((:script :type "text/javascript")
"
panZoomSVG1 = svgPanZoom('#svg-1', {
zoomEnabled: true,
controlIconsEnabled: true,
preventMouseEventsDefault: false,
fit: true,
minZoom: 0.01,
maxZoom: 100,
center: true});"))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(the views))))))))
(define-lens (svg geom-base::view-object-cache)()
:output-functions
((lines-and-curves
()
(unless (zerop (length (the vertex-array-2d-scaled)))
(let ((object (the object))
(2d-vertices
(unless (the path-info-2d-scaled)
(map 'vector #'(lambda(vertex)
(let ((point
(add-vectors (subseq vertex 0 2)
geom-base:*svg-translation*)))
(make-point (get-x point)
(- (the length) (get-y point)))))
(the vertex-array-2d-scaled))))
(path-info (when (the path-info-2d-scaled)
(mapcar #'(lambda(component)
(if (keywordp component) component
(let ((point
(add-vectors component geom-base:*svg-translation*)))
(make-point (get-x point)
(- (the length) (get-y point))))))
(the path-info-2d-scaled)))))
(let ((line-index-pairs (when 2d-vertices (the-object object %line-vertex-indices%)))
(curve-index-quadruples (when 2d-vertices (the-object object %curve-vertex-indices%)))
(display-controls (or (geom-base::find-in-hash object *display-controls*)
(the object display-controls)))
#+nil ;; FLAG -- do we need some kind of unique ID? If so, this name is too long, find something else.
(name (base64-encode-safe
(format nil "~s~s"
(the-object object root-path)
(the root-path)))))
(let ((line-path-string (write-the (line-path-string line-index-pairs 2d-vertices)))
(curve-path-string (write-the (curve-path-string curve-index-quadruples 2d-vertices)))
(other-path-string (write-the (other-path-string path-info)))
(stroke-linejoin (getf display-controls :stroke-linejoin "round"))
(stroke (or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex)))
(fill (or (when (getf display-controls :fill-color)
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex) "transparent"))
(stroke-width (let ((value (getf display-controls :line-thickness)))
(when value (setq value (number-round value 4))) (or value 1.0)))
(onclick (cond ((the object onclick-function)
(the parent parent parent ;; FLAG -- pass this in!
(gdl-ajax-call :function-key :call-onclick-function!
:arguments (list object))))
((and (defaulting (the viewport)) (eql (the viewport digitation-mode) :select-object))
(the viewport (gdl-ajax-call :function-key :set-object-to-inspect!
:arguments (list object))))
(t nil))))
(when (or line-path-string curve-path-string other-path-string)
(with-html-output (*stream*)
((:path :d (string-append line-path-string curve-path-string other-path-string)
;;:vector-effect "non-scaling-stroke"
:stroke-linejoin stroke-linejoin
:stroke stroke :fill fill :stroke-width stroke-width
:onclick onclick
:onmouseover (format nil "this.style.strokeWidth = ~a;" (* stroke-width 3))
:onmouseout (format nil "this.style.strokeWidth = ~a;" stroke-width))
(:title (str (one-line
(format nil "~s" (cons 'the (let ((root-path (reverse (the object root-path))))
(if (eql (first root-path) :root-object-object)
(rest root-path) root-path)))))))))))))))))
))
;;
;; FLAG -- below is merged into main codebase now!
;;
(in-package :gwl)
#+nil
(excl:without-package-locks
(excl:without-redefinition-warnings
;;
;; merged.
;;
(define-object-amendment base-ajax-graphics-sheet ()
:computed-slots
((svg-string (if (the no-graphics?)
(with-cl-who-string ()
((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message))))
(with-error-handling ()
(with-output-to-string (ss)
(with-format (svg ss
:background-color (the background-color)
:foreground-color (the foreground-color))
(write-the view-object cad-output))))))))
;;
;; merged.
;;
(define-lens (html-format base-ajax-graphics-sheet)()
:amend? t
:output-functions
(
;;
;; merged.
;;
("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))
(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 :write-embedded-x3d-world function."))
(cond ((the no-graphics?)
(htm
((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message)))))
(t
(let ((*display-controls* (the display-controls-hash)))
(htm
(: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|
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
))
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))))))))
;;
;; merged.
;;
(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 ((the no-graphics?)
(htm ((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message)))))
((typep (the image-url) 'error)
(the (set-slot! :view-toggle nil))
(write-the geometry-error))
(t
(let ((image-url (the image-url)))
(htm ((: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)))))))))))))
......@@ -59,7 +59,8 @@
:computed-slots ((root-object-type (read-from-string "wbl::glider"))))
(defun win-pathname-string-to-ux (string)
(glisp:replace-regexp string "\\" "/"))
(let ((result (glisp:replace-regexp string "\\" "/")))
(subseq result 0 (1- (length result)))))
(defparameter *home* (make-pathname :name nil :type nil :defaults *load-pathname*))
......@@ -76,7 +77,8 @@
(probe-file (merge-pathnames "../geysr-static/" *home*)))))))
(print-variables static)
(setq static (win-pathname-string-to-ux (subseq static 0 (1- (length static)))))
;;(setq static (win-pathname-string-to-ux (subseq static 0 (1- (length static)))))
(setq static (win-pathname-string-to-ux static))
(print-variables static)
(with-all-servers (server)
......
......@@ -24,7 +24,7 @@
(define-object menu-node ()
:input-slots ((label "TBD")
(title (unless (the child-nodes) "This operation is not implemented yet..."))
(title (unless (the %child-nodes) "This operation is not implemented yet..."))
(id (glisp:replace-regexp
(glisp:replace-regexp
(glisp:replace-regexp
......@@ -37,54 +37,66 @@
(1+ (the parent depth)))))
:computed-slots ((child-nodes
:computed-slots ((%child-nodes
(remove-if-not
#'(lambda(child)
(typep child 'menu-node)) (the children)))
)
(html (with-cl-who-string (:indent t)
(cond ((and (the child-nodes) (zerop (the depth)))
(htm ((:nav :id (the id))
(str (the ul)))))
:functions
((html
(&optional menu-name)
(with-cl-who-string (:indent t)
(let* ((key (make-keyword menu-name))
(child-nodes (if menu-name
(remove-if-not #'(lambda(child)
(eql (first (the-object child root-path)) key))
(the %child-nodes))
(the %child-nodes))))
(cond ((and child-nodes (zerop (the depth)))
(htm ((:nav :id (the id))
(str (the (ul child-nodes))))))
((the child-nodes)
(htm (str (the ul))))
(child-nodes
(htm (str (the (ul child-nodes)))))
(t (htm ((:li :onmouseover "hideMenus(event);")
((:a :href "#"
:class "inactive"
:title (the title)) (str (the label))))))))))
(t (htm ((:li :onmouseover "hideMenus(event);")
((:a :href "#"
:class "inactive"
:title (the title)) (str (the label)))))))))
(ul (with-cl-who-string (:indent t)
((:ul
:id (the id)
:onmouseover
(unless (zerop (the depth))
(format nil "addVisible(event, ~a);" (the depth))))
(ul (child-nodes)
(with-cl-who-string (:indent t)
((:ul
:id (the id)
:onmouseover
(unless (zerop (the depth))
(format nil "addVisible(event, ~a);" (the depth))))
(dolist (child (the child-nodes))
(if (the-object child child-nodes)
(htm ((:li :id (the-object child id)
:tabindex "0"
:onmouseover "hideMenus(event);"
:onclick (when (zerop (the depth))
"makeMenuBarHoverable(event);"))
(dolist (child child-nodes)
(if (the-object child %child-nodes)
(htm ((:li :id (the-object child id)
:tabindex "0"
:onmouseover "hideMenus(event);"
:onclick (when (zerop (the depth))
"makeMenuBarHoverable(event);"))
((:a :href "#" :id (format nil "a ~a" (the-object child id))
:title (the-object child title))
((:a :href "#" :id (format nil "a ~a" (the-object child id))
:title (the-object child title))
(str (the-object child label))
(str (the-object child label))
(when (>= (the-object child depth) 2)
(htm ((:span :class "menu-right-icon")
((:i :class "fas fa-caret-right"))))))
(str (the-object child html))))
(str (the-object child html))))))))
(when (>= (the-object child depth) 2)
(htm ((:span :class "menu-right-icon")
((:i :class "fas fa-caret-right"))))))
(str (the-object child html))))
(str (the-object child html)))))))
:functions
((set-new-geysr-object!
(set-new-geysr-object!
(object-type)
(the menu-object geysr (set-new-geysr-object! object-type)))))
......
......@@ -111,14 +111,17 @@ function addVisible(event, level)
(inner-html (with-cl-who-string ()
(the force-refresh)
(str (the nav-html))))
(str (the nav-html)))))
(nav-html (the nav html)))
:objects ((nav :type 'geysr-nav :pass-down (menu-object design-mode? local-assets?)))
:functions
((toggle-force-refresh! () (the (set-slot! :force-refresh (not (the force-refresh)))))
((nav-html
(&optional menu-name)
(the nav (html menu-name)))
(toggle-force-refresh! () (the (set-slot! :force-refresh (not (the force-refresh)))))
(set-click-mode! (mode) (funcall (the set-click-mode-func) mode))
(reset-zoom! () (funcall (the reset-zoom-func)) (the toggle-force-refresh!))
(clear! () (funcall (the clear-func)) (the toggle-force-refresh!))
......
......@@ -67,6 +67,28 @@
:computed-slots
(
;;
;; For testing
;;
#+nil
(menu-html (with-cl-who-string ()
(:style ".view-menu
{
display: none;
position: absolute;
z-index: 10;
}
.view-menu--active{
display: block;
}
")
((:nav :class "menu context-menu"
:id "menu")
((:ul :id "menu" :class "menu")
((:li :onclick (the (gdl-ajax-call :function-key :set-view! :arguments (list :top)))) "top")
(:li "left")))))
(empty? (not (or (the display-list-object-roots)
(the display-list-objects))))
#+nil
......@@ -75,9 +97,6 @@
(otherwise 1)))
(recompute? nil :settable)
(respondent (the geysr))
......@@ -98,13 +117,53 @@
;;(operations-list nil :settable)
(viewport-js-text
(case (the image-format-selector value)
(:x3dom
(format nil "
function x3draw ()
{
console.log('running x3draw for view-~(~a~)');
if (x3dom.type != 'undefined') x3dom.reload();
var elem = document.getElementById('view-~(~a~)');
if (elem) elem.setAttribute('set_bind', 'true');
var x3dom1 = document.getElementById('x3dom-1');
var xruntime;
if (x3dom1) xruntime= x3dom1.runtime;
if (xruntime) xruntime.resetView(); // FLAG -- remember user specified view and set to that.
if (xruntime) xruntime.fitAll(xruntime.getSceneBBox().min, xruntime.getSceneBBox().max);
}
x3draw();
console.log('Done running x3draw');
" (the view-selector value) (the view-selector value)))
(:svg
"
if (document.getElementById('svg-1'))
{
panZoomSVG1 = svgPanZoom('#svg-1', {
zoomEnabled: true,
controlIconsEnabled: true,
preventMouseEventsDefault: false,
fit: true,
minZoom: 0.01,
maxZoom: 100,
center: true});
};")))
)
:functions
(
;;
......@@ -288,31 +347,58 @@
(define-lens (html-format viewport)()
:output-functions
(
(inner-html
()
(("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>."
(with-cl-who ()
(let ((*display-controls* (the display-controls-hash)))
(let ((image-format (the image-format)))
(ecase image-format
(:links (the (write-geometry-links)))
(:svg (write-the svg-vector-graphics))
(:raphael (write-the vector-graphics))
((:png :jpeg) (write-the raster-graphics))
(:x3dom (the (write-embedded-x3dom-world :include-view-controls? nil)))))))
embedded-x3dom-world
(&key (include-view-controls? nil))
(declare (ignore include-view-controls?))
;; (the (restore-slot-default! :js-to-eval))
(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 :write-embedded-x3d-world function."))
(cond ((the no-graphics?)
(htm
((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message)))))
(t
(let ((*display-controls* (the display-controls-hash)))
(htm
((:span :id "x3d-viewport")
((:|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|
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
))
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output)))))
)
))))))
#+nil
(inner-html
()
(with-cl-who ()
(let ((*display-controls* (the display-controls-hash)))
(let ((image-format (if (the 2d-boxes?) (the image-format) :png)))
(ecase image-format
(ecase image-format
(:links (the (write-geometry-links)))
(:svg (write-the svg-vector-graphics))
(:raphael (write-the vector-graphics))
(:raphael )
((:png :jpeg) (write-the raster-graphics))
(:x3dom (the (write-embedded-x3dom-world :include-view-controls? nil))))))))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment