Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
gendl
gendl-patches
gendl-patches
Commits
91186569
Commit
91186569
authored
Nov 30, 2020
by
Dave Cooper
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
ready for new patches build
parent
ffb6f9b2
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
92 additions
and
3 deletions
+92
-3
source/gwl.lisp
source/gwl.lisp
+92
-3
No files found.
source/gwl.lisp
View file @
91186569
...
...
@@ -49,9 +49,6 @@
;;
;; Merged into devo 2020-08-17
;;
...
...
@@ -417,3 +414,95 @@ form-controls (default of these is also nil) will be respected. Default is nil."
(
setq
anything-changed?
(
glisp:set-settings
*settings*
))
(
start-gwl
)
anything-changed?
)))
(
in-package
:svg
)
(
#+
allegro
excl:without-package-locks
#-
allegro
progn
(
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
:style
(
format
nil
"background-color: ~a"
(
lookup-color
(
format-slot
background-color
)
:format
:hex
)))
(
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
)))))
(
the
views
)))))))))
(
in-package
:gwl
)
(
#+
allegro
excl:without-package-locks
#-
allegro
progn
(
define-object-amendment
base-ajax-graphics-sheet
()
:input-slots
((
viewport-js-text
(
case
(
the
image-format-selector
value
)
(
:x3dom
(
format
nil
"
function x3draw ()
{
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');
if (x3dom1) xruntime= x3dom1.runtime;
xruntime.resetView();
}
x3draw();
"
(
the
view-selector
value
)))
(
:svg
"
panZoomSVG1 = svgPanZoom('#svg-1', {
zoomEnabled: true,
controlIconsEnabled: true,
preventMouseEventsDefault: false,
fit: true,
minZoom: 0.01,
maxZoom: 100,
center: true});"
)))
(
viewport-script
(
progn
(
the
inner-html
)
(
cond
((
member
(
the
image-format-selector
value
)
(
list
:x3dom
:svg
))
(
with-cl-who-string
()
(
:div
((
:script
:type
"text/javascript"
)
(
str
(
the
viewport-js-text
))))))
(
t
""
))))
)))
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