home *** CD-ROM | disk | FTP | other *** search
/ PC Graphics Unleashed / PC Graphics Unleashed.iso / ch18 / rad386 / vector.lsp < prev   
Encoding:
Lisp/Scheme  |  1993-07-15  |  19.3 KB  |  616 lines
  1. ;;; ***************************************************************************
  2. ;;;        vector.lsp
  3. ;;; 
  4. ;;;        This file is part of the program torad.lsp to export 
  5. ;;;        RADIANCE scene description files from Autocad. 
  6. ;;;
  7. ;;;        Copyright (C) 1993 by Georg Mischler / Lehrstuhl
  8. ;;;                              fuer Bauphysik ETH Zurich.
  9. ;;;  
  10. ;;;        Permission to use, copy, modify, and distribute this software  
  11. ;;;        for any purpose and without fee is hereby granted, provided  
  12. ;;;        that the above copyright notice appears in all copies and that  
  13. ;;;        both that copyright notice and this permission notice appear in  
  14. ;;;        all supporting documentation.  
  15. ;;;  
  16. ;;;        THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED  
  17. ;;;        WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  
  18. ;;;        PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.  
  19. ;;;  
  20. ;;;        Acknowlegdements:   
  21. ;;;        Final developement of this program has been sponsored by Prof. Dr.   
  22. ;;;        B. Keller, Building Physics, Dep. for Architekture ETH Zurich.   
  23. ;;;        The developement environment has been provided by Prof. Dr. 
  24. ;;;        G. Schmitt, Architecture & CAAD ETH Zurich. 
  25. ;;;  
  26. ;;; ***************************************************************************
  27.  
  28. ;;; VECTORS *******************************************************************
  29.  
  30. (defun vector (p1 p2 / len)
  31.  ;; return: vector of length 1 from p1 towards p2.
  32.  ;;         null-vector if points are identical.
  33.   (setq len (distance p1 p2))
  34.   (if (equal 0 len 0.0000001)
  35.       '(0.0 0.0 0.0)
  36.       (mapcar '(lambda (x1 x2)
  37.                  (/ (- x2 x1)
  38.                     len ) )
  39.             p1 p2 ) ) )
  40.  
  41.  
  42. (defun d-vector (p1 p2)
  43.  ;; return: vector of resulting length from p1 towards p2.
  44.  ;;         null-vector if points are identical.
  45.       (mapcar '(lambda (x1 x2)
  46.                  (- x2 x1) )
  47.             p1 p2 ) )
  48.  
  49.  
  50. (defun vectorize-l (line) 
  51.  ;; return: list of first point and vector of length 1 from first
  52.  ;;         towards second point of 'line'.
  53.   (list (car line) (vector (car line) (cadr line)) ) )
  54.  
  55.  
  56. (defun d-vectorize-l (line) 
  57.  ;; return: list of first point and vector of length 1 from first
  58.  ;;         towards second point of 'line'.
  59.   (list (car line) (d-vector (car line) (cadr line)) ) )
  60.  
  61.  
  62.  
  63. (defun normalize (vect / len)
  64.  ;; return: vector of length 1 in direction of vector 'vect'.
  65.   (setq len (distance '(0 0 0) vect))
  66.   (if (equal 0 len 0.0000001)
  67.       vect
  68.       (mapcar '(lambda (co)
  69.                  (/ co len) )
  70.          vect ) ) )
  71.  
  72.  
  73. (defun trans-vl (vl from to)
  74.   (list (trans (car vl) from to)
  75.         (trans (cadr vl) from to T) ) )
  76.  
  77.  
  78. (defun transl-p (point vector dist)
  79.  ;; return: point translated in direction of 'vector' for the
  80.  ;;         distance 'dist'.
  81.   (mapcar '(lambda (p v)
  82.              (+ p (* v dist)) )
  83.         point vector ) )
  84.  
  85.  
  86. (defun transl-l (pts dir dist)
  87.   (mapcar '(lambda (pt)
  88.               (transl-p pt dir dist) )
  89.      pts ) )
  90.  
  91.  
  92. (defun transl-vl (vl dir dist)
  93.   (if (equal '(0.0 0.0 0.0) dist)
  94.       vl
  95.       (list (mapcar '(lambda (p v)
  96.                       (+ p (* v dist)) )
  97.               (car vl) dir )
  98.             (cadr vl) ) ) )
  99.  
  100.  
  101. (defun extend-vect (vect factor)
  102.  ;; return: vector extended according to 'factor' relative to its
  103.  ;;         original length.
  104.   (mapcar '(lambda (xv)
  105.               (* xv factor) )
  106.      vect ) )
  107.  
  108.  
  109. (defun extend-vline (vline dist)
  110.  ;; return: point on vectorized line 'vline' in distance 'dist' from its
  111.  ;;         origin-point.
  112.   (mapcar '(lambda (xp xv)
  113.               (+ xp (* xv dist)) )
  114.      (car vline)(cadr vline) ) )
  115.  
  116.  
  117. ;;; PRODUKTS --------------------------------------------------***
  118.  
  119. (defun dot-prod (v1 v2)
  120.   (apply '+ (mapcar '* v1 v2)) )
  121.  
  122.  
  123. (defun vect-prod (v1 v2 / yzx)
  124.   ;; vector-product
  125.   ;;
  126.   ;;    x = y1 z2 - y2 z1
  127.   ;;    y = z1 x2 - z2 x1
  128.   ;;    z = x1 y2 - x2 y1
  129.   ;;
  130.   (setq yzx (shift (mapcar 'list v1 v2)))
  131.   (normalize (mapcar '(lambda (yl zl)
  132.                         (- (* (car yl)(cadr zl))
  133.                            (* (cadr yl)(car zl)) ) )
  134.                 yzx (shift yzx) )) )
  135.  
  136.  
  137. ;;; INQUIERY ---------------------------------------------------***
  138.  
  139. (defun vlen (vect)
  140.  ;; return: length of vector 'vect'.
  141.   (sqrt (apply '+ (mapcar '(lambda (xx)
  142.                              (* xx xx) )
  143.                       vect ))) )
  144.  
  145.  
  146. (defun vlinters (vl1 vl2)
  147.   ;; return : intersection-point of vectorized lines 'vl1' 'vl2' if
  148.   ;;          existing. else NIL.
  149.    (inters (car vl1) (extend-vline vl1 1.0)
  150.            (car vl2) (extend-vline vl2 1.0) NIL) )
  151.  
  152.  
  153.  
  154. (defun vl-dist (vl1 vl2 / p1 v1 v2 vd sup sub)
  155.  ;;
  156.  ;; smallest distance between two vectorized lines.
  157.  ;;
  158.  ;;   p1 = vr + t1 va
  159.  ;;   p2 = vs + t2 vb
  160.  ;;
  161.  ;;        | [va, vb, vs - vr] |
  162.  ;;   d = -----------------------
  163.  ;;             | va X vb |
  164.  ;;
  165.   (setq p1 (car vl1)
  166.         v1 (cadr vl1)
  167.         v2 (cadr vl2) )
  168.   (cond ( (v-parallelp v1 v2)
  169.           (distance p1 (orthonvline p1 vl2)) )
  170.         ( T
  171.           (setq vd (mapcar '- (car vl2)(car vl1))
  172.                 sup (abs (3det v1 v2 vd))
  173.                 sub (vlen (vect-prod v1 v2)) )
  174.           (/ sup
  175.              sub ) ) ) )
  176.  
  177.  
  178.  
  179. (defun interang (v1 v2 / ot pp d1 ang)
  180.   ;; return : angle between vectors 'v1' and 'v2'  ---  0 <= ang <= pi.
  181.   (cond ( (or (equal v2 '(0 0 0))(equal v1 '(0 0 0)))
  182.           (setq ang -1) )
  183.         (T 
  184.          (setq ot (orthparamt v2 (list '(0 0 0) v1))
  185.                pp (extend-vline  (list '(0 0 0) v1) ot)
  186.                d1 (distance '(0 0 0) pp) )
  187.          (cond ( (= 0 d1)
  188.                  (setq ang (/ pi 2)) )
  189.                ( T
  190.                 (setq ang (atan (/ (distance v2 pp) d1 )))
  191.                 (if (> 0 ot) 
  192.                     (setq ang (- pi ang)) ) ) ) ) )
  193.   ang )
  194.  
  195. ;;; PREDICATES ---------------------------------------------------***
  196.  
  197. (defun v-parallelp (v1 v2)
  198.  ;; for normalized vectors only!
  199.  ;; return: T if vectors 'v1' and 'v2' are parallel, else NIL.
  200.   (or (apply 'and (mapcar '(lambda (x1 x2)
  201.                              (equal x1 x2 0.000001) )
  202.                     v1 v2 ))
  203.       (apply 'and (mapcar '(lambda (x1 x2)
  204.                              (equal x1 x2 0.000001) )
  205.                     v1 (mapcar '- v2) )) ) )
  206.  
  207.  
  208. (defun vl-samep (vl1 vl2)
  209.  ;; return: T if the vectorized lines 'vl1' and 'vl2' are identical, else NIL.
  210.   (and (v-parallelp (cadr vl1)(cadr vl2))
  211.        (= 0.0 (vl-dist vl1 vl2)) ) )
  212.  
  213.  
  214. (defun planarp (ptlist / p0 v1 v2)
  215.   (cond ( (or (null ptlist) (> 3 (length ptlist))) NIL)
  216.         ( (= 3 (length ptlist)) T)
  217.         ( T
  218.           (setq p0 (car ptlist)
  219.                 v1 (vector p0 (cadr ptlist))
  220.                 v2 (vector p0 (caddr ptlist))
  221.                 ptlist (cdddr ptlist) )
  222.           (while (and ptlist
  223.                       (< (abs (3det (vector p0 (car ptlist)) v1 v2)) 0.001) )
  224.                  (setq ptlist (cdr ptlist)) )
  225.           (not ptlist) ) ) )
  226.  
  227.  
  228.  
  229. ;;; RELATED VECTORS ----------------------------------------------***
  230.  
  231. (defun 3angvector (av bv cv coslist / xyz sxyz rxyz vallist)
  232.  ;; parameters: three normalized vectors and
  233.  ;;             coslist: (cos-a cos-b cos-c)
  234.  ;; return: vector spanning certain angles with three other vectors.
  235.  ;;         all vectors must be normalized.
  236.  ;;         the result will only be correct if the angles fit possibluy
  237.  ;;         together with the three vectors (ain't it strange?).
  238.  ;; 
  239.  ;;
  240.  ;;    x xa + y ya + z za - cos-a = 0  
  241.  ;;    x xb + y yb + z zb - cos-b = 0  
  242.  ;;    x xc + y yc + z zc - cos-c = 0  
  243.  ;;
  244.  ;;
  245.  ;;      cos-a (yc zb - yb zc) + cos-b (ya zc - yc za) + cos-c (yb za - ya zb)
  246.  ;; x = -----------------------------------------------------------------------
  247.  ;;          xa (yc zb - yb zc) + xb (ya zc - yc za) + xc (yb za - ya zb)
  248.  ;;
  249.  ;;      cos-a (zc xb - zb xc) + cos-b (za xc - zc xa) + cos-c (zb xa - za xb)
  250.  ;; y = -----------------------------------------------------------------------
  251.  ;;          ya (zc xb - zb xc) + yb (za xc - zc xa) + yc (zb xa - za xb)
  252.  ;;
  253.  ;;      cos-a (xc yb - xb yc) + cos-b (xa yc - xc ya) + cos-c (xb ya - xa yb)
  254.  ;; z = -----------------------------------------------------------------------
  255.  ;;          za (xc yb - xb yc) + zb (xa yc - xc ya) + zc (xb ya - xa yb)
  256.  ;;
  257.  ;;
  258.   (setq xyz  (mapcar 'list av bv cv)
  259.         sxyz (mapcar 'shift xyz)
  260.         rxyz (mapcar 'shift sxyz)
  261.         vallist (mapcar '(lambda (ry sz sy rz)
  262.                            (mapcar '(lambda (yc zb yb zc)
  263.                                       (- (* yc zb)
  264.                                          (* yb zc) ) )
  265.                               ry sz sy rz ) )
  266.                   (shift rxyz)
  267.                   (shift (shift sxyz))
  268.                   (shift sxyz)
  269.                   (shift (shift rxyz)) ) )
  270.   (mapcar '(lambda (xlist vals)
  271.              (/ (apply '+ (mapcar '* coslist vals))
  272.                 (apply '+ (mapcar '* xlist vals)) ) )
  273.     xyz vallist ) )
  274.  
  275. ;;; POINTS -------------------------------------------------------***
  276.  
  277. (defun pointthru (vl p0 vv vw)
  278.   (extend-vline vl (pointthru-t vl p0 vv vw)) )
  279.  
  280. (defun orthonvline (pt vl)
  281.   ;; return: point perpendiculer on vectorized line 'vl' from point 'pt'.
  282.     (extend-vline vl (orthparamt pt vl) ) )
  283.  
  284.  
  285. ;;; PARAMETERS ---------------------------------------------------***
  286.  
  287. (defun pointthru-t (vl p0 vv vw / svv svw abc o-p   )
  288.  ;; 
  289.  ;;  return : parameter t extending vectorized line 'vl' to the common
  290.  ;;           point of vector 'vl' and plane 'r = p0 + vv = vw'.
  291.  ;;
  292.  ;;       ( xp )     ( xq )              ( xo )     ( xv )     ( xw )
  293.  ;;  vl = ( yp ) + t ( yq )      E : r = ( yo ) + s ( yv ) + u ( yw )
  294.  ;;       ( zp )     ( zq )              ( zo )     ( zv )     ( zw )
  295.  ;;
  296.  ;;     x = xp + t xq
  297.  ;;     y = yp + t yq
  298.  ;;     z = zp + t zq
  299.  ;; 
  300.  ;; 
  301.  ;;        A (xo - xp) + B (yo - yp) + C (zo - zp)
  302.  ;;  t = -------------------------------------------
  303.  ;;        A xq        + B yq        + C zq
  304.  ;; 
  305.  ;;  A = yv zw - yw zv
  306.  ;;  A = zv xw - zw xv
  307.  ;;  A = xv yw - xw yv
  308.  ;;
  309.  ;; 
  310.   (setq svv (shift vv)
  311.         svw (shift vw)
  312.         abc (mapcar '(lambda (yv zw yw zv)
  313.                         (- (* yv zw)
  314.                            (* yw zv) ) )
  315.                svv (shift svw) svw (shift svv) )
  316.         o-p (mapcar '- p0 (car vl)) )
  317.   (/ (apply '+ (mapcar '* abc o-p))
  318.      (apply '+ (mapcar '* abc (cadr vl))) ) )
  319.  
  320.  
  321. (defun orthparamt (pt vl / tc tn tval)
  322.   ;;  return : parameter t extending vectorized line 'vl' to
  323.   ;;           the point perpendicular on 'vl' from point 'pt'.
  324.   ;;
  325.   ;;      (  xp  )              (  xq  )     (  xv  )
  326.   ;;  p = (  yp  )      g : r = (  yq  ) + t (  yv  )
  327.   ;;      (  zp  )              (  zq  )     (  zv  )
  328.   ;;
  329.   ;; plane with orthogonal vector v:
  330.   ;;  E :  xv x + yv y + zv z - xv xp - yv yp - zv zp = 0
  331.   ;;
  332.   ;; insert g:       x + xq + t xv
  333.   ;;                 y + yq + t yv
  334.   ;;                 z + zq + t zv
  335.   ;;
  336.   ;;
  337.   ;;       tc      xv (xp - xr) + yv (yp - yr) + zv (zp - zr)
  338.   ;;  t = ---- = --------------------------------------------
  339.   ;;       tn                   xv2 + yv2 + zv2
  340.   ;;
  341.    (setq tc (apply '+ (mapcar '(lambda (xv xp xr)
  342.                                  (* xv (- xp xr)) )
  343.                         (cadr vl) pt (car vl) ))
  344.          tn (apply '+ (mapcar '(lambda (xv)
  345.                                  (* xv xv) )
  346.                         (cadr vl) )) )
  347.    (if (= 0 tn)
  348.        (prompt "\ndivbyzero in orthparamt!\007 ");(/ pi 2)
  349.        (/ tc tn) ) )
  350.  
  351.  
  352.  
  353. (defun ihlparam-t (vl1 vl2 / va vb vr vs aa bb ab subval as-r br-s)
  354.   ;; return: list of the two parameters extending the vectorized lines
  355.   ;;         'vl1'  and 'vl2' to the points of their smallest distance, if
  356.   ;;         they are parallel, starting out from the startpoint of 'vl1'.
  357.   ;;
  358.   ;;   p1 = vr + t1 va
  359.   ;;   p2 = vs + t2 vb
  360.   ;;
  361.   ;;   (vs + t2 vb - vr - t1 va).va = 0
  362.   ;;   (vs + t2 vb - vr - t1 va).vb = 0
  363.   ;;
  364.   ;;
  365.   ;;         (va.vb) ((vb.vr) - (vb.vs)) + (vb.vb) ((va.vs) - (va.vr))
  366.   ;;   t1 = -----------------------------------------------------------
  367.   ;;                      (va.va)(vb.vb) - (va.vb)(va.vb)
  368.   ;;
  369.   ;;         (va.vb) ((va.vs) - (va.vr)) + (vb.vb) ((vb.vr) - (va.vs))
  370.   ;;   t2 = -----------------------------------------------------------
  371.   ;;                      (va.va)(vb.vb) - (va.vb)(va.vb)
  372.   ;;
  373.   (setq va (cadr vl1)
  374.         vb (cadr vl2)
  375.         vr (car vl1)
  376.         vs (car vl2)
  377.         aa (dot-prod va va)
  378.         bb (dot-prod vb vb)
  379.         ab (dot-prod va vb)
  380.         as-r (- (dot-prod va vs) (dot-prod va vr))
  381.         br-s (- (dot-prod vb vr) (dot-prod vb vs))
  382.         subval (- (* aa bb) (* ab ab)) )
  383.   (if (= 0 subval)
  384.       (list 0.0 (orthparamt (car vl1) vl2))
  385.       (list (/ (+ (* ab br-s)(* bb as-r))
  386.                subval )
  387.             (/ (+ (* ab as-r)(* bb br-s))
  388.                subval ) ) ) )
  389.  
  390. ;;; DETERMINANTS ------------------------------------------------***
  391.  
  392. (defun 2det (va vb)
  393.  ;; 2-dimensional determinant
  394.  ;;
  395.  ;;                 ( xa xb )
  396.  ;;  [va, vb] = det ( ya yb ) 
  397.  ;;
  398.  ;;           = xa yb - xb ya
  399.  ;;
  400.   (- (* (car va)(cadr vb))
  401.      (* (cadr va)(car vb)) ) )
  402.  
  403.  
  404. (defun 3det (va vb vc)
  405.  ;; 3-dimensional determinant
  406.  ;;
  407.  ;;                    ( xa xb xc )
  408.  ;; [va, vb, vc] = det ( ya yb yc )
  409.  ;;                    ( za zb zc )
  410.  ;;
  411.  ;;              =   xa yb zc - za yb xc
  412.  ;;                + xb yc za - zb yc xa
  413.  ;;                + xc ya zb - zc ya xb
  414.  ;;
  415.   (apply '+ (mapcar '(lambda (a1 a3 b2 c1 c3)
  416.                        (- (* a1 b2 c3)
  417.                           (* a3 b2 c1) ) )
  418.               va (shift (shift va))
  419.               (shift vb)
  420.               vc (shift (shift vc)) )) )
  421.  
  422.  
  423. ;;;   --------------------------------------------------------***
  424.  
  425.  
  426. (defun intervectors (v1 v2 vn ai num / astep a1 a2 vect vlist)
  427.  ;; return: a list of one or more vectors interpolated regularly between
  428.  ;;         the vectors 'v2' and 'v2'.
  429.  ;;    'vn' must be a vector perpendicular to the other two.
  430.  ;;    'ai' must be the angle between the two vectors.
  431.  ;;    'num' is the number of vectors to return.
  432.   (setq astep (/ ai (1+ num))
  433.         a1 0 )
  434.   (repeat num
  435.      (setq a1 (+ a1 astep)
  436.            a2 (- ai a1)
  437.            vect (if (or (equal v1 v2)
  438.                         (equal v1 (mapcar '- v2)) )
  439.                     v1
  440.                     (3angvector v1 v2 vn (list (cos a1) (cos a2) 0)) )
  441.            vlist (append vlist (list vect)) ) )
  442.   vlist )
  443.  
  444.  
  445. (defun interpoints (dplist num / p1 p2 tstep vect plist)
  446.  ;; return: a list of one or more points interpolated regularly between
  447.  ;;         the points 'p2' and 'p2'.
  448.  ;;    'num' is the number of points to return.
  449.   (setq p1 (car dplist)
  450.         p2 (cadr dplist)
  451.         tstep (/ (distance p1 p2) (1+ num))
  452.         vect (vector p1 p2) )
  453.   (repeat num
  454.      (setq p1 (transl-p p1 vect tstep)
  455.            plist (append plist (list p1)) ) )
  456.   plist )
  457.  
  458.  
  459.  
  460. ;;; MATH *********************************************************
  461.  
  462. (defun mod (modulator moduland / res)
  463.  ;; return: 'moduland' mod 'modulator'.
  464.   (cond ( (<= modulator 0)
  465.           (prompt "\n\007negative modulator! ") )
  466.         ( T (setq res (- moduland (* modulator (fix (/ moduland modulator)))))
  467.             (if (>= 0 res)
  468.                 (setq res (+ res modulator)) ) ) )
  469.   res )
  470.  
  471. (defun fact (N / r)      ; n!
  472.   (setq r 1)
  473.   (while (< 1 (abs n))
  474.     (setq r (* r n)
  475.           n (1- n) ) )
  476.   r )
  477.  
  478. (defun grad (ang)       ; radians to grad ( pi -> 180 )
  479.   (* 180 (/ ang pi)) )
  480.  
  481.  
  482. ;;; MATRIX CALCULATIONS ************************************************
  483.  
  484. (defun matrix-to (vx vy vz)
  485.   (mapcar 'list vx vy vz) )
  486.  
  487.  
  488. (defun transf-p (vect matrix)
  489.   (mapcar '(lambda (mline)
  490.                    (apply '+ (mapcar '* vect mline)) )
  491.           matrix ) )
  492.  
  493.  
  494. (defun transf-vl (vl matrix)
  495.   (mapcar 'transf-p vl (list matrix matrix)) )
  496.  
  497.  
  498. (defun reverse-matrix ( matrix / xyz sxyz rxyz vallist det-a)
  499.   (setq xyz  (mapcar 'list (car matrix) (cadr matrix) (caddr matrix))
  500.         sxyz (mapcar 'shift xyz)
  501.         rxyz (mapcar 'shift sxyz)
  502.         vallist (mapcar '(lambda (ry sz sy rz)
  503.                                  (mapcar '(lambda (yc zb yb zc)
  504.                                                   (- (* yc zb)
  505.                                                      (* yb zc) ) )
  506.                                          ry sz sy rz ) )
  507.                         (shift rxyz)
  508.                         (shift (shift sxyz))
  509.                         (shift sxyz)
  510.                         (shift (shift rxyz)) )
  511.         det-a (apply '+ (mapcar '* (car vallist) (car xyz))) )
  512.   (mapcar '(lambda (line)
  513.                    (mapcar '/ line (list det-a det-a det-a)) )
  514.           vallist) )
  515.  
  516.  
  517. (defun rot-xy (vect rotang / cosa sina)
  518.   (setq cosa (cos rotang)
  519.         sina (sin rotang) )
  520.   (transf-p vect (list (list cosa (- sina)  0)
  521.                        (list sina     cosa  0)
  522.                           '(    0        0  1) )) )
  523.  
  524. (defun rot-3d-matrix (dir rotang / sina 1-cosa arot
  525.                           u v w uu vv ww uv vw wu te ta ta2)
  526.  ;; return: transformation-matrix rotating any point around the
  527.  ;;         axis with the direction 'dir' that goes through the 
  528.  ;;         origin of the coordinate-system.
  529.  ;; the rotation-angle 'rotang' is given in radians.
  530.   (setq sina   (sin rotang)
  531.         1-cosa (- 1 (cos rotang))
  532.         u (car dir)
  533.         v (cadr dir)
  534.         w (caddr dir)
  535.         uu (* u u)      uv (* u v)
  536.         vv (* v v)      vw (* v w)
  537.         ww (* w w)      wu (* w u)
  538.         TE '((1.0  0.0  0.0 )
  539.              (0.0  1.0  0.0 )
  540.              (0.0  0.0  1.0 ) )
  541.         TA  (list (list  0.0   (- w) v     )
  542.                   (list  w     0.0   (- u) )
  543.                   (list  (- v) u     0.0   ) )
  544.         TA2 (list (list  (- (+ vv ww))  uv            wu            )
  545.                   (list  uv             (- (+ ww uu)) vw            )
  546.                   (list  wu             vw            (- (+ uu vv)) ) ) )
  547.   (mapcar '(lambda (elin alin a2lin)
  548.                    (mapcar '(lambda (ex ax a2x)
  549.                                     (+ ex (* sina ax) (* 1-cosa a2x)) )
  550.                            elin alin a2lin ) )
  551.           TE TA TA2 ) )
  552.  
  553.  
  554.  
  555. (defun matmul (mx1 mx2)
  556.    (mapcar '(lambda (l1 )
  557.                (mapcar '(lambda (l2r)
  558.                            (apply '+ (mapcar '* l1 l2r)) )
  559.                    (mapcar 'list (car mx2)(cadr mx2)(caddr mx2)) ) )
  560.       mx1  ) )
  561.  
  562.  
  563.  
  564. ;;; TRANSFORMATION-MATRIX FROM WORLD-UCS TO ENTITY-CS.
  565. (defun ent_xform (data / xtilt ytilt ztilt mx1 inspt
  566.                          rotang mxrot xrot yrot zrot
  567.                          xstr ystr zstr )
  568.  
  569.   ;; tilted coordinates in bl-cs
  570.   (setq ztilt (cdr (assoc 210 data)) )   ; extrusion relative to world-z.
  571.   (cond ( (equal '(0.0 0.0 1.0) ztilt)
  572.           (setq xtilt '(1.0 0.0 0.0)
  573.                 ytilt '(0.0 1.0 0.0) ) )
  574.         ( (and (< (abs (car ztilt)) (/ 1.0 64.0))
  575.                (< (abs (cadr ztilt)) (/ 1.0 64.0)) )
  576.           (setq xtilt (vect-prod '(0.0 1.0 0.0) ztilt)
  577.                 ytilt (vect-prod  ztilt xtilt) ) )
  578.         (T (setq xtilt (vect-prod '(0.0 0.0 1.0) ztilt)
  579.                  ytilt (vect-prod  ztilt xtilt) ) ) )
  580.  
  581.   (setq mx1 (mapcar 'list xtilt ytilt ztilt)
  582.         inspt (transf-p (cdr (assoc 10 data)) mx1 ) )
  583.  
  584.   (cond ( (= "INSERT" (cdr (assoc 0 data)))
  585.        ;; rotated coordinates in bl-cs ucs
  586.        (setq rotang (cdr (assoc 50 data))
  587.              zrot ztilt)   ;; in radians!
  588.        (cond ( (and rotang (/= 0.0 rotang))
  589.                (if (equal '(0.0 0.0 1.0) ztilt)
  590.                    (setq xrot (rot-xy xtilt rotang)
  591.                          yrot (rot-xy ytilt rotang) )
  592.                    (setq mxrot (rot-3d-matrix zrot rotang)
  593.                          xrot (transf-p xtilt mxrot)
  594.                          yrot (transf-p ytilt mxrot) ) ) )
  595.              (T (setq xrot xtilt
  596.                       yrot ytilt )) )
  597.        
  598.        ;; stretched coorinates in bl-ucs
  599.        (setq xstr (extend-vect xrot (cdr (assoc 41 data)))
  600.              ystr (extend-vect yrot (cdr (assoc 42 data)))
  601.              zstr (extend-vect zrot (cdr (assoc 43 data))) )
  602.        
  603.        ;; transformation-matrix to world from if c-s of the entity.
  604.        (list (mapcar 'list xstr ystr zstr) inspt) )
  605.       (T (list  mx1 inspt)) ) )
  606.  
  607.  
  608. ;;; LIST MANIPULATIONS ********************************************************
  609.  
  610. (defun shift (alist)
  611.   (append (cdr alist) (list (car alist))) )
  612.  
  613. ;;;*****************************************************************************
  614. ;;; end of vector.lsp.
  615. ;;;*****************************************************************************
  616.