Commit 01c36b10 authored by Dave Cooper's avatar Dave Cooper
Browse files

Merge branch 'feature/gendl4' into devo

parents c818e44e 636dc3c0
......@@ -14,6 +14,8 @@ bin
*.idx
*.log
*.toc
*.ind
*.ilg
configure.el
systems.txt
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)))
......
(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))))
This diff is collapsed.
......@@ -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))
......
......@@ -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%)))
......
......@@ -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.
......
......@@ -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))
......
......@@ -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.
;;
......
......@@ -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))
......
......@@ -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))