Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
bcf9d98f
Commit
bcf9d98f
authored
Sep 02, 2013
by
Dave Cooper
Browse files
updated for merging with devo
parent
184e2bae
Changes
15
Hide whitespace changes
Inline
Side-by-side
base/rest/source/utilities.lisp
View file @
bcf9d98f
...
...
@@ -780,8 +780,15 @@ toplevel inputs as specified in the snapshot file.
(
defparameter
*dep-hash-threshhold*
1000
)
(
defun
add-notify-cons
(
notify-cons
value
&optional
self
message
)
;;
;; FLAG -- this was added as a fix for github Issue #69, but causes
;; a regression by polluting the dependency graph with normal objects
;; which may then become unbound spuriously. Retracted until a more
;; benign fix for Issue #69 can be determined.
;;
(
declare
(
ignore
self
message
))
#+
nil
(
when
(
and
self
message
)
(
let
((
aggregate
(
gdl-acc::%aggregate%
(
first
notify-cons
))))
(
when
(
and
(
consp
aggregate
)
...
...
documentation/tutorial/examples/4-bar-assembly.gdl
deleted
100644 → 0
View file @
184e2bae
(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))
(input-link-angle-d nil :settable)
)
:objects ((assembly :type 'assembly
:input-link-angle-d (or nil ;;(the 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
:js-to-eval :parse
:inner-html (with-cl-who-string ()
(str (the main-area dropped-x-y))
(str (the input-link-angle-d))
#+nil
(:script
(str (the (gdl-ajax-call :function-key :set-slot!
:arguments (list :input-link-angle-d (if (the input-link-angle-d)
(1+ (the input-link-angle-d)) 90 ))))))))
(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 (ecase (the-child index)
(1 :drag-and-drop)
(0 nil)))
: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 :fill-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 (global-polyline)
:input-slots (start end coupler-angle-1 coupler-length-1)
:computed-slots ((datum (the edge-1 end))
(direction-vector (subtract-vectors (the end) (the start)))
(vertex-list (list (the start) (the end) (the edge-1 end))))
:hidden-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))))
#+nil
(define-object coupler-link (line outline-specialization-mixin)
:input-slots (coupler-angle-1 coupler-length-1)
:computed-slots ((datum (the edge-1 end)))
:hidden-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))))
documentation/tutorial/pdf/tutorial.pdf
deleted
100644 → 0
View file @
184e2bae
File deleted
emacs/gdl.el
View file @
bcf9d98f
...
...
@@ -215,13 +215,14 @@
(
when
(
file-exists-p
"~/.emacs-glime.el"
)
(
load-file
"~/.emacs-glime.el"
)))
(
require
'package
)
;; Add the original Emacs Lisp Package Archive
(
add-to-list
'package-archives
'
(
"elpa"
.
"http://tromey.com/elpa/"
))
;; Add the user-contributed repository
(
add-to-list
'package-archives
'
(
"marmalade"
.
"http://marmalade-repo.org/packages/"
))
(
ignore-errors
(
require
'package
)
;; Add the original Emacs Lisp Package Archive
(
add-to-list
'package-archives
'
(
"elpa"
.
"http://tromey.com/elpa/"
))
;; Add the user-contributed repository
(
add-to-list
'package-archives
'
(
"marmalade"
.
"http://marmalade-repo.org/packages/"
)))
;; 5. MAKE IT HAPPEN
...
...
geom-base/annotations/source/leader-line.lisp
View file @
bcf9d98f
...
...
@@ -59,11 +59,13 @@ Currently only :wedge is supported. Default is :none."
(
leader-length
(
3d-distance
(
first
(
the
path-points
))
(
lastcar
(
the
path-points
))))
)
(
%lines-to-draw%
(
remove
nil
(
cons
(
the
polyline
%lines-to-draw%
)
(
apply
#'
append
(
mapsend
(
the
polylines
)
:%lines-to-draw%
))))))
:hidden-objects
(
(
polyline
:type
(
if
(
null
(
the
break-points
))
'global-polyline
'null-part
)
((
polyline
:type
(
if
(
null
(
the
break-points
))
'global-polyline
'null-part
)
:vertex-list
(
the
path-points
))
...
...
geom-base/drawing/source/lenses.lisp
View file @
bcf9d98f
...
...
@@ -150,53 +150,50 @@
()
(
when
(
typep
(
the
object
)
'gdl::gdl-basis
)
(
let
((
object
(
the
object
))
(
2d-vertices
(
the
vertex-array-2d-scaled
)))
;;
;; FLAG -- clean up the handling for global-filleted-polyline and any other odd types.
;;
(
unless
nil
;;(typep object 'global-polyline-mixin)
(
let
((
line-index-pairs
(
the-object
object
%line-vertex-indices%
))
(
curve-index-quadruples
(
the-object
object
%curve-vertex-indices%
)))
(
let
((
line-index-pairs
(
the-object
object
%line-vertex-indices%
))
(
curve-index-quadruples
(
the-object
object
%curve-vertex-indices%
)))
(
pdf:with-saved-state
(
write-the-object
object
line-thickness-setting
)
(
pdf:with-saved-state
(
write-the-object
object
line-thickness-setting
)
(
write-the-object
object
dash-pattern-setting
)
(
write-the-object
object
dash-pattern-setting
)
(
write-the-object
object
rgb-stroke-setting
)
(
write-the-object
object
rgb-stroke-setting
)
(
mapc
#'
(
lambda
(
line-index-pair
)
(
destructuring-bind
(
start-index
end-index
)
line-index-pair
(
let
((
start
(
svref
2d-vertices
start-index
))
(
end
(
svref
2d-vertices
end-index
)))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
))
(
pdf:line-to
(
%get-x%
end
)(
%get-y%
end
)))))
line-index-pairs
)
(
mapc
#'
(
lambda
(
line-index-pair
)
(
destructuring-bind
(
start-index
end-index
)
line-index-pair
(
let
((
start
(
svref
2d-vertices
start-index
))
(
end
(
svref
2d-vertices
end-index
)))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
))
(
pdf:line-to
(
%get-x%
end
)(
%get-y%
end
)))))
line-index-pairs
)
(
let
(
start
end
prev-end
)
(
let
(
start
end
prev-end
)
(
mapc
#'
(
lambda
(
curve-index-quadruple
)
(
destructuring-bind
(
start-index
c1-index
c2-index
end-index
)
curve-index-quadruple
(
declare
(
ignorable
start-index
))
(
mapc
#'
(
lambda
(
curve-index-quadruple
)
(
destructuring-bind
(
start-index
c1-index
c2-index
end-index
)
curve-index-quadruple
(
declare
(
ignorable
start-index
))
(
setq
prev-end
end
)
(
setq
start
(
svref
2d-vertices
start-index
)
end
(
svref
2d-vertices
end-index
))
(
setq
prev-end
end
)
(
setq
start
(
svref
2d-vertices
start-index
)
end
(
svref
2d-vertices
end-index
))
(
let
((
c1
(
svref
2d-vertices
c1-index
))
(
c2
(
svref
2d-vertices
c2-index
)))
(
let
((
c1
(
svref
2d-vertices
c1-index
))
(
c2
(
svref
2d-vertices
c2-index
)))
(
unless
(
and
start
prev-end
(
coincident-point?
start
prev-end
))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
)))
(
unless
(
and
start
prev-end
(
coincident-point?
start
prev-end
))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
)))
(
pdf:bezier-to
(
%get-x%
c1
)
(
%get-y%
c1
)
(
%get-x%
c2
)
(
%get-y%
c2
)
(
%get-x%
end
)
(
%get-y%
end
)))))
curve-index-quadruples
))
(
pdf:bezier-to
(
%get-x%
c1
)
(
%get-y%
c1
)
(
%get-x%
c2
)
(
%get-y%
c2
)
(
%get-x%
end
)
(
%get-y%
end
)))))
curve-index-quadruples
))
(
if
(
the-object
object
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
)))))))))
)
(
if
(
the-object
object
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
)))))))))
(
define-lens
(
dxf
view-object-cache
)()
...
...
geom-base/wire/source/base-object.lisp
View file @
bcf9d98f
...
...
@@ -769,4 +769,3 @@ based on the orientation and center of the object to which the local-to-global m
(
push
(
third
curve
)
result
)
(
push
(
fourth
curve
)
result
))))
geom-base/wire/source/global-polygon-projection.lisp
View file @
bcf9d98f
...
...
@@ -172,6 +172,3 @@ each direction.</li>
(
the
polygons-for-ifs
))))))
geom-base/wire/source/views.lisp
View file @
bcf9d98f
...
...
@@ -145,48 +145,10 @@
;;
;; FLAG -- the following
should
be folded into %lines-to-draw% and %curves-to-draw% to avoid
;; FLAG -- the following
has
be
en
folded into %lines-to-draw% and %curves-to-draw% to avoid
;; the need for separate views. But it works this way for now.
;;
#+
nil
(
define-lens
(
pdf
global-filleted-polyline
)()
:output-functions
((
cad-output
()
(
let
((
lines
(
the
straights
))
(
fillets
(
list-elements
(
the
fillets
))))
(
pdf:with-saved-state
(
write-the
line-thickness-setting
)
(
write-the
rgb-stroke-setting
)
(
when
(
the
fill-color-decimal
)
(
apply
#'
pdf:set-rgb-fill
(
coerce
(
the
fill-color-decimal
)
'list
)))
(
with-format-slots
(
view
)
(
let
((
start
(
if
view
(
the-object
view
(
view-point
(
first
(
first
lines
))))
(
first
(
first
lines
)))))
(
pdf:move-to
(
get-x
start
)
(
get-y
start
))
(
mapc
#'
(
lambda
(
line
fillet
)
(
destructuring-bind
(
start
end
)
(
if
view
(
mapcar
#'
(
lambda
(
point
)
(
the-object
view
(
view-point
point
)))
line
)
line
)
(
declare
(
ignore
start
))
(
pdf:line-to
(
get-x
end
)
(
get-y
end
))
(
when
fillet
(
let
((
curves
(
chain-curves
(
mapcar
#'
(
lambda
(
curve
)
(
if
view
(
mapcar
#'
(
lambda
(
point
)
(
the-object
view
(
view-point
point
)))
curve
)
curve
))
(
the-object
fillet
:curves
))
(
make-point
(
get-x
end
)
(
get-y
end
))
:rank
2
)))
(
dolist
(
curve
curves
)
(
destructuring-bind
(
p1
p2
p3
p4
)
curve
(
declare
(
ignore
p1
))
(
pdf:bezier-to
(
get-x
p2
)
(
get-y
p2
)
(
get-x
p3
)
(
get-y
p3
)
(
get-x
p4
)
(
get-y
p4
))))))))
lines
(
append
fillets
(
list
nil
))))
(
if
(
the
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
))))))))
#+
nil
(
define-lens
(
dxf
global-filleted-polyline
)()
:output-functions
...
...
@@ -246,39 +208,9 @@
(
))
fillets
)
)))))
;;
;; FLAG -- update for auto-scaling outside base-view
;;
#+
nil
(
define-lens
(
pdf
global-polyline
)()
:output-functions
((
cad-output
()
(
with-format-slots
(
view
)
(
let
((
line-index-pairs
(
the
%%line-vertex-indices%%
))
(
2d-vertices
(
map
'vector
(
if
view
#'
(
lambda
(
point
)
(
the-object
view
(
view-point
point
)))
#'
identity
)
(
the
%%vertex-array%%
))))
(
pdf:with-saved-state
(
write-the
line-thickness-setting
)
(
write-the
rgb-stroke-setting
)
(
when
(
the
fill-color-decimal
)
(
apply
#'
pdf:set-rgb-fill
(
coerce
(
the
fill-color-decimal
)
'list
)))
(
let
((
start
(
svref
2d-vertices
(
first
(
first
line-index-pairs
)))))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
))
(
mapc
#'
(
lambda
(
line-index-pair
)
(
destructuring-bind
(
start-index
end-index
)
line-index-pair
(
declare
(
ignore
start-index
))
(
let
((
end
(
svref
2d-vertices
end-index
)))
(
pdf:line-to
(
%get-x%
end
)
(
%get-y%
end
)))))
line-index-pairs
))
(
if
(
the
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
))))))))
#+
nil
(
define-lens
(
dxf
global-polyline
)()
:output-functions
...
...
@@ -305,9 +237,3 @@
)
line-index-pairs
)))))))
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
bcf9d98f
...
...
@@ -123,11 +123,6 @@ value of the image-format-selector, which itself defaults to :raphael."
;;
(
inner-html
(
with-cl-who-string
()
(
write-the
inner-html
)))
(
on-drag-function
nil
)
(
on-drop-function
nil
)
(
on-touchmove-function
nil
)
)
...
...
@@ -151,39 +146,10 @@ value of the image-format-selector, which itself defaults to :raphael."
:computed-slots
(
(
"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
image-format
:x3dom
)
nil
;;"console.log(\"loading x3dom js\"); xdom_script.src=\"http://www.x3dom.org/x3dom/release/x3dom.js\""
)))
:settable
)
(
js-to-eval
:parse
:settable
)
(
js-always-to-eval
nil
#+
nil
(
cond
((
eql
(
the
image-format
)
:x3dom
)
"console.log(\"loading x3dom script\");
loadScript(xdom_script.src);
//location.reload(true);
"
)))
(
js-always-to-eval
nil
)
(
raphael-canvas-id
(
format
nil
"raphael-~a"
(
the
base64-encoded-root-path
)))
...
...
@@ -285,18 +251,6 @@ bottom of the graphics inside a table."
:functions
(
(
on-drag
()
(
when
(
the
on-drag-function
)
(
funcall
(
the
on-drag-function
))))
(
on-drop
()
(
when
(
the
on-drop-function
)
(
funcall
(
the
on-drop-function
))))
(
on-touchmove
()
(
when
(
the
on-touchmove-function
)
(
funcall
(
the
on-touchmove-function
))))
;;
;; FLAG -- copied from base-html-graphics-sheet's logic for dig-point and report-point --
;; factor out the repeated code!
...
...
@@ -334,10 +288,6 @@ The <tt>view-object</tt> child should exist and be of type <tt>web-drawing</tt>.
(
write-the
(
embedded-x3dom-world
:include-view-controls?
include-view-controls?
)))))