Commit bcf9d98f authored by Dave Cooper's avatar Dave Cooper

updated for merging with devo

parent 184e2bae
......@@ -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)
......
(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))))
......@@ -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
......
......@@ -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))
......
......@@ -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)()
......
......@@ -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))))
......@@ -172,6 +172,3 @@ each direction.</li>
(the polygons-for-ifs))))))
......@@ -145,48 +145,10 @@
;;
;; FLAG -- the following should be folded into %lines-to-draw% and %curves-to-draw% to avoid
;; FLAG -- the following has been 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)))))))
......@@ -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?)))))
(define-lens (html-format base-ajax-graphics-sheet)()
:output-functions
((main-view
......
......@@ -28,7 +28,11 @@
(define-lens (raphael base-drawing)()
:output-functions
((cad-output
((raphael-paper-def (&key width length)
(format *stream* "if (typeof paper === 'undefined') {var paper = Raphael('~a', ~a, ~a)};~%"
(the raphael-canvas-id) width length))
(cad-output
()
(let ((view-center (if (the user-center)
(scalar*vector (the user-scale) (the user-center))
......@@ -41,51 +45,7 @@
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(format *stream* "if (typeof paper === 'undefined') {var paper = Raphael('~a', ~a, ~a)};~%
if (typeof start === 'undefined') {