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
facad824
Commit
facad824
authored
Jul 12, 2013
by
Dave Cooper
Browse files
merged svg-dd into this branch for website demo deployment
parents
2714fc0a
b0df745f
Changes
22
Expand all
Hide whitespace changes
Inline
Side-by-side
apps/tasty/source/assembly.lisp
View file @
facad824
...
...
@@ -163,7 +163,7 @@ o filter inspector slots to local slots
(
the
(
gdl-ajax-call
:function-key
:perform-action!
:arguments
(
list
object
)
:
one-arg
?
(
member
(
the-child
image-format
)
(
list
:x3d
:x3dom
))
:
null-event
?
(
member
(
the-child
image-format
)
(
list
:x3d
:x3dom
))
)))
:tatu-root
self
)
...
...
apps/tasty/source/viewport.lisp
View file @
facad824
...
...
@@ -69,8 +69,10 @@
(
use-bsplines?
(
the
use-bsplines-checkbox
value
))
#+
nil
(
js-to-eval
(
when
(
eql
(
the
image-format
)
:raphael
)
(
the
raphael-string
)))
(
recompute?
nil
:settable
)
...
...
base/rest/source/utilities.lisp
View file @
facad824
...
...
@@ -514,9 +514,10 @@ CL \"fround\" function.
,
(
readable-expression
(
nreverse
vals
)
self
))
ht
)))
(
defmethod
readable-expression
((
object
cons
)
&optional
self
)
(
with-error-handling
(
:timeout
nil
)
`
(
list
,@
(
mapcar
#'
(
lambda
(
expr
)
(
readable-expression
expr
self
))
object
))))
(
with-error-handling
(
:timeout
nil
)
`
(
list
,@
(
mapcar
#'
(
lambda
(
expr
)
(
readable-expression
expr
self
))
object
))))
(
defmethod
readable-expression
((
object
number
)
&optional
self
)
(
declare
(
ignore
self
))
object
)
(
defmethod
readable-expression
((
object
string
)
&optional
self
)
(
declare
(
ignore
self
))
object
)
...
...
base/rest/source/vanilla-mixin.lisp
View file @
facad824
...
...
@@ -689,10 +689,10 @@ by the update."
(
the
(
message-list
:category
:required-input-slots
))
(
the
(
message-list
:category
:defaulted-input-slots
))))
result
)
(
mapc
#'
(
lambda
(
slot
)
(
let
((
contents
(
funcall
(
read-from-string
(
format
nil
"gdl-acc::~a"
slot
))
self
)
))
(
when
(
and
(
not
(
member
slot
'
(
:%name%
:%parent%
:%aggregate%
:%index%
:$$tatu-object
)))
(
consp
contents
)
(
third
contents
))
(
push
slot
result
)
(
push
(
readable-expression
(
first
contents
)
self
)
result
))))
inputs
)
(
unless
(
member
slot
'
(
:%name%
:%parent%
:%aggregate%
:%index%
:$$tatu-object
))
(
let
((
contents
(
funcall
(
read-from-string
(
format
nil
"gdl-acc::~a"
slot
))
self
)))
(
when
(
and
(
consp
contents
)
(
third
contents
))
(
push
slot
result
)
(
push
(
readable-expression
(
first
contents
)
self
)
result
))))
)
inputs
)
(
nreverse
result
)))
...
...
documentation/tutorial/examples/4-bar-assembly.gdl
0 → 100644
View file @
facad824
(gwl:define-package :4-bar (:export #:assembly #:dd))
(in-package :4-bar)
(define-object dd (base-ajax-sheet base-object)
:computed-slots ((use-raphael? t)
(main-sheet-body (with-cl-who-string ()
(str (the development-links))
(str (the main-area main-div))
(str (the drop-coord-section main-div))))
(dropped-x-y (the main-area dropped-x-y)))
:objects ((assembly :type 'assembly
:input-link-angle-d (if (the dropped-x-y)
(angle-between-vectors-d (the (face-normal-vector :right))
(subtract-vectors (the dropped-x-y)
(the assembly ground-2))
(the (face-normal-vector :top)))
90)))
:hidden-objects ((drop-coord-section :type 'sheet-section
:inner-html (with-cl-who-string ()
(str (the main-area dropped-x-y))))
(main-area :type 'base-ajax-graphics-sheet
:respondent self
:vector-graphics-onclick? nil
:length 500 :width 500
;;:projection-vector (getf *standard-views* :top)
:display-list-object-roots (list (the assembly)))))
(define-object assembly (base-object)
:input-slots
((ground-link-length 15 :settable)
(grounded-link-1-length 8 :settable)
(grounded-link-2-length 5 :settable)
(coupler-link-length 15 :settable)
(coupler-angle-1-d 30 :settable)
(coupler-length-1 10 :settable)
(input-link-index 1 :settable)
(input-link-angle-d 90 :settable)
(angle-increment 10 :settable))
:computed-slots
((input-link-angle (degree (the input-link-angle-d)))
(coupler-angle-1 (degree (the coupler-angle-1-d)))
(ground-1 (translate (the center) :left (half (the ground-link-length))))
(ground-2 (translate (the center) :right (half (the ground-link-length))))
(follower-link-circle (the (grounded-link-circles (- 1 (the input-link-index)))))
(follower-link-ends (mapcar #'(lambda(flag)
(inter-circle-sphere (the input-link-circle center)
(the input-link-circle radius)
(the input-link-circle
(face-normal-vector :top))
(the follower-link-circle center)
(the follower-link-circle radius)
flag))
(list t nil)))
(follower-link-angles (mapcar #'(lambda(point)
(angle-between-vectors
(the follower-link-circle (face-normal-vector :right))
(subtract-vectors point
(the follower-link-circle center))
(the follower-link-circle (face-normal-vector :top))))
(the follower-link-ends)))
(follower-link-angle (apply #'min (the follower-link-angles)))
(follower-link-end (if (near-to? (first (the follower-link-angles))
(the follower-link-angle))
(first (the follower-link-ends))
(second (the follower-link-ends))))
(links (list (the ground-link) (the (grounded-links 0)) (the (grounded-links 1))
(the coupler-link)))
(sorted-links (safe-sort (the links) #'<
:key #'(lambda(link) (the-object link length))))
(shortest-link (first (the sorted-links)))
(longest-link (lastcar (the sorted-links)))
(p-link (second (the sorted-links)))
(q-link (third (the sorted-links)))
(crank-rocker? (and (eql (the grashof-classification) :type-1)
(or (eql (the shortest-link) (the (grounded-links 0)))
(eql (the shortest-link) (the (grounded-links 1))))))
(double-crank? (eql (the shortest-link) (the ground-link)))
(double-rocker? (eql (the shortest-link) (the coupler-link)))
(grashof-classification (cond ((< (+ (the shortest-link length)
(the longest-link length))
(+ (the p-link length)
(the q-link length))) :type-1)
((> (+ (the shortest-link length)
(the longest-link length))
(+ (the p-link length)
(the q-link length))) :type-2)
(t :neutral))))
:hidden-objects
((scratch :type 'assembly
:pass-down (angle-increment
ground-link-length grounded-link-1-length
grounded-link-2-length coupler-link-length
coupler-angle-1-d coupler-length-1
input-link-index input-link-angle-d)))
:objects
(
(follower-link-sphere :type 'sphere
:center (the follower-link-circle center)
:radius (the follower-link-circle radius))
(input-link-circle :type 'circle
:radius (the coupler-link-length)
:center (the (grounded-links (the input-link-index)) end))
(grounded-link-circles :type 'circle
:sequence (:size 2)
:radius (ecase (the-child index)
(0 (the grounded-link-1-length))
(1 (the grounded-link-2-length)))
:center (ecase (the-child index)
(0 (the ground-1))
(1 (the ground-2))))
(ground-link :type 'c-cylinder :radius 0.3
:start (the ground-1) :end (the ground-2)
:display-controls (list :line-thickness 2))
(pivot-1 :type 'cylinder
:center (the ground-link start)
:radius (the ground-link radius)
:length 0.5
:display-controls (list :line-thickness 3)
:orientation (alignment :front (the (face-normal-vector :top))))
(pivot-2 :type 'cylinder
:center (the ground-link end)
:radius (the ground-link radius)
:length 0.5
:display-controls (list :line-thickness 3)
:orientation (alignment :front (the (face-normal-vector :top))))
(grounded-links :type 'c-cylinder
:radius (the ground-link radius)
:sequence (:size 2)
:display-controls (list :color (ecase (the-child index)
(0 :red) (1 :green))
:line-thickness 2
:drag-controls :drag-and-drop)
:circle (the (grounded-link-circles (the-child index)))
:pseudo-inputs (circle)
:start (the-child circle center)
:end (rotate-point (the-child circle start)
(the-child circle center)
(the (face-normal-vector :top))
:angle (if (= (the input-link-index)
(the-child index))
(the input-link-angle)
(the follower-link-angle))))
(coupler-link :type 'coupler-link
:display-controls (list :line-thickness 2 :color :blue)
:pass-down (coupler-angle-1 coupler-length-1)
:start (the (grounded-links 0) end)
:end (the (grounded-links 1) end)))
:functions
((animate
(&key (start-angle-d 0) (end-angle-d 360) (increment (the angle-increment)) (write-pdfs? t))
(let* ((current-angle (the input-link-angle-d))
(angles (list-of-numbers start-angle-d end-angle-d increment))
(count -1) data)
(dolist (angle angles)
(the (set-slot! :input-link-angle-d angle))
(print-variables angle)
(incf count)
(with-error-handling () (push (the coupler-link datum) data))
(when write-pdfs?
(let ((filename (format nil "/tmp/4bar-~2,,,'0@a.pdf" count)))
(with-format (pdf filename :page-width (* 5 72) :page-length (* 5 72))
(write-the view-object cad-output)))))
(the (set-slot! :input-link-angle-d current-angle))
(nreverse data)))))
(define-object coupler-link (line)
:input-slots (coupler-angle-1 coupler-length-1)
:computed-slots ((datum (the edge-1 end)))
:objects
((baseline :type 'line
:pass-down (start end))
(edge-1 :type 'line
:pass-down (start)
:end (rotate-point (translate-along-vector (the start)
(the direction-vector)
(the coupler-length-1))
(the start)
(the (face-normal-vector :top))
:angle (the coupler-angle-1)))
(edge-2 :type 'line
:start (the edge-1 end)
:pass-down (end))))
geom-base/drawing/source/base-view.lisp
View file @
facad824
...
...
@@ -416,7 +416,13 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(
the
arcs-array-2d
)))
(
the
arcs-array-2d
)))
(
path-info-2d-scaled
(
when
(
the
path-info-2d
)
(
if
(
the
scale?
)
(
let
((
scale
(
the
view-scale
)))
(
mapcar
#'
(
lambda
(
point
)
(
if
(
keywordp
point
)
point
(
scalar*vector
scale
point
)))
(
the
path-info-2d
)))
(
the
path-info-2d
))))
;;
;; FLAG -- fold code from this and next message into a method function
...
...
@@ -438,21 +444,15 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(
:right
(
make-vector
(
get-y
point
)
(
get-z
point
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
)))))
#'
(
lambda
(
point
)
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
))))
(
subseq
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
))
0
2
)))
raw-points
)))
(
vertex-array-2d
(
when
(
typep
(
the
object
)
'gdl::gdl-basis
)
(
let
((
raw-points
(
or
(
the
object
%corners%
)
(
the
object
%vertex-array%
))))
;;(the touched-geometry)
;;(print-messages object)
;;(print-variables raw-points)
(
let
((
raw-points
(
or
(
the
object
%vertex-array%
)
(
the
object
%corners%
))))
(
map
'vector
#'
(
lambda
(
point
)
;;
...
...
@@ -465,10 +465,34 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(
:rear
(
make-vector
(
-
(
get-x
point
))
(
get-z
point
)))
(
:front
(
make-vector
(
get-x
point
)
(
get-z
point
)))
(
:right
(
make-vector
(
get-y
point
)
(
get-z
point
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
)))))
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
))))
(
subseq
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
))
0
2
)))
raw-points
))))
(
path-info-2d
(
when
(
and
(
typep
(
the
object
)
'gdl::gdl-basis
)
(
the
object
path-info
))
(
let
((
raw-points
(
the
object
path-info
)))
(
mapcar
#'
(
lambda
(
point
)
;;
;; FLAG this case basically repeats code from (defun keyed-transform*vector ...)
;;
(
if
(
keywordp
point
)
point
(
if
(
and
(
keywordp
(
the
view-transform
))
(
the
snap-to-y?
))
(
case
(
the
view-transform
)
(
:top
(
subseq
point
0
2
))
;;(make-vector (get-x point) (get-y point)))
(
:bottom
(
make-vector
(
get-x
point
)
(
-
(
get-y
point
))))
(
:rear
(
make-vector
(
-
(
get-x
point
))
(
get-z
point
)))
(
:front
(
make-vector
(
get-x
point
)
(
get-z
point
)))
(
:right
(
make-vector
(
get-y
point
)
(
get-z
point
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
))))
(
subseq
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
))
0
2
))))
raw-points
))))
(
2d-bounding-box
(
unless
(
or
(
not
(
typep
(
the
object
)
'gdl::gdl-basis
))
...
...
geom-base/drawing/source/lenses.lisp
View file @
facad824
...
...
@@ -153,8 +153,7 @@
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(
unless
(
typep
object
'global-filleted-polyline
)
(
unless
(
typep
object
'global-polyline-mixin
)
(
let
((
line-index-pairs
(
the-object
object
%line-vertex-indices%
))
(
curve-index-quadruples
(
the-object
object
%curve-vertex-indices%
)))
...
...
geom-base/wire/source/base-object.lisp
View file @
facad824
...
...
@@ -361,6 +361,8 @@ Defaults to the foreground color specified in <tt>*colors-default*</tt>. This me
:functions
(
(
path-info
())
;;
;; FLAG -- check if we are at root orientation and center,
;; i.e. confirm transform is really necessary.
...
...
geom-base/wire/source/fillet.lisp
View file @
facad824
...
...
@@ -28,9 +28,12 @@
(
local-vertex
direction-vectors
)
:computed-slots
((
orientation
(
alignment
:top
(
apply
#'
cross-vectors
(
the
:direction-vectors
))))
((
normal
(
apply
#'
cross-vectors
(
the
direction-vectors
)))
(
orientation
(
alignment
:top
(
the
normal
)))
(
angle
(
apply
#'
angle-between-vectors
(
the
:direction-vectors
)))
(
angle
(
apply
#'
angle-between-vectors
(
append
(
the
:direction-vectors
)
(
list
(
the
normal
)
:-ve
t
))))
(
other-angle
(
-
pi
(
the
:angle
)))
...
...
@@ -47,17 +50,18 @@
(
start-to-end-angle
(
twice
(
angle-between-vectors
(
the
:keep-vector
)
(
subtract-vectors
(
first
(
the
:tangents
))
(
the
:center
)))))
(
subtract-vectors
(
first
(
the
:tangents
))
(
the
:center
))
(
the
normal
)
:-ve
t
)))
(
start-tangent
(
if
(
minusp
(
angle-between-vectors
(
subtract-vectors
(
first
(
the
:tangents
))
(
the
:center
))
(
subtract-vectors
(
second
(
the
:tangents
))
(
the
:center
))
(
the
(
:face-normal-vector
:top
)
)
:-ve
t
))
(
the
normal
)
:-ve
t
))
(
second
(
the
:tangents
))
(
first
(
the
:tangents
))))
(
start-angle
(
angle-between-vectors
(
the
(
:face-normal-vector
:right
))
(
subtract-vectors
(
the
:start-tangent
)
(
the
:center
))
(
the
(
:face-normal-vector
:top
))
))
(
the
normal
)
:-ve
t
))
(
start-angle-normalized
(
mod
(
the
start-angle
)
2pi
))
...
...
geom-base/wire/source/global-filleted-polyline.lisp
View file @
facad824
...
...
@@ -76,11 +76,27 @@ filleted-polyline."
(
%arcs%
(
list-elements
(
the
fillets
)))
(
%renderer-info%
(
list
:vrml?
t
:view-default
:top
))
(
path-info
(
let
((
first?
t
))
(
mapcan
#'
(
lambda
(
straight
curve-set
)
(
append
(
if
first?
(
progn
(
setq
first?
nil
)
(
list
:move
(
first
straight
)
:line
(
second
straight
)))
(
list
:line
(
second
straight
)))
(
apply
#'
append
(
mapcar
#'
(
lambda
(
curve
)
(
cons
:curve
(
rest
(
reverse
curve
))))
(
reverse
(
the-object
curve-set
%curves-to-draw%
))))))
(
the
straights
)
(
list-elements
(
the
fillets
)))))
(
fillet-types
(
mapcar
#'
(
lambda
(
test
)
(
if
(
the-object
test
valid?
)
'fillet
'null-part
))
(
list-elements
(
the
fillet-tests
)))))
;;
;; FLAG --replace with function call returning fillet-curves.
;;
...
...
geom-base/wire/source/global-polyline.lisp
View file @
facad824
...
...
@@ -29,14 +29,14 @@
:computed-slots
((
%corners%
(
bounding-box-from-points
(
the
vertex-list
)))
(
%lines-to-draw%
nil
)
(
%
%
lines-to-draw%
%
(
the
:lines
))
(
%%vertex-array%%
(
flatten-lines
(
the
%
%lines-to-draw%
%
)))
(
%lines-to-draw%
(
the
:lines
))
(
%%vertex-array%%
(
flatten-lines
(
the
%lines-to-draw%
)))
(
%%line-vertex-indices%%
(
let
((
count
-1
))
(
mapcar
#'
(
lambda
(
line
)
(
declare
(
ignore
line
))
(
list
(
incf
count
)
(
incf
count
)))
(
the
%
%lines-to-draw%
%
))))
(
the
%lines-to-draw%
))))
(
%renderer-info%
(
list
:vrml?
t
:view-default
:top
))
...
...
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
facad824
...
...
@@ -121,17 +121,53 @@ value of the image-format-selector, which itself defaults to :raphael."
;;
;; FLAG -- probably not needed, inherited from skeleton-ui-mixin via base-ajax-sheet, base-html-sheet, sheet-section.
;;
(
inner-html
(
with-cl-who-string
()
(
write-the
inner-html
))))
(
inner-html
(
with-cl-who-string
()
(
write-the
inner-html
)))
(
on-drag-function
nil
)
(
on-drop-function
nil
)
)
:functions
((
set-js-vals!
(
js-vals
)
(
let
((
dropped-x-y
(
the
(
model-x-y
(
destructuring-bind
(
&key
x
y
&allow-other-keys
)
js-vals
(
list
:x
x
:y
y
)))))
(
dropped-height-width
(
destructuring-bind
(
&key
width
height
&allow-other-keys
)
js-vals
(
list
:width
(
/
width
(
the
view-object
view-scale
))
:height
(
/
height
(
the
view-object
view-scale
)))))
(
dropped-object
(
with-error-handling
()
(
base64-decode-list
(
getf
js-vals
:name
)))))
(
the
(
set-slots!
(
list
:dropped-x-y
dropped-x-y
:dropped-height-width
dropped-height-width
:dropped-object
dropped-object
)
)))))
:computed-slots
(
(
js-to-eval
(
let
((
image-format
(
the
image-format
)))
(
print-variables
image-format
)
(
cond
((
eql
(
the
image-format
)
:raphael
)
(
"3D point. This is the upper-right corner of the bounding box of the dragged and/or dropped element."
dropped-x-y
nil
:settable
)
(
"Plist with :width and :height. The dimensions of the bounding-box of the dragged and/or dropped element."
dropped-height-width
nil
:settable
)
(
"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
)
(
js-to-eval
:parse
#+
nil
(
let
((
image-format
(
the
image-format
)))
(
cond
((
eql
image-format
:raphael
)
(
the
raphael-string
))
((
eql
(
the
image-format
)
:x3dom
)
((
eql
image-format
:x3dom
)
nil
;;"console.log(\"loading x3dom js\"); xdom_script.src=\"http://www.x3dom.org/x3dom/release/x3dom.js\""
)))
...
...
@@ -242,14 +278,45 @@ bottom of the graphics inside a table."
:choice-list
(
plist-keys
(
the
standard-views
))
;;:default :top
:default
(
the
view-direction-default
)
)
)
)
)
:functions
((
reset-zoom!
(
(
on-drag
()
(
when
(
the
on-drag-function
)
(
funcall
(
the
on-drag-function
))))
(
on-drop
()
(
when
(
the
on-drop-function
)
(
funcall
(
the
on-drop-function
))))
;;
;; FLAG -- copied from base-html-graphics-sheet's logic for dig-point and report-point --
;; factor out the repeated code!
;;
;; FLAG -- standardize on length instead of height for Y coord.
;;
(
model-x-y
(
local-x-y
)
(
when
local-x-y
(
destructuring-bind
(
&key
x
y
)
local-x-y
(
let
((
x
(
-
x
(
half
(
the
view-object
width
))))
(
y
(
let
((
y
(
-
(
the
view-object
length
)
y
)))
(
-
y
(
half
(
the
view-object
length
))))))
(
let
((
adjusted
(
scalar*vector
(
the
view-object
user-scale
)
(
add-vectors
(
make-point
(
get-x
(
the
view-object
user-center
)
)
(
get-y
(
the
view-object
user-center
))
0
)
(
scalar*vector
(
/
(
the
view-object
user-scale
))
(
make-point
x
y
0
))))))
(
let
((
model-point
(
the
view-object
main-view
(
model-point
adjusted
))))
model-point
))))))
(
reset-zoom!
()
(
the
view-object
(
restore-slot-defaults!
(
list
:user-center
:user-scale
))))
...
...
@@ -342,8 +409,6 @@ to call the :write-embedded-x3d-world function."))
(
t
(
print-variables
(
the
onclick-function
))
(
with-cl-who
()
(
:p
((
:span
:style
"cursor: pointer;"
)
...
...
gwl-graphics/raphael/source/lenses.lisp
View file @
facad824
This diff is collapsed.
Click to expand it.
gwl-graphics/raphael/source/tests.lisp
View file @
facad824
...
...
@@ -19,71 +19,139 @@
;; <http://www.gnu.org/licenses/>.