|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is an example of a user command that will emulate all existing ;;;
;; extrude capabilities, plus add a new option. The new option :draft ;;;
;; allows the user to specify if the extruded result should be drafted. ;;;
;; It is possible to make a mill command out of this file by exchanging ;;;
;; all occurances of "extrude" with "mill", and changing the ;;;
;; "add_loft :part" statement to "remove_loft :parts". ;;;
;; ;;;
;; NOTE: THIS COMMAND CAN NOT YET SUPPORT NESTED LOOPS IN A PROFILE ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :acme_warehouse)
(use-package :oli)
(sd-defdialog 'draft_extrude
:dialog-title "extrude"
:variables
'((*FEEDBACK* :initial-value nil)
(*START-STATE* :initial-value (sd-set-model-checkpoint))
(*CURR-WP* :initial-value (sd-inq-curr-wp))
(*MODE* :initial-value (sd-inq-geometry-mode))
(*START-ELEM*) ;this can go after we get loop info
(*END-ELEM*) ;this can go after we get loop info
(A_PART :value-type :part-incl-new
:prompt-text "Identify part to be modified")
(WP :value-type :wp-with-profile
:title "Workplane"
:prompt-text "Identify workplane to extrude"
:check-function #'find-start-end-elem
:after-input (update-pers :wp))
("-")
(DISTANCE
:value-type :distance
:prompt-text "Specify distance to extrude"
:after-input (update-pers :distance))
(TO_PART
:value-type :part
:prompt-text "Specify part to extrude to"
:after-input (update-pers :to_part))
(DRAFT
:value-type :angle
:prompt-text "Enter draft angle"
:initial-optional t
:after-input (draft-feedback :show)
:end-input-feedback (draft-feedback :hide))
("-")
(DIRECTION
:value-type :wp-normal
:title "Reverse")
(KEEP_WP
:value-type :boolean)
)
:mutual-exclusion '(distance to_part)
:ok-action ;keep_wp=t, to_part=nil
'(progn
(when (and DRAFT (= DRAFT 0)) (setq DRAFT nil))
(extrude-doer)
)
:local-functions
'(
(update-pers (item)
;function to manage interaction of distance and part options
(case item
(:distance (setq TO_PART nil))
(:to_part (setq DISTANCE nil)
(setq DRAFT nil)
(sd-set-variable-status 'DRAFT :enable nil)
(draft-feedback :hide))
(:wp (draft-feedback :show))
)
)
(draft-feedback (mode)
;function to display or hide draft feedback
(case mode
(:hide (destroy-draft-feedback))
(:show (if (and DRAFT (= DRAFT 0))
(setq DRAFT nil)
;else
(create-draft-feedback))
)
)
)
(destroy-draft-feedback ()
(sd-end-direction-feedback *FEEDBACK*)
(setq *FEEDBACK* nil))
(find-start-end-elem (wp &aux eg sel-list s-elem e-elem start-coord)
;find all real geo on current wp
(sd-call-cmds (current_wp wp))
(setq sel-list (sd-call-cmds (get_selection
:focus_type *sd-edge-2d-seltype* :curr_wp_only :select :all_2d)))
;check if wp has more than one element
(when (< (length sel-list) 2)
(return-from find-start-end-elem
(values :error "Must have more than one element on this wp"))
)
;select the start and end element
(setq s-elem (first sel-list))
(setq eg (sd-inq-edge-geo s-elem :dest-space wp))
(setq start-coord (sd-gpnt3d-to-2d (sd-edge-start-pnt eg)))
;find elem attached to start pt.
(setq e-elem (sd-call-cmds (get_selection :focus_type
*sd-edge-2d-seltype* :curr_wp_only :select :by_vertex_2d
start-coord)))
;if we can not find an element, then reject this WP
(unless e-elem
(return-from find-start-end-elem
(values :error "Internal error in getting start/end elem"))
)
(if (equal (first e-elem) s-elem)
(setq e-elem (second e-elem))
(setq e-elem (first e-elem)))
;save start and end element for later use
(setq *start-elem* s-elem)
(setq *end-elem* e-elem)
(return-from find-start-end-elem :ok)
)
(create-draft-feedback ()
(let ((eg (sd-inq-edge-geo *END-ELEM* :dest-space :global))
start-arrow normal tangent half-p geo-data)
;if there is feedback, destroy it first.
(when *FEEDBACK* (destroy-draft-feedback))
;find mid point of end-elem
(setq half-p (/ (+ (sd-edge-s-end eg) (sd-edge-s-start eg)) 2.0))
(setq geo-data (sd-inq-edge-pnt *END-ELEM* :s half-p :coordinates t
:tangent t :dest-space :global))
;calculate feedback coordinates
(setq start-arrow (getf geo-data :coordinates))
(setq tangent (getf geo-data :tangent))
(setq normal (sd-vec-cross-product tangent (sd-inq-wp-w-dir WP)))
;draw feedback
(setq *FEEDBACK* (sd-start-direction-feedback :disc nil
:point start-arrow :direction normal))
)
)
(extrude-doer ()
(if draft
;use the lofting approach
(extrude-with-draft)
;use the standard extrude approach
(standard-extrude)
)
)
(display-error (&optional (mesg nil) (cleanup nil))
;cleanup first since user can terminate while message is displayed
(when cleanup (cleanup))
(if mesg
(sd-display-error (format nil "~A~%~A" mesg
(sd-inq-error-obj :message)))
(sd-display-error (sd-inq-error-obj :message)))
)
(cleanup ()
(sd-return-to-model-checkpoint *START-STATE*)
)
(standard-extrude ()
(let ((reverse nil) (cmd-opt `(:part ,A_PART :wp ,WP)))
;check if we need to use the :reverse option
(unless (plusp (sd-vec-scalar-product direction (sd-inq-wp-w-dir WP)))
(setq reverse t))
(if to_part
(setq cmd-opt (nconc cmd-opt `(:to_part ,TO_PART)))
(setq cmd-opt (nconc cmd-opt `(:distance ,DISTANCE))))
(when reverse (nconc cmd-opt '(:reverse)))
(if KEEP_WP
(setq cmd-opt (nconc cmd-opt '(:keep_wp :yes)))
(setq cmd-opt (nconc cmd-opt '(:keep_wp :no))))
;do the extrude
(sd-call-cmds (apply #'extrude cmd-opt)
:failure (cleanup))
)
)
(extrude-with-draft (&aux select-list)
(let (equid-list wp-set draft-wp cp-wp
start-match-coord end-match-coord)
;create workplane set with copy of original wp and new offset wp
(multiple-value-setq (wp-set draft-wp cp-wp)
(create-draft-wp-set))
(sd-call-cmds (current_wp cp-wp))
(sd-call-cmds (geometry_mode :real))
;find all real geometry on the cp-wp
(setq select-list
(sd-call-cmds (get_selection :focus_type *sd-edge-2d-seltype*
:curr_wp_only :select :all_2d)
:failure (progn
(display-error "unable to locate geometry" t)
(return-from extrude-with-draft))))
;calculate and perform offset
(multiple-value-setq (start-match-coord end-match-coord)
(create-equidistance-loop select-list))
;if no match coordinate is found, terminate
(unless start-match-coord (return-from extrude-with-draft))
;find new elements created by equidistance
(setq equid-list
(sd-call-cmds (get_selection :focus_type *sd-edge-2d-seltype*
:curr_wp_only :select :start :all_2d
:remove select-list :select_done)))
;check if wp is valid
;this should be done before projecting, to avoid
;projecting self-interseting curves
(unless (sd-basic-wp-profile-check-p cp-wp)
(display-error "Draft angle is too great" t)
(return-from extrude-with-draft))
;project new geo onto new workplane as real geo
(sd-call-cmds (current_wp draft-wp))
(sd-call-cmds (project equid-list))
(sd-call-cmds (delete_2d equid-list))
;create matchline
(let ((start-match-pt (create-match-pt start-match-coord cp-wp))
(end-match-pt (create-match-pt end-match-coord draft-wp)))
(sd-call-cmds (create_match_line start-match-pt end-match-pt))
)
;loft with new body or existing body
(sd-call-cmds (add_loft :part a_part :tool wp-set :keep_tool :no)
:failure (progn
(display-error nil t)
(return-from extrude-with-draft)))
;do we keep the original wp or not
(unless keep_wp
(sd-call-cmds (delete_3d wp)))
)
)
(create-equidistance-loop (edge-list)
(let* (
(s-elem *START-ELEM*)
(e-elem *END-ELEM*)
(offset (* distance (sin draft)))
(eg (sd-inq-edge-geo s-elem :dest-space WP))
(start-coord (sd-gpnt3d-to-2d (sd-edge-start-pnt eg)))
(half-p (/ (+ (sd-edge-s-end eg) (sd-edge-s-start eg)) 2.0))
(mid-coord1 (sd-gpnt3d-to-2d (getf (sd-inq-edge-pnt s-elem
:s half-p :coordinates t :dest-space wp) :coordinates)))
mid-coord2 normal tangent offset-vec
geo-data coord-on-equid equid-elem)
;use old start-elem to find coordinates and select this start-elem on cp-wp
(setq s-elem
(sd-call-cmds (get_selection :focus_type *sd-edge-2d-seltype*
:curr_wp_only :select mid-coord1)))
;find coordinate info for end element
(setq eg (sd-inq-edge-geo e-elem :dest-space WP))
(setq half-p (/ (+ (sd-edge-s-end eg) (sd-edge-s-start eg)) 2.0))
(setq geo-data (sd-inq-edge-pnt e-elem :s half-p :coordinates t
:tangent t :dest-space wp))
(setq mid-coord2 (sd-gpnt3d-to-2d (getf geo-data :coordinates)))
;calculate catch pt for offsetted end-element
(setq tangent (sd-gpnt3d-to-2d (getf geo-data :tangent)))
(setq normal (sd-gpnt3d-to-2d (sd-vec-cross-product tangent 0,0,1)))
(setq offset-vec (sd-vec-scale normal (abs offset)))
(setq coord-on-equid (sd-vec-add mid-coord2 offset-vec))
;create equdistance contour
(sd-call-cmds (equidistance_2d :construction :off :intersections :off
:distance offset start-coord s-elem mid-coord1
:side coord-on-equid)
:failure (progn
(display-error "Failed offset:" t)
(return-from create-equidistance-loop nil)))
;calculate match-coord
(setq equid-elem
(sd-call-cmds (get_selection :focus_type *sd-edge-2d-seltype*
:curr_wp_only :select (if (plusp offset)
coord-on-equid
(sd-vec-subtract mid-coord2 offset-vec)))))
;check if we got an element
(unless equid-elem
(display-error "Catching of offset element failed" t)
(return-from create-equidistance-loop nil)
)
;pick the end of this element that is closests to original
(let ((len1) (len2))
;find the corresponding element on equidistant profile to start-elem
(setq eg (sd-inq-edge-geo (first equid-elem) :dest-space wp))
(setq len1 (sd-vec-length
(sd-vec-subtract start-coord (sd-edge-start-pnt eg))))
(setq len2 (sd-vec-length
(sd-vec-subtract start-coord (sd-edge-end-pnt eg))))
(if (> len2 len1)
(setq coord-on-equid (sd-gpnt3d-to-2d (sd-edge-start-pnt eg)))
(setq coord-on-equid (sd-gpnt3d-to-2d (sd-edge-end-pnt eg))))
)
(values start-coord coord-on-equid)
)
)
(create-draft-wp-set ()
(let (dist
(draft-wp "draft-wp")
(cp-wp "cp-wp")
(wp-set-name (sd-gen-obj-basename :wpset))
(wp-set nil))
;create a new workplane set
(sd-call-cmds (create_wpset :name wp-set-name))
(setq wp-set (sd-pathname-to-obj (format nil "/~A" wp-set-name)))
;create a shared copy of the original
(sd-call-cmds (create_workplane :share :source WP :name cp-wp
:owner wp-set :par_wp :ref_wp WP :offset 0))
(setq cp-wp (sd-inq-curr-wp))
;create new offset workplane
(if (plusp (sd-vec-scalar-product direction (sd-inq-wp-w-dir wp)))
(setq dist distance)
(setq dist (- distance)))
(sd-call-cmds (create_workplane :new :name draft-wp :owner wp-set
:par_wp :ref_wp wp :offset dist))
(setq draft-wp (sd-inq-curr-wp))
(values wp-set draft-wp cp-wp)
)
)
(create-match-pt (match-coord match-wp)
;change wp to cp-wp
(sd-call-cmds (current_wp match-wp))
(sd-call-cmds (get_selection :focus_type *sd-match-vertex-2d-seltype*
:curr_wp_only :select match-coord))
)
)
)
;