Explode

|#


(in-package :EXAMPLES)
(use-package :OLI)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(sd-defdialog 'explode
  :dialog-title "Explode"
  :variables	
  '(;; local variables:
    (FIXPOINT :value-type     :point-3d 
	      :initial-value  0,0,0)
    (FACTOR   :value-type     :number
	      :initial-value  1.5)
    ;; visible dialog variables:
    (PARTS  :value-type     :part 
	    :multiple-items t 
	    :modifies       :parent-contents)
    (ASMBS  :value-type     :assembly
	    :multiple-items t
	    :modifies       :contents))
  :mutual-exclusion '(parts asmbs)
  :local-functions
  '((inq-part-box (p)
     (let ((pll nil)
	   (pur nil)
	   (faces (sd-call-cmds (get_selection :focus_type *sd-face-seltype*
					       :allow_face_part
					       :allow_wire_part
					       :select :in_part p))))
       (if (listp faces)
	   (dolist (i faces)
	     (let* ((fp (sd-inq-face-geo i :dest-space :global))
		    (fll (sd-face-ll-pnt fp))
		    (fur (sd-face-ur-pnt fp)))
	       (if pll
		   (progn
		     (when (< (gpnt3d_x fll) (gpnt3d_x pll))
		       (setf (gpnt3d_x pll) (gpnt3d_x fll)))
		     (when (< (gpnt3d_y fll) (gpnt3d_y pll))
		       (setf (gpnt3d_y pll) (gpnt3d_y fll)))
		     (when (< (gpnt3d_z fll) (gpnt3d_z pll))
		       (setf (gpnt3d_z pll) (gpnt3d_z fll)))
		     (when (> (gpnt3d_x fur) (gpnt3d_x pur))
		       (setf (gpnt3d_x pur) (gpnt3d_x fur)))
		     (when (> (gpnt3d_y fur) (gpnt3d_y pur))
		       (setf (gpnt3d_y pur) (gpnt3d_y fur)))
		     (when (> (gpnt3d_z fur) (gpnt3d_z pur))
		       (setf (gpnt3d_z pur) (gpnt3d_z fur))))
		 (progn
		   (setf pll fll)
		   (setf pur fur)))))
	 (progn
	   (setf pll 0,0,0)
	   (setf pur 0,0,0)))
       ;; return value:
       (list pll pur)))
    
    (doit ()
     (when asmbs
       (dolist (i asmbs)
	 (setf parts (nconc parts (inq-obj-tree-list i))))
       (setf parts
	     (remove-if #'(lambda (obj) (not (equal (sel_item-type obj)
						    *sd-part-seltype*)))
			parts)))
     (dolist (i parts)
       (let* ((box (inq-part-box i))
	      (vec (sd-vec-subtract 
		    (sd-vec-scale (sd-vec-add (first box) (second box)) 0.5)
		    fixpoint)))
	 (sd-call-cmds (position_pa i :translate (sd-vec-scale vec factor))))))
    )
  :ok-action '(doit))


(defun inq-obj-tree-list (obj)
  (cons obj
	(apply #'nconc (mapcar #'inq-obj-tree-list (sd-inq-obj-children obj)))))


;;