Commit 8cf961ee authored by Dave Cooper's avatar Dave Cooper
Browse files

streamlined path operators, still have to fix logic for gdlajax innerhtml and js-to-eval responses.

parent 731f50e1
......@@ -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))
......
......@@ -123,7 +123,7 @@ value of the image-format-selector, which itself defaults to :raphael."
;;
(inner-html (with-cl-who-string () (write-the inner-html)))
(on-move-function nil)
(on-drag-function nil)
(on-drop-function nil)
......@@ -150,11 +150,15 @@ value of the image-format-selector, which itself defaults to :raphael."
:computed-slots
(
(dropped-x-y nil :settable)
("3D point. This is the upper-right corner of the bounding box of the dragged and/or dropped element."
dropped-x-y nil :settable)
(dropped-height-width 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)
(dropped-object 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 (let ((image-format (the image-format)))
......@@ -276,9 +280,9 @@ bottom of the graphics inside a table."
:functions
(
(on-move ()
(when (the on-move-function)
(funcall (the on-move-function))))
(on-drag ()
(when (the on-drag-function)
(funcall (the on-drag-function))))
(on-drop ()
(when (the on-drop-function)
......
......@@ -41,24 +41,35 @@
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(format *stream* "~&~%var paper = Raphael('~a', ~a, ~a);~%
(format *stream* "if (typeof paper === 'undefined') {var paper = Raphael('~a', ~a, ~a)};~%
if (typeof start === 'undefined') {
var start = function () {
this.lastdx ? this.odx += this.lastdx : this.odx = 0;
this.lastdy ? this.ody += this.lastdy : this.ody = 0;
this.animate({opacity: .5}, 500, \">\");
},
move = function (dx, dy) {
move_cb = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
~a
},
move = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
},
up = function () {
this.animate({opacity: 1.0}, 500, \">\");
~a
};
}};
"
(the raphael-canvas-id) width length
......@@ -68,7 +79,7 @@
;; to that, instead of referring to
;; the parent here.
;;
(the parent (gdl-sjax-call :js-vals? t :function-key :on-move))
(the parent (gdl-sjax-call :js-vals? t :function-key :on-drag))
(the parent (gdl-sjax-call :js-vals? t :function-key :on-drop)))
(with-translated-state (:raphael (make-point (- (get-x view-center))
......@@ -142,32 +153,38 @@
(unless (zerop (length (the vertex-array-2d-scaled)))
(let ((object (the object))
(2d-vertices
(map 'vector #'(lambda(vertex)
(let ((point
(add-vectors (subseq vertex 0 2)
geom-base:*raphael-translation*)))
(make-point (get-x point)
(- (the length) (get-y point)))))
(the vertex-array-2d-scaled))))
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(unless (the path-info-2d-scaled)
(map 'vector #'(lambda(vertex)
(let ((point
(add-vectors (subseq vertex 0 2)
geom-base:*raphael-translation*)))
(make-point (get-x point)
(- (the length) (get-y point)))))
(the vertex-array-2d-scaled))))
(path-info (when (the path-info-2d-scaled)
(mapcar #'(lambda(component)
(if (keywordp component) component
(let ((point
(add-vectors component geom-base:*raphael-translation*)))
(make-point (get-x point)
(- (the length) (get-y point))))))
(the path-info-2d-scaled)))))
(let ((line-index-pairs (the-object object %line-vertex-indices%))
(curve-index-quadruples (the-object object %curve-vertex-indices%))
(let ((line-index-pairs (when 2d-vertices (the-object object %line-vertex-indices%)))
(curve-index-quadruples (when 2d-vertices (the-object object %curve-vertex-indices%)))
(display-controls (or (geom-base::find-in-hash object *display-controls*)
(the object display-controls)))
(name (base64-encode-safe
(format nil "~s" (remove :root-object-object
(the-object object root-path)))))
(*read-default-float-format* 'single-float))
(let (prev-end
(move? t))
(when line-index-pairs
(let ((path-string
;;(*read-default-float-format* 'single-float)
)
(let ((line-path-string
(when line-index-pairs
(let (prev-end (move? t))
(format nil "~{~a~^ ~}"
(mapcar
#'(lambda(line-index-pair)
......@@ -175,155 +192,110 @@
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index)))
(when (and prev-end (coincident-point? start prev-end))
(setq move? nil))
(setq move? (not (and prev-end (coincident-point? start prev-end))))
(setq prev-end end)
(format nil "~aL ~a ~a"
(format nil "~a ~a ~a"
(if move?
(format nil "M ~a ~a "
(to-single-float (get-x start))
(to-single-float (get-y start)))
(number-round (get-x start) 4)
(number-round (get-y start) 4))
" ")
(to-single-float (get-x end))
(to-single-float (get-y end))))))
line-index-pairs))))
(with-cl-who ()
(fmt "var ~a_lines = paper.path('~a').attr({stroke: '~a', fill: '~a'});~%"
name
path-string
(or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex))
(or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex)))
(fmt "~a_lines.attr({cursor: 'pointer'}).data('name','\\\"~a\\\"');"
name name)
(fmt "~&paper.set(~a_lines).drag(move,start,up);" name)
))))
(let (result)
(mapc #'(lambda(curve-index-quadruple)
(destructuring-bind (start-index c1-index c2-index end-index)
curve-index-quadruple
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index))
(c1 (svref 2d-vertices c1-index))
(c2 (svref 2d-vertices c2-index)))
(push (list start c1 c2 end) result)))) curve-index-quadruples)
(setq result (nreverse result))
(when result
(let* ((name (base64-encode-safe
(format nil "~s" (remove :root-object-object
(the-object object root-path)))))
(line-thickness (getf display-controls :line-thickness))
(line-thickness (or line-thickness (the object line-thickness)))
(line-thickness (if (zerop line-thickness) 1 line-thickness)))
(let ((start-string
(format nil "var ~a_curves = paper.path('~{~a~}').attr({stroke: '~a'});~%"
name
(let* (prev-end
(move? t)
(curve-strings
(mapcar
#'(lambda(curve)
(setq move? t)
(destructuring-bind (start c1 c2 end) curve
(when (and prev-end (coincident-point? start prev-end))
(setq move? nil))
(setq prev-end end)
(format nil "~aC ~a ~a ~a ~a ~a ~a "
(if move? (format nil "M ~a ~a "
(to-single-float (get-x start))
(to-single-float (get-y start)))
"")
(to-single-float (get-x c1) )
(to-single-float (get-y c1))
(to-single-float (get-x c2) )
(to-single-float (get-y c2))
(to-single-float (get-x end) )
(to-single-float (get-y end))
(number-round (get-x end) 4)
(number-round (get-y end) 4)))))
line-index-pairs)))))
(curve-path-string
(when curve-index-quadruples
(let (coords)
(mapc #'(lambda(curve-index-quadruple)
(destructuring-bind (start-index c1-index c2-index end-index)
curve-index-quadruple
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index))
(c1 (svref 2d-vertices c1-index))
(c2 (svref 2d-vertices c2-index)))
(push (list start c1 c2 end) coords)))) curve-index-quadruples)
(setq coords (nreverse coords))
(let (prev-end (move? t))
(format nil "~{~a~}"
(mapcar
#'(lambda(curve)
(setq move? t)
(destructuring-bind (start c1 c2 end) curve
(when (and prev-end (coincident-point? start prev-end))
(setq move? nil))
(setq prev-end end)
(format nil "~aC ~a ~a ~a ~a ~a ~a "
(if move? (format nil "M ~a ~a "
(number-round (get-x start) 4)
(number-round (get-y start) 4)) "")
(number-round (get-x c1) 4)
(number-round (get-y c1) 4)
(number-round (get-x c2) 4)
(number-round (get-y c2) 4)
(number-round (get-x end) 4)
(number-round (get-y end) 4)
))) result)))
curve-strings)
(let ((color (or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex))))
(or color "#000"))))
;;
;; FLAG make this into separate output-function to be amended for objects containing a viewport.
;;
(onclick-string nil)
#+nil
(onclick-string
(when (ignore-errors (and (the viewport) (eql (the viewport digitation-mode) :select-object)))
(format nil "~a_curves.node.onclick = function (event) {~a};"
name
(the viewport (gdl-ajax-call :function-key :set-object-to-inspect!
:arguments (list object))))))
(onmouseover-string
nil
#+nil
(format nil
" ~a_curves.node.onmouseover = function (){~a_curves.attr({'stroke-width': '~a'});};"
name name
(floor (to-single-float (* (or line-thickness 1) 3)))
))
(onmouseout-string
nil
#+nil
(format nil " ~a_curves.node.onmouseout = function (){~a_curves.attr({'stroke-width': '~a'});};"
name name (to-single-float (or line-thickness 1))))
))) coords)))))))
(when (or path-info line-path-string curve-path-string)
(who:with-html-output (*stream*)
(fmt "var ~a;~%" name)
(when (or line-path-string curve-path-string)
(fmt "~a = paper.path('~a ~a');"
name (or line-path-string "") (or curve-path-string "")))
(when path-info
(fmt "~&~a = paper.path('~{~a~^ ~}');~%"
name
(mapcar #'(lambda(component)
(if (keywordp component)
(ecase component
(:move "M")
(:line "L")
(:curve "C"))
(format nil "~a ~a"
(number-round (get-x component) 4)
(number-round (get-y component) 4)))) path-info)))
(fmt "~a.attr({stroke: '~a'});"
name (or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex)))
(let ((fill (or (when (getf display-controls :fill-color)
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex))))
(when fill (fmt "~a.attr({fill: '~a'});" name fill)))
(let ((line-thickness (getf display-controls :line-thickness)))
(when line-thickness
(fmt "~&~a.attr('stroke-width','~a');" name (number-round line-thickness 4))))
(write-the (drag-controls :name name :display-controls display-controls))
;;
;; FLAG work these back in as generic output-functions.
;;
#+nil
(onclick-string
(when (ignore-errors (and (the viewport) (eql (the viewport digitation-mode) :select-object)))
(format nil "~a_curves.node.onclick = function (event) {~a};"
name
(the viewport (gdl-ajax-call :function-key :set-object-to-inspect!
:arguments (list object))))))
#+nil
(onmouseover-string
(format nil
" ~a_curves.node.onmouseover = function (){~a_curves.attr({'stroke-width': '~a'});};"
name name
(floor (to-single-float (* (or line-thickness 1) 3)))))
#+nil
(onmouseout-string
(format nil " ~a_curves.node.onmouseout = function (){~a_curves.attr({'stroke-width': '~a'});};"
name name (to-single-float (or line-thickness 1))))
(fill-string
(let ((color (or (when (getf display-controls :fill-color)
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex))))
(if color
(format nil "~a_curves.attr('fill','~a');"
name color) "")))
)))))))))
(stroke-width-string
(if line-thickness
(format nil "~&~a_curves.attr('stroke-width','~a');"
name (to-single-float line-thickness))
"")))
(with-cl-who ()
(str start-string)
;;
;; FLAG -- this has to be conditionalized based on :display-controls
;; of the object.
;;
(when onclick-string (str onclick-string))
(when onmouseover-string (str onmouseover-string))
(when onmouseout-string (str onmouseout-string))
(str fill-string)
(str stroke-width-string)
)))
))))))))
......@@ -389,7 +361,10 @@
(define-lens (raphael global-polyline)()
:output-functions
((cad-output
((cad-output ())
#+nil
(cad-output
()