;;; --------------------------------------------------------------------------- ;;; tube.lsp 1.0 Copyright Georg Mischler 1993 ;;; tube.lsp 1.1/1.2 Copyright Georg Mischler 1998 ;;; schorsch@schorsch.com ;;; ;;; Permission to use, copy, modify, and distribute this software ;;; for any purpose and without fee is hereby granted, provided that ;;; the above copyright notice appears in all copies and that both ;;; that copyright notice and this permission notice appear in all ;;; supporting documentation. ;;; ;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;;; --------------------------------------------------------------------------- ;;; environment setup --------------------------------------------------------- ;;; (defun tube_error (msg) (tube_reset) ) (defun tube_setup () (command "_.undo" "_group") (setq *tube_oldvars* (list (getvar "cmdecho") (getvar "osmode") (getvar "blipmode") *error* ) *error* tube_error *tube_selection* NIL ) (setvar "cmdecho" 0) (setvar "osmode" 0) ) (defun tube_reset () (foreach sel *tube_selection* (redraw sel) ) (setvar "cmdecho" (car *tube_oldvars*)) (setvar "osmode" (cadr *tube_oldvars*)) (setvar "blipmode" (caddr *tube_oldvars*)) (setq *tube_selection* NIL *error* (cadddr *tube_oldvars*) *tube_oldvars* NIL) (command "_.undo" "_end") (princ) ) ;;; ;;; end environment setup ----------------------------------------------------- ;;; tube generation ----------------------------------------------------------- ;;; (defun make_tube (prof path nclose mclose zdir / pathlen nprof firstp profl) (if (equal (car path)(last path)) (setq mclose T path (reverse (cdr (reverse path))) ) ) (setq path (elimstraights (uniquepts path)) pathlen (length path) prof (uniquepts prof) firstp (car path) profl (list (if mclose (ntubeprof prof (cons (last path) path) zdir) prof )) ) (cond ( (< 1 pathlen) (cond ( (= 2 pathlen) (setq profl (list prof (etubeprof prof path zdir))) ) ( (< 2 (length path)) (while (cddr path) (setq prof (if (setq nprof (ntubeprof prof path zdir)) nprof prof) profl (if nprof (cons prof profl) profl) path (cdr path) ) ) (setq prof (if mclose (ntubeprof prof (append path (list firstp)) zdir ) (etubeprof prof path zdir) ) profl (cons prof profl) ) ) (T NIL) ) (command "_.3dMESH" (length profl) (length prof)) (foreach profile (reverse profl) (foreach point profile (command point) ) ) (if nclose (command "_.pedit" "_last" "_N" "")) (if mclose (command "_.pedit" "_last" "_M" "")) ) (T (Princ "Path too short")) ) ) (defun ntubeprof (prof path zdir / dir1 dir2 ai p0 v1 v2) (setq p0 (cadr path) dir1 (vector (car path) (cadr path)) dir2 (vector (caddr path)(cadr path)) hdiff (- (caddr p0)(caddar path)) ai (full_interang dir1 dir2) v1 (if zdir zdir (vect-prod dir1 dir2)) v2 (car (intervectors dir1 dir2 v1 ai 1)) ) (if (equal 0.0 ai 0.0000001) (etubeprof prof path zdir) (ctubeprof prof dir1 p0 v1 v2 hdiff zdir) ) ) (defun etubeprof (prof path zdir / p0 dir v1 v2 ) (setq dir (vector (car path) (cadr path)) p0 (cadr path) hdiff (- (caddr p0)(caddar path)) v1 (if zdir zdir (if (or (equal '(-1.0 0.0 0.0) dir 0.5) (equal '(1.0 0.0 0.0) dir 0.5) ) (vect-prod dir '(0.0 1.0 0.0)) (vect-prod dir '(1.0 0.0 0.0)) )) v2 (vect-prod dir v1) ) (ctubeprof prof dir p0 v1 v2 hdiff zdir) ) (defun ctubeprof (prof dir p0 v1 v2 hdiff zdir / npt) (if zdir (mapcar '(lambda (pt) (setq npt (pointthru (list pt dir) p0 v1 v2)) (list (car npt) (cadr npt) (+ (caddr pt) hdiff)) ) prof ) (mapcar '(lambda (pt) (pointthru (list pt dir) p0 v1 v2) ) prof ) ) ) ;;; ;;; end tube generation ------------------------------------------------------- ;;; vector calc --------------------------------------------------------------- ;;; (defun intervectors (v1 v2 vn ai num / astep a1 a2 vect vlist) (setq astep (/ ai (1+ num)) a1 0 ) (repeat num (setq a1 (+ a1 astep) a2 (- ai a1) vect (if (or (equal v1 v2) (equal v1 (mapcar '- v2)) ) v1 (3angvector v1 v2 vn (list (cos a1) (cos a2) 0)) ) vlist (append vlist (list vect)) ) ) vlist ) (defun 3angvector (av bv cv coslist / xyz sxyz rxyz vallist) (setq xyz (mapcar 'list av bv cv) sxyz (mapcar 'shift xyz) rxyz (mapcar 'shift sxyz) vallist (mapcar '(lambda (ry sz sy rz) (mapcar '(lambda (yc zb yb zc) (- (* yc zb) (* yb zc) ) ) ry sz sy rz ) ) (shift rxyz) (shift (shift sxyz)) (shift sxyz) (shift (shift rxyz)) ) ) (mapcar '(lambda (xlist vals) (/ (apply '+ (mapcar '* coslist vals)) (apply '+ (mapcar '* xlist vals)) ) ) xyz vallist ) ) (defun pointthru (vl p0 vv vw) (extend-vline vl (pointthru-t vl p0 vv vw)) ) (defun pointthru-t (vl p0 vv vw / svv svw abc o-p ) (setq svv (shift vv) svw (shift vw) abc (mapcar '(lambda (yv zw yw zv) (- (* yv zw) (* yw zv) ) ) svv (shift svw) svw (shift svv) ) o-p (mapcar '- p0 (car vl)) ) (/ (apply '+ (mapcar '* abc o-p)) (apply '+ (mapcar '* abc (cadr vl))) ) ) (defun orthparamt (pt vl / tc tn tval) (setq tc (apply '+ (mapcar '(lambda (xv xp xr) (* xv (- xp xr)) ) (cadr vl) pt (car vl) )) tn (apply '+ (mapcar '(lambda (xv) (* xv xv) ) (cadr vl) )) ) (if (= 0 tn) (prompt "\ndivision by zero in orthparamt!\007 ") (/ tc tn) ) ) (defun full_interang (v1 v2 / ot pp d1 ang) (setq ot (orthparamt v2 (list '(0 0 0) v1)) pp (extend-vline (list '(0 0 0) v1) ot) d1 (distance '(0 0 0) pp) ) (cond ( (= 0 d1) (setq ang (/ pi 2)) ) ( T (setq ang (atan (/ (distance v2 pp) d1 ))) ) ) ang ) (defun vector (p1 p2 / len) (setq len (distance p1 p2)) (if (= 0 len) '(0.0 0.0 0.0) (mapcar '(lambda (x1 x2) (/ (- x2 x1) len) ) p1 p2 ) ) ) (defun vect-prod (v1 v2 / yzx) (setq yzx (shift (mapcar 'list v1 v2))) (normalize (mapcar '(lambda (yl zl) (- (* (car yl)(cadr zl)) (* (cadr yl)(car zl)) ) ) yzx (shift yzx) )) ) (defun transf-p (vect matrix / factor) (if (numberp (setq factor (last matrix))) (setq vect (mapcar '* vect (list factor factor factor)) matrix (reverse (cdr (reverse matrix))) ) ) (mapcar '(lambda (mline) (apply '+ (mapcar '* vect mline)) ) matrix ) ) (defun extend-vline (vline dist) (mapcar '(lambda (xp xv) (+ xp (* xv dist)) ) (car vline)(cadr vline) ) ) (defun normalize (vect / len) (setq len (distance '(0 0 0) vect)) (if (= 0 len) vect (mapcar '(lambda (co) (/ co len) ) vect ) ) ) ;;; ;;; end vector calc ----------------------------------------------------------- ;;; spline fitting ------------------------------------------------------------ ;;; (defun bspl_knot (jj tt nn) (cond ( (< jj tt) 0.0) ( (> jj nn) (- nn tt -2.0)) ( T (- jj tt -1.0)) ) ) (defun bspl_blend (k tt n u kN kT / tmp v) (setq v 0.0) (cond ( (and (= k n) (= u (- n tt -2.0))) (setq v 1.0) ) ( (and (equal k 0 0.0000001) (equal u 0 0.0000001)) (setq v 1.0) ) ( (= tt 1) (if (and (<= (bspl_knot k kN kT) u) (< u (bspl_knot (+ k 1.0) kN kT)) ) (setq v 1.0) ) ) ( T (if (/= 0.0 (setq tmp (- (bspl_knot (- (+ k tt) 1.0) kN kT) (bspl_knot k kN kT) )) ) (setq v (/ (* (- u (bspl_knot k kN kT)) (bspl_blend k (- tt 1.0) n u kN kT) ) tmp )) ) (if (/= 0.0 (setq tmp (- (bspl_knot (+ k tt) kN kT) (bspl_knot (+ k 1.0) kN kT) ))) (setq v (+ v (/ (* (- (bspl_knot (+ k tt) kN kT) u) (bspl_blend (+ k 1.0) (- tt 1.0) n u kN kT ) ) tmp ))) ) ) ) v ) (defun bspl_calcpt (tt n u cpts / k B pt) (setq k 0.0 pt '(0.0 0.0 0.0) ) (foreach cpt cpts (setq B (bspl_blend k tt n u tt n) pt (mapcar '(lambda (p c) (+ p (* c B)) ) pt cpt ) k (+ k 1.0) ) ) pt ) (defun bspline (cpts segs degr / i n tt pts) (setq i 0.0 n (- (length cpts) 1.0) tt (1+ degr) ) (while (<= i segs) (setq pts (cons (bspl_calcpt tt n (* (/ (- n tt -2.0) segs) i) cpts) pts ) i (+ i 1) ) (if (= (/ (fix i) 10)(/ i 10.0))(princ ".")) ) (reverse pts) ) ;;; ;;; end spline fitting -------------------------------------------------------- ;;; util ---------------------------------------------------------------------- ;;; (defun tubeselectpoly (str / ele etyp ) (setq ele (entsel str)) (cond ( ele (setq etyp (cdr (assoc 0 (entget (car ele))))) (cond ( (= "POLYLINE" etyp) (tubeplinetolist (car ele)) ) ( (= "LWPOLYLINE" etyp) (tubelwplinetolist (car ele)) ) (T NIL) ) ) (T NIL) ) ) (defun tubeplinetolist (pline / a b plist flag) (setq flag (getval pline 70) a (entget pline) b (entget (entnext (cdar a))) plist NIL ) (cond ( (= 0 (logand flag (+ 2 4 16 32 64))) (while (/= "SEQEND" (cdr (assoc 0 b))) (setq plist (cons (trans (cdr (assoc 10 b )) pline 1) plist ) b (entget (entnext (cdar b))) ) ) (cons pline (reverse plist)) ) ( T NIL) ) ) (defun tubelwplinetolist (lwpline / plist) (setq plist (apply 'append (mapcar '(lambda (pair) (if (eq (car pair) 10) (list (trans (cdr pair) lwpline 1)) ) ) (entget lwpline) ) ) ) (cons lwpline plist) ) (defun elimstraights (plist / nplist) (cond ( (< 2 (length plist)) (mapcar '(lambda (p0 p1 p2) (if (and nplist (equal 0.0 (full_interang (vector p0 p1) (vector p1 p2)) 0.0000001) ) NIL (setq nplist (cons p1 nplist)) ) ) (reverse (shift (reverse plist))) plist (shift plist) ) (reverse nplist) ) (T (plist)) ) ) (defun uniquepts (plist / nplist) (mapcar '(lambda (p0 p1) (if (equal p0 p1) NIL (setq nplist (cons p0 nplist)) ) ) plist (shift plist) ) (reverse nplist) ) (defun getval (ele code) (cdr (assoc code (entget ele))) ) (defun shift (alist) (append (cdr alist) (list (car alist))) ) ;;; ;;; end util ------------------------------------------------------------------ ;;; commands ------------------------------------------------------------------ ;;; (defun c:fitpoly ( / plist segs degr splist) (tube_setup) (setq plist (tubeselectpoly "select polyline: ")) (cond ( plist (redraw (car plist) 3) (setq *tube_selection* (list (car plist))) (setq segs (getint "\nnumber of segments: ") degr (getint "\npolynominal degree of spline: ") splist (bspline (cdr plist) segs degr) ) (setvar "blipmode" 0) (command "_.3dpoly") (foreach pt splist (command pt)) (command "") ) (T (prompt "not a polyline!\007\n")) ) (tube_reset) ) (defun c:tube () (tube_setup) (asktube NIL) (tube_reset) ) (defun c:ztube () (tube_setup) (asktube '(0.0 0.0 1.0)) (tube_reset) ) (defun asktube ( zdir / cplist pplist fflag segs degr) (setq cplist (tubeselectpoly "select Polyline as profile: ")) (cond ( cplist (redraw (car cplist) 3) (setq *tube_selection* (list (car cplist))) (setq pplist (tubeselectpoly "select Polyline as path: ")) (cond ( pplist (redraw (car pplist) 3) (setq *tube_selection* (cons (car pplist) *tube_selection*)) (initget "Yes No") (setq fflag (getkword "\nFit path-curve Yes/: ")) (if (= "Yes" fflag) (setq segs (getint "\nTotal number of segments: ") degr (getint "\npolynominal degree of spline: ") npplist (bspline (cdr pplist) segs degr) ) (setq npplist (cdr pplist)) ) (setvar "blipmode" 0) (make_tube (cdr cplist) npplist (= 1 (logand 1 (getval (car cplist) 70))) (= 1 (logand 1 (getval (car pplist) 70))) zdir ) ) ( T (prompt "no Polyline!\007\n")) ) ) (T (prompt "no Polyline!\007\n")) ) ) ;;; ;;; end commands -------------------------------------------------------------- (prompt "type \"FITPOLY\", \"TUBE\" or \"ZTUBE\" to start.\n") (princ) ;;; end tube.lsp -------------------------------------------------------------