Commit 7bb2a191 authored by Dave Cooper's avatar Dave Cooper
Browse files

Partial fix for Issue #84

parent 96bb61fe
......@@ -450,3 +450,5 @@ The error was: ~a
)
))))
......@@ -241,6 +241,7 @@
(define-object value-inspector (inspector)
:input-slots ((message nil)
......@@ -252,7 +253,10 @@
(the parent-node (evaluate (the message))))))
:computed-slots
((value-type (if (the 3d-vector?)
((value-root-path (cons (the message) (the parent-node root-path)))
(value-type (if (the 3d-vector?)
:gdl-3d-point
(typecase (the value)
(list (when (consp (the value)) :list))
......@@ -293,6 +297,7 @@
(let* ((value (the value))
(gdl-object? (eql (class-of (class-of value))
(find-class 'gdl-class))))
(with-cl-who-string ()
((:span :style (format nil "color: ~a; ~a"
(if (the clickable?) "blue" "black")
......@@ -307,7 +312,10 @@
(when (the clickable?)
(the (gdl-ajax-call
:function-key :perform-action!
:arguments (list (the point))))))
;;:arguments (list (the point))
:arguments (let ((object (make-object 'gdl::root-path-container
:root-path (the value-root-path))))
(list object))))))
((:list :gdl-sequence)
(unless (the expanded?)
......@@ -336,12 +344,20 @@
(:td (str (the-object row value-display)))))))))
(htm (:pre (esc (the truncated-sequence))))))
(gdl-object? (htm (esc (format nil "~s" value))))
#+nil
((eql (the value-type) :gdl-3d-point)
(htm (esc (the point strings-for-display))))
((eql (the value-type) :gdl-3d-point)
(htm (esc (format nil "~s" value))))
(t (htm (fmt "~s" value))))))))))
:objects ((point :type (if (the 3d-vector?) 'point 'null-object)
:objects (
#+nil
(point :type (if (the 3d-vector?) 'point 'null-object)
:center (when (the 3d-vector?) (the value))
:strings-for-display (format nil "~s" (the value)))
......
......@@ -44,7 +44,9 @@
;;(the recompute?)
(maphash #'(lambda(root-path value)
(declare (ignore value))
(push (the root-object (follow-root-path root-path)) result))
(push (if (listp root-path)
(the root-object (follow-root-path root-path))
root-path) result))
(the view-object-roots-root-paths-hash)) (nreverse result)))
......@@ -126,17 +128,18 @@
;;
(add-leaves!
(object)
(the (add-display-controls! object))
(let ((hash (the view-object-roots-root-paths-hash))
(root-path (the-object object root-path)))
(root-path (the-object object root-path)))
(the (set-slot! :view-object-roots-root-paths-hash
(progn (unless (second (multiple-value-list (gethash root-path hash)))
(setf (gethash root-path hash) t)) hash))))
(progn (unless (second (multiple-value-list (gethash root-path hash)))
(setf (gethash root-path hash) t)) hash))))
(the (set-slot! :operations-list
(append (the operations-list)
(list (list :operation :add-leaves :object object))))))
(append (the operations-list)
(list (list :operation :add-leaves :object object))))))
(enter-debugger!
......
......@@ -958,8 +958,8 @@ a separate object hierarchy." object self)))
(define-object root-path-container ()
:input-slots (root-path))
......
......@@ -297,7 +297,10 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
;;(typep obj 'outline-specialization-mixin)
))
(let ((leaves
(apply #'append (mapcar #'(lambda(object) (the-object object leaves))
(apply #'append (mapcar #'(lambda(object)
(if (typep object 'gdl::gdl-basis)
(the-object object leaves)
(list object)))
(the object-roots)))))
(append leaves
(apply #'append
......@@ -324,18 +327,17 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(object-array
(remove-duplicates
(coerce
(append (the objects)
(remove-if #'(lambda(obj) (or (typep obj 'null-part)
(typep obj 'outline-specialization-mixin)
))
(apply #'append
(append (the objects)
(remove-if #'(lambda(obj) (or (typep obj 'null-part)
(typep obj 'outline-specialization-mixin)
))
(apply #'append
(mapcar #'(lambda(object)
(when (typep object 'outline-specialization-mixin)
(the-object object outline-leaves)))
(the objects))))
(the leaf-objects-from-roots))
'vector))))
(mapcar #'(lambda(object)
(when (typep object 'outline-specialization-mixin)
(the-object object outline-leaves)))
(the objects))))
(the leaf-objects-from-roots)) 'vector))))
:hidden-objects
((border-box :type 'box)
......@@ -441,33 +443,35 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(vertex-array-2d
(let ((raw-points (or (the object %corners%) (the object %vertex-array%))))
(when (typep (the object) 'gdl::gdl-basis)
(let ((raw-points (or (the object %corners%) (the object %vertex-array%))))
;;(the touched-geometry)
;;(the touched-geometry)
;;(print-messages object)
;;(print-variables raw-points)
;;(print-messages object)
;;(print-variables raw-points)
(map 'vector
#'(lambda(point)
;;
;; FLAG this case basically repeats code from (defun keyed-transform*vector ...)
;;
(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)))))
(project-to-plane point 1 (the projection-vector) (the view-transform)
:snap-to (the snap-to)))
raw-points)))
(map 'vector
#'(lambda(point)
;;
;; FLAG this case basically repeats code from (defun keyed-transform*vector ...)
;;
(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)))))
(project-to-plane point 1 (the projection-vector) (the view-transform)
:snap-to (the snap-to)))
raw-points))))
(2d-bounding-box
(unless (the immune?)
(unless (or (not (typep (the object) 'gdl::gdl-basis))
(the immune?))
(let* ((vertex-array-2d (the vertex-array-2d))
(xs (map 'list #'get-x vertex-array-2d))
(ys (map 'list #'get-y vertex-array-2d)))
......
......@@ -148,55 +148,56 @@
:output-functions
((lines-and-curves
()
(let ((object (the object)) (2d-vertices (the vertex-array-2d-scaled)))
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(unless (typep object 'global-filleted-polyline)
(when (typep (the object) 'gdl::gdl-basis)
(let ((object (the object)) (2d-vertices (the vertex-array-2d-scaled)))
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(unless (typep object 'global-filleted-polyline)
(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)()
......
......@@ -93,6 +93,24 @@
)))))
;;
;; FLAG -- add output functions for point and simple-vector.
;;
(define-lens (x3d t) ()
:output-functions
((cad-output
(&key (header? nil))
(declare (ignore header?)))
(cad-output-tree
(&key (header? nil))
(declare (ignore header?)))))
(define-lens (x3d base-object)()
:output-functions
(
......
......@@ -86,6 +86,9 @@ meaning the crosshairs will remain the same size regardless of zoom state."
(make-point (+ x 1) (+ y 1) (+ z 1))))))))
(define-lens (pdf point)()
:output-functions
((cad-output
......@@ -111,3 +114,24 @@ meaning the crosshairs will remain the same size regardless of zoom state."
(define-lens (pdf simple-vector)()
:output-functions
((cad-output
()
(with-format-slots (view)
(let ((center (if view (the-object view (view-point self)) self))
(crosshair-length 3) ;; FLAG -- figure out better way to specify this
;;(view-scale (if view (the-object view view-scale) 1))
(view-scale 1)
)
(let ((start-x (- (get-x center) (* crosshair-length view-scale)))
(start-y (- (get-y center) (* crosshair-length view-scale))))
(pdf:with-saved-state
(pdf:move-to (to-single-float start-x) (to-single-float (get-y center)))
(pdf:line-to (to-single-float (+ start-x (* (twice crosshair-length) view-scale)))
(to-single-float (get-y center)))
(pdf:move-to (to-single-float (get-x center))
(to-single-float start-y))
(pdf:line-to (to-single-float (get-x center))
(to-single-float (+ start-y (* (twice crosshair-length) view-scale))))
(pdf:stroke))))))))
\ No newline at end of file
......@@ -154,7 +154,7 @@ if you are making a web-drawing on your own. Defaults (in the standalone case) t
(center (make-point 0 0 0))
(image-file (dolist (object (the objects))
(when (the-object object image-file)
(when (and (typep object 'gdl::gdl-basis) (the-object object image-file))
(return (the-object object image-file))))))
......
......@@ -483,5 +483,49 @@
(the color-hex)))))))))))
(define-lens (raphael simple-vector)()
:output-functions
((cad-output
()
(with-format-slots (view)
(let ((center (if view (the-object view (view-point self)) self))
(crosshair-length 3)
(view-scale 1))
(setq center (let ((point
(add-vectors geom-base:*raphael-translation* (subseq center 0 2))))
(make-point (get-x point) (- (the-object view length) (get-y point)))))
(let ((start-x (to-single-float (- (get-x center) (* crosshair-length view-scale))))
(start-y (to-single-float (- (get-y center) (* crosshair-length view-scale))))
(end-x (to-single-float (+ (get-x center) (* crosshair-length view-scale))))
(end-y (to-single-float (+ (get-y center) (* crosshair-length view-scale))))
(center-x (to-single-float (get-x center)))
(center-y (to-single-float (get-y center)))
(name "pt"))
(with-cl-who ()
(let ((*read-default-float-format* 'single-float))
(str
(format
nil
"var ~a_lines = paper.path('M ~a ~a L ~a ~a M ~a ~a L ~a ~a').attr({stroke: '#000'});~%"
name
start-x
center-y
end-x
center-y
center-x
start-y
center-x
end-y
))))))))))
(define-lens (raphael t)()
:output-functions
((cad-output ())))
......@@ -31,6 +31,9 @@
(cons (encode-for-ajax (first item))
(encode-for-ajax (rest item)))))
(defmethod encode-for-ajax ((self gdl::root-path-container))
(list :%container-rp% (the root-path)))
(defmethod encode-for-ajax ((self gdl::gdl-basis))
(list :%rp% (the root-path)))
......@@ -42,6 +45,8 @@
(when item
(cond ((eql (first item) :%rp%)
(the (follow-root-path (getf item :%rp%))))
((eql (first item) :%container-rp%)
(make-object 'gdl::root-path-container :root-path (getf item :%container-rp%)))
(t (cons (decode-from-ajax (first item) self)
(decode-from-ajax (rest item) self))))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment