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
gendl
Commits
c5c2357f
Commit
c5c2357f
authored
Jul 26, 2012
by
Dave Cooper
Browse files
added partial text-line support for x3d, added anchor support for x3d and x3dom.
parent
cfbf6c9e
Changes
16
Hide whitespace changes
Inline
Side-by-side
build/source/app.lisp
View file @
c5c2357f
...
...
@@ -64,6 +64,7 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(
asdf:map-systems
#'
asdf:clear-system
)
(
asdf:clear-output-translations
)
(
asdf:disable-output-translations
)
))
...
...
demos/robot/source/assembly.lisp
View file @
c5c2357f
...
...
@@ -192,7 +192,9 @@ to the src/ directory distributed with GDL.
arm-angle-right
arm-angle-left
pincer-distance-right
pincer-distance-left
)
pincer-distance-left
shininess
transparency
)
:computed-slots
((
display-controls
(
list
:color
:orange
:line-thickness
2
...
...
@@ -217,7 +219,18 @@ to the src/ directory distributed with GDL.
(
the
(
:face-normal-vector
:top
))))
:pass-down
(
head-angle
torso-type
arm-angle-right
arm-angle-left
pincer-distance-left
pincer-distance-right
))))
pincer-distance-left
pincer-distance-right
))
(
center-sphere
:type
'sphere
:radius
0.1
)
(
rob-text
:type
'general-note
:orientation
(
alignment
:top
(
the
(
face-normal-vector
:rear
)))
:strings
"Bob"
:center
(
the
center
))
))
(
define-object
robot-body
(
base-object
)
...
...
@@ -282,6 +295,9 @@ to the src/ directory distributed with GDL.
(
the
(
:face-normal-vector
:right
))
(
the
:head-angle
)
(
the
(
:face-normal-vector
:top
)))))
))
...
...
gdl/apps/tasty/source/assembly.lisp
View file @
c5c2357f
...
...
@@ -162,7 +162,9 @@ o filter inspector slots to local slots
:onclick-function
#'
(
lambda
(
object
)
(
the
(
gdl-ajax-call
:function-key
:perform-action!
:arguments
(
list
object
))))
:arguments
(
list
object
)
:one-arg?
(
member
(
the-child
image-format
)
(
list
:x3d
:x3dom
))
)))
:tatu-root
self
)
(
inspector
:type
'inspector
...
...
gdl/base/common/package.lisp
View file @
c5c2357f
...
...
@@ -234,7 +234,9 @@
#:write-the
#:write-the-object
#:xml-reader
#:^2
))
#:^2
#:*onclick-function*
))
(
defpackage
:gdl-toplevel
(
:use
))
(
defpackage
:gdl-rule
(
:size
25
)
(
:use
)
...
...
gdl/base/common/start-gdl.lisp
View file @
c5c2357f
...
...
@@ -131,6 +131,8 @@ And really this should be done in the post-load-form of your build."))
:directory
(
butlast
(
pathname-directory
glisp:*gdl-program-home*
))
:defaults
glisp:*gdl-program-home*
))
(
glisp:set-default-float-format
)
(
glisp:set-defpackage-behavior
)
;;
;; FLAG -- don't do this here. Don't want to mess up people's
...
...
@@ -145,7 +147,7 @@ And really this should be done in the post-load-form of your build."))
;;
;;(setq ql:*quicklisp-home* (merge-pathnames "quicklisp/" glisp:*gdl-home*))
;;
(
asdf:initialize-output-translations
)
(
glisp:set-default-package
)
...
...
gdl/base/rest/source/parameters.lisp
View file @
c5c2357f
...
...
@@ -283,3 +283,6 @@ Defaults to :error.")
"Boolean. Determines whether the system keeps track of previous slot values
(accessible with previous-value function) after bashings are done. Leave this
set to nil to improve memory performance."
)
(
defparameter
*onclick-function*
nil
)
gdl/geom-base/lenses/source/x3d.lisp
View file @
c5c2357f
...
...
@@ -24,10 +24,13 @@
(
define-format
x3d
(
vrml
))
(
defparameter
*onclick*
nil
)
(
define-lens
(
x3d
base-drawing
)()
:output-functions
((
cad-output
()
(
let
(
;;(req (when (find-package :gwl) (symbol-value (read-from-string "gwl:*req*"))))
)
...
...
@@ -148,7 +151,8 @@
(
:|Transform|
:translation
(
when
(
not
(
every
#'
zerop
(
list
x
y
z
)))
(
format
nil
"~3,7f ~3,7f ~3,7f"
x
y
z
))
:rotation
(
when
rotation
(
format
nil
"~3,7f ~3,7f ~3,7f ~3,7f"
(
get-x
rotation
)
(
get-y
rotation
)
(
get-z
rotation
)
(
get-w
rotation
)))
(
format
nil
"~3,7f ~3,7f ~3,7f ~3,7f"
(
get-x
rotation
)
(
get-y
rotation
)
(
get-z
rotation
)
(
get-w
rotation
)))
(
:|Group|
(
write-the
shape
))))))
(
scene
...
...
@@ -186,14 +190,10 @@
(
format
nil
"~3,7f ~3,7f ~3,7f ~3,7f"
(
get-x
rotation
)
(
get-y
rotation
)
(
get-z
rotation
)
(
get-w
rotation
))))
(
if
(
and
(
find-package
:gwl
)
(
symbol-value
(
read-safe-string
"gwl::*onclick-function*"
)))
(
cl-who:htm
((
:|Anchor|
:url
(
format
nil
"javascript:event=null;~a"
(
funcall
(
symbol-value
(
read-safe-string
"gwl::*onclick-function*"
))
self
)))
(
write-the
shape
)))
(
write-the
shape
)))
;;
;; FLAG -- revert to proper conditional
;;
(
write-the
shape
))
(
when
(
and
(
typep
self
'outline-specialization-mixin
)
(
not
(
ignore-errors
(
typep
self
(
read-from-string
"surf:surface"
))))
...
...
@@ -228,19 +228,29 @@
;;(rotation (matrix-to-rotation orientation))
(
x
(
get-x
center
))
(
y
(
get-y
center
))
(
z
(
get-z
center
)))
;;
;; FLAG -- factor out the redundant calls and call directly to
;; cad-output, which will itself call to the shape.
;;
(
cl-who:with-html-output
(
*stream*
nil
:indent
nil
)
((
:|Transform|
:|translation|
(
unless
(
every
#'
zerop
(
list
x
y
z
))
(
format
nil
"~3,7f ~3,7f ~3,7f"
x
y
z
)))
((
:|Transform|
:|rotation|
(
when
rotation
(
format
nil
"~3,7f ~3,7f ~3,7f ~3,7f"
(
get-x
rotation
)
(
get-y
rotation
)
(
get-z
rotation
)
(
get-w
rotation
))))
(
format
nil
"~3,7f ~3,7f ~3,7f ~3,7f"
(
get-x
rotation
)
(
get-y
rotation
)
(
get-z
rotation
)
(
get-w
rotation
)))
)
(
if
(
null
(
the
children
))
(
if
(
and
(
find-package
:gwl
)
(
symbol-value
(
read-safe-string
"gwl::*onclick-function*"
)))
(
if
(
and
(
find-package
:gwl
)
*onclick-function*
)
(
cl-who:htm
((
:|Anchor|
:url
(
format
nil
"javascript:
event=null;~a"
(
funcall
(
symbol-value
(
read-safe-string
"gwl::
*onclick-function*
"
))
self
)))
((
:|Anchor|
:url
(
format
nil
"javascript:
~a;"
(
funcall
*onclick-function*
self
)))
(
write-the
shape
)))
(
write-the
shape
))
...
...
@@ -403,10 +413,11 @@
(
with-corrected-orientation
(
:|Shape|
(
:|Appearance|
(
write-the
material-properties
))
(
:|Box|
:|size|
(
format
nil
"~a ~a ~a"
(
to-double-float
(
the
width
))
(
to-double-float
(
the
length
))
(
to-double-float
(
the
height
)))))))))
((
:|Box|
:|size|
(
format
nil
"~a ~a ~a"
(
to-double-float
(
the
width
))
(
to-double-float
(
the
length
))
(
to-double-float
(
the
height
))))))))))
...
...
@@ -465,3 +476,45 @@
(
the
ifs-array
)))))))))))
(
define-lens
(
x3d
text-line
)()
:output-functions
((
shape
()
(
let
((
font-size
(
the
character-size
)))
(
declare
(
ignore
font-size
))
(
cl-who:with-html-output
(
*stream*
nil
:indent
t
)
(
:|Shape|
(
:|Appearance|
(
write-the
material-properties
))
(
format
*stream*
"<Text string='\"~a\"' solid='false'>
<FontStyle size='1' justify='MIDDLE'></FontStyle>
</Text>"
(
the
%text-to-draw%
))))
#+
nil
(
cl-who:with-html-output
(
*stream*
nil
:indent
t
)
(
let
((
center
(
the
center
)))
(
setq
center
(
the
(
global-to-local
center
)))
(
cl-who:htm
((
:|Transform|
#+
nil
:|translation|
#+
nil
(
format
nil
"~3,7f, ~3,7f, ~3,7f"
(
-
(
get-x
center
))
(
-
(
get-y
center
))
(
-
(
get-z
center
)))
(
:|Shape|
(
:|Appearance|
(
write-the
material-properties
))
(
format
*stream*
"<Text string='~a' solid='false'>
</Text>"
(
the
%text-to-draw%
))
#+
nil
((
:|Text|
:|string|
(
the
%text-to-draw%
))
)))))))))))
gdl/geom-base/prereqs/source/parameters.lisp
View file @
c5c2357f
...
...
@@ -179,3 +179,5 @@ the value of this parameter at your own risk.")
(
push
#'
initialize-geom-base
*gdl-init-functions*
)
(
setq
cl-who:*attribute-quote-char*
#\"
)
\ No newline at end of file
gdl/gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
c5c2357f
...
...
@@ -343,24 +343,26 @@ to call the :write-embedded-x3d-world function."))
(
t
(
print-variables
(
the
onclick-function
))
(
with-cl-who
()
(
:p
((
:
|X3D|
:id
"the_element"
:swfpath
"/static/3rdpty/x3dom/x3dom.swf
"
;;:width "100%
"
;;:
height
"100%"
:width
(
the
view-object
page-width
)
:height
(
the
view-object
page-
leng
th
)
)
(
:|Scene|
(
with-format
(
x3d
*stream*
)
(
let
((
*onclick-function*
(
the
onclick-function
)))
(
write-the
view-object
cad-output
))))))
((
:
span
:style
"cursor: pointer;"
)
((
:|X3D|
:id
"the_element
"
:swfpath
"/static/3rdpty/x3dom/x3dom.swf
"
;;:
width
"100%"
;;:height "100%"
:width
(
the
view-object
page-
wid
th
)
:height
(
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"
:src
"/static/3rdpty/x3dom/x3dom.js"
:id
"xdom_script"
))
(
when
(
the
x3dom-view-controls?
)
(
htm
(
:tr
(
:td
((
:span
:style
"color: blue; cursor: pointer;"
:onclick
"document.getElementById('the_element').runtime.showAll();"
)
...
...
gdl/gwl-graphics/gwl/source/base-html-graphics-sheet.lisp
View file @
c5c2357f
...
...
@@ -22,9 +22,6 @@
(
in-package
:gwl
)
(
defparameter
*onclick-function*
nil
)
(
define-object
geometry-view-mixin
()
:input-slots
...
...
@@ -105,9 +102,10 @@
(
let
((
*onclick-function*
(
the
onclick-function
)))
(
let
((
*stream*
reply-stream
))
(
with-cl-who
()
(
:|scene|
(
with-format
(
x3d
reply-stream
:use-bsplines?
(
the
use-bsplines?
))
(
write-the
view-object
cad-output
))))))))))))
(
:|X3D|
(
:|Scene|
(
with-format
(
x3d
reply-stream
:use-bsplines?
(
the
use-bsplines?
))
(
write-the
view-object
cad-output
)))))))))))))
(
push
url
(
gethash
(
make-keyword
(
the
instance-id
))
*url-hash-table*
))
url
)
:uncached
)
...
...
gdl/gwl/ajax/source/base-ajax-sheet.lisp
View file @
c5c2357f
...
...
@@ -434,7 +434,11 @@ UI specific jQuery Layout JavaScript."
((
:script
:type
"text/javascript"
:src
"/static/3rdpty/jquery/js/jquery-ui-current.min.js"
))
;;
;; FLAG -- put this back after re-arranging tasty color schemes to avoid the invisible menus.
;;
#+
nil
((
:link
:rel
"stylesheet"
:href
"http://code.jquery.com/ui/1.8.21/themes/base/jquery-ui.css"
:media
"all"
))
((
:script
:type
"text/javascript"
...
...
gdl/gwl/ajax/source/skeleton-ui-element.lisp
View file @
c5c2357f
...
...
@@ -318,12 +318,84 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
function-key
arguments
form-controls
(
asynch?
t
))
(
asynch?
t
)
(
one-arg?
nil
)
)
(
let
((
string-1
(
the
(
encode-ajax-args
:bashee
bashee
:respondent
respondent
:function-key
function-key
:arguments
arguments
)))
(
string-2
(
let
((
string
(
if
form-controls
(
string-append
"&fields=' + "
(
format
nil
"encode64('(' + ~{~a~^ + ' ' + ~} + ')').replace(/=/g,'')"
(
mapcar
#'
(
lambda
(
form-control
)
(
when
*debug?*
(
print-variables
form-control
))
(
string-append
(
if
(
not
(
or
(
typep
form-control
'radio-form-control
)
(
typep
form-control
'menu-form-control
)))
(
format
nil
"'~s ' + "
(
the-object
form-control
field-name
))
""
)
(
or
(
typecase
form-control
(
radio-form-control
(
format
nil
"~{~a~^ + ~}"
(
mapcar
#'
(
lambda
(
n
)
(
format
nil
"' :|radio-~a-~a| (' + doublequote + document.getElementById('~a-~a').value + doublequote + ' ' + doublequote + document.getElementById('~a-~a').checked + doublequote + ')' "
(
the-object
form-control
field-name
)
n
(
the-object
form-control
id
)
n
(
the-object
form-control
id
)
n
))
(
list-of-numbers
0
(
1-
(
length
(
plist-keys
(
the-object
form-control
effective-choice-plist
))))))))
(
checkbox-form-control
(
format
nil
"doublequote + encode64(document.getElementById('~a').value).replace(/=/g,'') + doublequote + ' ~s-checkedp ' + doublequote + document.getElementById('~a').checked + doublequote"
(
the-object
form-control
id
)
(
the-object
form-control
field-name
)
(
the-object
form-control
id
)))
(
menu-form-control
(
format
nil
"collectMenuSelections(document.getElementById('~a'))"
(
the-object
form-control
id
))))
#+
nil
(
format
nil
"doublequote + document.getElementById('~a').value + doublequote"
(
the-object
form-control
id
))
(
format
nil
"doublequote + encode64(document.getElementById('~a').value).replace(/=/g,'') + doublequote"
(
the-object
form-control
id
)))))
(
ensure-list
form-controls
))))
"'"
)))
string
))
(
string-3
(
if
asynch?
"true"
"false"
)))
(
if
one-arg?
(
format
nil
"gdlAjax1('args=~a~a);"
string-1
string-2
)
(
format
nil
"gdlAjax(event,'args=~a~a,~a);"
string-1
string-2
string-3
)))
#+
nil
(
format
nil
"gdlAjax(event, 'args=~a~a, ~a);"
nil
"gdlAjax(event,'args=~a~a,~a);"
(
the
(
encode-ajax-args
:bashee
bashee
:respondent
respondent
:function-key
function-key
...
...
gdl/gwl/static/gwl/js/gdlajax.js
View file @
c5c2357f
...
...
@@ -78,7 +78,10 @@ return y;
}
function
gdlAjax1
(
params
)
{
gdlAjax
(
null
,
params
,
true
);
}
function
gdlAjax
(
evt
,
params
,
asynch
)
{
...
...
regression/source/general-note.lisp
0 → 100644
View file @
c5c2357f
(
in-package
:gdl-lift-tests
)
(
define-object
general-note-test
(
base-object
)
:objects
(
(
center-sphere
:type
'sphere
:radius
.1
)
(
box
:type
'box
:length
10
:width
10
:height
10
:display-controls
(
list
:transparency
0.7
:color
:orange
))
(
note
:type
'general-note
:display-controls
(
list
:color
(
list
.32
.54
.26
)
:specular-color
(
list
0.46
0.46
0.46
)
:ambient-intensity
0.0933
)
:strings
"Hey Now"
)
(
kid
:type
'general-note-kid
:center
(
translate
(
the
center
)
:rear
10
))
))
(
define-object
general-note-kid
(
base-object
)
:objects
((
center-sphere
:type
'sphere
:radius
.1
)
(
box
:type
'box
:length
10
:width
10
:height
10
:display-controls
(
list
:transparency
0.7
:color
:orange
))
(
note
:type
'general-note
:display-controls
(
list
:color
(
list
.32
.54
.26
)
:specular-color
(
list
0.46
0.46
0.46
)
:ambient-intensity
0.0933
)
:strings
"Hey Now"
)
))
\ No newline at end of file
surf/source/methods.lisp
View file @
c5c2357f
...
...
@@ -745,3 +745,20 @@
(
define-smlib-wrapper
make-extend-curve
(
curve
&key
distance
distance-type
extending-from
continuity
))
(
define-smlib-wrapper
approximated-compatible-curves
(
curve-list
&key
length
tolerance
))
(
define-smlib-wrapper
make-tx-assembly-instance
(
&key
name
))
(
define-smlib-wrapper
tx-assembly-add-subassembly
(
parent-assembly-instance-pointer
child-assembly-instance-pointer
))
(
define-smlib-wrapper
tx-assembly-add-brep
(
assembly-instance-pointer
native-brep
&key
name
red
green
blue
))
(
define-smlib-wrapper
tx-assembly-add-curve
(
assembly-instance-pointer
native-curve
&key
name
red
green
blue
))
(
define-smlib-wrapper
tx-assembly-add-point
(
assembly-instance-pointer
point
&key
name
red
green
blue
))
\ No newline at end of file
surf/source/views.lisp
View file @
c5c2357f
...
...
@@ -24,21 +24,6 @@
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
ql:quickload
:uffi
))
;;
;; FLAG -- make higher-level generic constructor for a translator assembly object
;;
(
defun
make-assembly-instance
(
&key
name
)
(
let
((
ai
(
smlib::tag-pointer
(
smlib::new-hwstdautoptr-hwassemblyinstance
)
'smlib::hwstdautoptr-hwassemblyinstance
)))
(
smlib::hwassemblyinstance-init
ai
(
uffi:with-cstring
(
cstring
name
)
cstring
)
(
uffi:with-cstring
(
cstring
name
)
cstring
))
(
smlib::finalize
ai
#'
(
lambda
(
obj
)
(
smlib::delete-hwstdautoptr-hwassemblyinstance
obj
)))
ai
))
(
define-lens
(
nurbs
vanilla-mixin
)()
:output-functions
...
...
@@ -49,7 +34,9 @@
(
write-the
cad-output-assembly-tree
))))
(
cad-output-assembly-tree
(
&optional
(
assembly-instance
(
let
((
assembly
(
make-assembly-instance
:name
(
the
strings-for-display
))))
(
cad-output-assembly-tree
(
&optional
(
assembly-instance
(
let
((
assembly
(
make-tx-assembly-instance
*geometry-kernel*
:name
(
the
strings-for-display
))))
(
set-format-slot
assembly
assembly
)
assembly
)))
...
...
@@ -61,19 +48,14 @@
;;
;; FLAG -- add object also in case there is actual geometry here.
;;
(
let
((
child-assembly-instance
(
make-assembly-instance
:name
(
the-object
child
strings-for-display
))))
(
let
((
child-assembly-instance
(
make-tx-assembly-instance
*geometry-kernel*
:name
(
the-object
child
strings-for-display
))))
(
write-the-object
child
(
cad-output-assembly-tree
child-assembly-instance
))
(
smlib::hwassembly-addsubassembly
(
smlib::hwstdautoptr-hwassemblyinstance-getassembly
assembly-instance
)
child-assembly-instance
)
#+
nil
(
let
((
new-one
(
smlib::tag-pointer
(
smlib::new-hwstdautoptr-hwassemblyinstance
)
'smlib::hwstdautoptr-hwassemblyinstance
)))
(
smlib::hwassemblyinstance-collapseunneededlevels
assembly-instance
new-one
)
(
setq
assembly-instance
new-one
))
(
tx-assembly-add-subassembly
*geometry-kernel*
assembly-instance
child-assembly-instance
))
)
;;
;; Add objects
...
...
@@ -100,28 +82,24 @@
:output-functions
((
cad-output-assembly
(
assembly-instance
)
(
let
((
color
(
lookup-color
(
getf
(
the
display-controls
)
:color
))))
(
smlib::hwassembly-addbrep
(
smlib::hwstdautoptr-hwassemblyinstance-getassembly
assembly-instance
)
(
the
%native-brep%
)
(
uffi:with-cstring
(
cstring
(
the
strings-for-display
))
cstring
)
(
to-double-float
(
get-x
color
))
(
to-double-float
(
get-y
color
))
(
to-double-float
(
get-z
color
)))))))
(
tx-assembly-add-brep
*geometry-kernel*
assembly-instance
(
the
%native-brep%
)
:name
(
the
strings-for-display
)
:red
(
get-x
color
)
:green
(
get-y
color
)
:blue
(
get-z
color
))))))
(
define-lens
(
nurbs
curve
)
()
:output-functions
((
cad-output-assembly
(
assembly-instance
)
(
let
((
color
(
lookup-color
(
getf
(
the
display-controls
)
:color
))))
(
smlib::hwassembly-addcurve
(
smlib::hwstdautoptr-hwassemblyinstance-getassembly
assembly-instance
)
(
the
native-curve-iw
)
(
uffi:with-cstring
(
cstring
(
the
strings-for-display
))
cstring
)
(
to-double-float
(
get-x
color
))
(
to-double-float
(
get-y
color
))
(
to-double-float
(
get-z
color
)))))))
(
tx-assembly-add-curve
*geometry-kernel*
assembly-instance
(
the
native-curve-iw
)
:name
(
the
strings-for-display
)
:red
(
get-x
color
)
:green
(
get-y
color
)
:blue
(
get-z
color
))))))
...
...
@@ -129,16 +107,12 @@
:output-functions
((
cad-output-assembly
(
assembly-instance
)
(
let
((
color
(
lookup-color
(
getf
(
the
display-controls
)
:color
))))
(
smlib::hwassembly-addpoint
(
smlib::hwstdautoptr-hwassemblyinstance-getassembly
assembly-instance
)
(
smlib::iw-make-point3d
(
get-x
(
the
center
))
(
get-y
(
the
center
))
(
get-z
(
the
center
)))
(
uffi:with-cstring
(
cstring
(
the
strings-for-display
))
cstring
)
(
to-double-float
(
get-x
color
))
(
to-double-float
(
get-y
color
))
(
to-double-float
(
get-z
color
)))))))
(
tx-assembly-add-point
*geometry-kernel*
assembly-instance
(
the
center
)
:name
(
the
strings-for-display
)
:red
(
get-x
color
)
:green
(
get-y
color
)