Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
tutorials
Commits
ce05d7b7
Commit
ce05d7b7
authored
Jan 28, 2021
by
Dave Cooper
Browse files
rejiggering geysr to work with end-user apps e.g. cbi-tank
parent
f2894b19
Changes
5
Hide whitespace changes
Inline
Side-by-side
geysr/source/assembly.gdl
View file @
ce05d7b7
...
...
@@ -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
-
2
d
-
scaled
)))))
(
let
((
line
-
index
-
pairs
(
when
2
d
-
vertices
(
the
-
object
object
%
line
-
vertex
-
indices
%)))
(
curve
-
index
-
quadruples
(
when
2
d
-
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
2
d
-
vertices
)))
(
curve
-
path
-
string
(
write
-
the
(
curve
-
path
-
string
curve
-
index
-
quadruples
2
d
-
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
)))))))))))))
geysr/source/initialize.gdl
View file @
ce05d7b7
...
...
@@ -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)
...
...
geysr/source/menu-node.gdl
View file @
ce05d7b7
...
...
@@ -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)))))
...
...
geysr/source/menu.gdl
View file @
ce05d7b7
...
...
@@ -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!))
...
...
geysr/source/viewport.gdl
100644 → 100755
View file @
ce05d7b7
...
...
@@ -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))))))))))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment