;;;****************************************************************************
;;;
;;; cyl.lsp - Create cylinders at arbitrary position in space.
;;;
;;; Georg Mischler 1995
;;;
;;;****************************************************************************
;;;
;;; The command CYL asks for a number of points (a polygon) and a radius.
;;; Then it generates cylinders (circles with thickness) to connect all points.
;;;
;;; Input library features:
;;;
;;; Polygon input is like drawing a 3DPOLY, but allows for relative points
;;; and centered points.
;;; To end the main polygon, enter <Return> or "C" for "close", which will
;;; cenerate an additional cylinder between start and endpoint of the polygon.
;;;
;;; If you enter "C" when the prompt contains "Centered: " then you can enter
;;; any number of points, which together form a sub-polygon.
;;; Ending that sub-polygon with <Return> selects the point in the arithmetic
;;; center of the points of the sub-polygon.
;;;
;;; Relative points can be entered when the prompt contains "Relative: "
;;; with "R". You can first enter the base point and then an offset as if
;;; you had entered the "@" character outside of a lisp function.
;;; (the "@" is inserted automatically).
;;;
;;; It is in the responsbility of the user to avoid confusion when nesting
;;; too many relative sub-polygons.
;;; If you want to know why only the first point in a polygon offers this
;;; "<Centered>/Relative" choice, try to make it yourself and tell me about
;;; the result.
;;;
;;;****************************************************************************
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted.
;;;
;;;    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.
;;;
;;;****************************************************************************


(defun c:cyl ( / ptl rad lay close)
  (cyl_setup)
  (setq ptl (askptlist T))
  (if (= 'STR (type (car ptl)))
      (setq close T
            ptl (append (cdr ptl) (list (cadr ptl))) ) )
  (setq ptl (mapcar '(lambda (pt)
                             (trans pt 1 0 ) )
                    ptl )
        rad (askreal "Radius" *cyl_rad* nil nil)
        *cyl_rad* rad
        lay (getvar "CLAYER") )
  (mapcar '(lambda (p0 p1)
                   (makecyl p0 p1 rad lay) )
          ptl (cdr ptl) )
  (cyl_reset) )


(defun makecyl (p0 p1 rad lay / thickn zvect mx)
  (setq thickn (distance p0 p1)
        zvect (if (equal 0 thickn 1E-07)
                  '(0.0 0.0 0.0)
                  (mapcar '(lambda (x1 x2)
                                   (/ (- x2 x1) thickn)) p0 p1) ) )
  (setq mx (reverse-matrix (get_arb_matrix zvect)))
  (make_circle (transf-p p0 mx) rad zvect lay thickn) )


;;;****************************************************************************
;;; from vector library ...

(defun get_arb_matrix ( ztilt / xtilt ytilt)
  ;; tilted coordinates in bl-cs
  (cond ( (equal '(0.0 0.0 1.0) ztilt)
          (setq xtilt '(1.0 0.0 0.0)
                ytilt '(0.0 1.0 0.0) ) )
        ( (and (< (abs (car ztilt)) (/ 1.0 64.0))
               (< (abs (cadr ztilt)) (/ 1.0 64.0)) )
          (setq xtilt (vect-prod '(0.0 1.0 0.0) ztilt)
                ytilt (vect-prod  ztilt xtilt) ) )
        (T (setq xtilt (vect-prod '(0.0 0.0 1.0) ztilt)
                 ytilt (vect-prod  ztilt xtilt) ) ) )
  (mapcar 'list xtilt ytilt ztilt) )


(defun reverse-matrix ( matrix / xyz sxyz rxyz vallist det-a)
  (setq xyz  (mapcar 'list (car matrix) (cadr matrix) (caddr matrix))
        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)) )
        det-a (apply '+ (mapcar '* (car vallist) (car xyz))) )
  (mapcar '(lambda (line)
                   (mapcar '/ line (list det-a det-a det-a)) )
          vallist) )


(defun vect-prod (v1 v2 / yzx)
  (setq yzx (shift (mapcar (quote list) v1 v2)))
  (normalize (mapcar '(lambda (yl zl)
                              (- (* (car yl) (cadr zl))
                                 (* (cadr yl) (car zl)) ) )
                     yzx (shift yzx) )) )


(defun normalize (vect / len)
  (setq len (distance '(0 0 0) vect))
  (if (equal 0 len 1E-07)
      vect
      (mapcar (quote (lambda (co) (/ co len))) vect) ) )


(defun transf-p (vect matrix)
  (mapcar '(lambda (mline)
                   (apply '+ (mapcar '* vect mline)) )
          matrix ) )



(defun shift (alst)
  (append (cdr alst) (list (car alst))) )


;;;****************************************************************************
;;; from input library ...


(defun askreal (msg old dft ini / val)
  ;; Real input.
  (terpri)
  (if ini (eval (cons 'initget ini)))
  (if msg
      (if (if old
              T  
              (setq old dft) )
          (princ (strcat msg " <" (rtos old) ">: "))
          (princ (strcat msg ": ")) )
      (prompt "real number: ") )
  (if (setq val (getdist))
      val
      old ) )


(defun askptlist (show / p0 ptlist )
  (setq p0 (askpoint "Startpoint" NIL T T NIL))
  (cond ( (null p0)
          (princ "\7") )
        (T (while (and p0 (/= "Close" p0))
                  (setq ptlist (cons p0 ptlist))
                  (cond ( (< 2 (length ptlist))
                          (initget "Close")
                          (setq p0 (getpoint p0 "next point or Close: ")) )
                        ( T (setq p0 (getpoint p0 "next point: ")) )
                        )
                  (cond ( (not show) NIL)
                        ( (= "Close" p0)
                          (grdraw (last ptlist) (car ptlist) -1) )
                        ( p0 (grdraw p0 (car ptlist) -1) )
                        ( T NIL) )
                  )
           (if (= "Close" p0)
               (cons "Close" (reverse ptlist))
               (reverse ptlist) )) ) )


(defun med (/ pl len)
  ;; input a point by surrounding.
  (setq pl (askptlist NIL)
        len (length pl))
  (if (< 0 len)
      (list (/ (apply '+ (mapcar 'car pl)) len)
            (/ (apply '+ (mapcar 'cadr pl)) len)
            (/ (apply '+ (mapcar 'caddr pl)) len) ) ) )


(defun askpoint (msg p0 mid rel ini / flag nmsg p1)
  (cond ( (and mid rel)
          (eval (cons 'initget (if ini
                                   (inicat ini 0 " Centered Relative")
                                   '("Centered Relative") )))
          (setq nmsg (strcat msg " oder <Centered>/Relative: ")) )
        ( mid
         (eval (cons 'initget (if ini
                                  (inicat ini 0 " Centered")
                                  '("Centered") )))
         (setq nmsg (strcat msg " or <Centered>: ")) )
        ( rel
         (eval (cons 'initget (if ini
                                  (inicat ini 0 " Relative")
                                  '("Relative") )))
         (setq nmsg (strcat msg " oder <Relative>: ")) )
        ( T
         (if ini (initget ini))
         (setq nmsg (strcat msg ": ")) ) )
  (setq p1 (if p0 (getpoint p0 nmsg)
               (getpoint nmsg) ))
  (cond ( (or (= "Centered"  p1)(and mid (null p1)))
          (med) )
        ( (or (= "Relative" p1)(and rel (null p1)))
          (askrelpoint) )
        ( T p1) ) )


(defun askrelpoint ()
  (setvar "LASTPOINT" (askpoint "Basepoint" NIL T NIL NIL))
  (mapcar '+ (getpoint "Offset: @")
          (getvar "LASTPOINT")) )


(defun inicat (ini num str / nnum nstr)
  ;; concatenate initget argument lists from different sources.
  (cond ( ini
         (if (= 'STR (type (last ini)))
             (setq nstr (strcat (last ini) str))
             (setq nstr str) )
         (if (numberp (car ini))
             (setq nnum (+ (car ini) num))
             (setq nnum num) )
         (list nnum nstr) )
        (T (list num str)) ) )



;;;****************************************************************************
;;; from entmake library ...

(defun make_circle (pt rad vect layer thickn)
  (entmake (list '(0 . "CIRCLE")
                 (cons 8 layer)
                 (cons 10 pt)
                 (cons 40 rad)
                 (cons 39 thickn)
                 (cons 210 vect) )) )


;;;****************************************************************************
;;; global-setup

(defun cyl_setup ()
  (setq *cyl_olderr* *error*
        *error* *cyl_error*)
  (command "undo" "group") )

(defun cyl_reset ()
  (setq *error* *cyl_olderr*)
  (command)
  (command "undo" "end")
  (princ) )

(defun *cyl_error* (msg)
  (cyl_reset) )


(princ "   ---   Command \"CYL\" defined   ---")
(princ)

;;;****************************************************************************
;;; end of cyl.lsp
;;;****************************************************************************