;;--------------------------------------------------------------------------*
;;  Copyright 2005  TECHSOFT Rand                                           *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Dateiname: rund_eckig.lsp 
;;  Version  : 13.011      
;;  Datum    :               
;;  Author   : Schaumberger G
;;--------------------------------------------------------------------------*
;;  Modulbeschreibung: Volumenmodell : Uebergang eckig auf rund             *
;;                                                                          *
;;                                                                          *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Hilfsmittel:                                                            *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Zugehoerige Moduln:                                                     *
;;     Name     |    Kurzbeschreibung                                       *
;;              |                                                           *
;;              |                                                           *
;;--------------------------------------------------------------------------*
;;  Wichtige Informationen:                                                 *
;;--------------------------------------------------------------------------*
;;  Anderungsverzeichnis:                                                   *
;;   Version   |  Datum   |   Autor    |  Beschreibung                      *
;;             |          |            |                                    *
;;             |          |            |                                    *
;;--------------------------------------------------------------------------*

;;--------------------------------------------------------------------------*
;;     in-packages                                                          *
;;--------------------------------------------------------------------------*

(in-package :custom)

;;--------------------------------------------------------------------------*
;;     use-packages                                                         *
;;--------------------------------------------------------------------------*

(use-package :OLI)
 
;;--------------------------------------------------------------------------*
;;     export                                                               *
;;--------------------------------------------------------------------------*
(export '(
         )
)

;;--------------------------------------------------------------------------*
;;     global variables                                                     *
;;--------------------------------------------------------------------------*

(defvar *ts-rund-eckig-l*)
(defvar *ts-rund-eckig-b*)
(defvar *ts-rund-eckig-h*)
(defvar *ts-rund-eckig-d*)
(defvar *ts-rund-eckig-r*)
(defvar *ts-rund-eckig-teilung*)
(defvar *ts-rund-eckig-versatz-x*)
(defvar *ts-rund-eckig-versatz-y*)

(setf *ts-rund-eckig-l* 1000)
(setf *ts-rund-eckig-b* 600)
(setf *ts-rund-eckig-h* 500)
(setf *ts-rund-eckig-d* 300)
(setf *ts-rund-eckig-r* 30)
(setf *ts-rund-eckig-teilung* 5)

(setf *ts-rund-eckig-l* 760)
(setf *ts-rund-eckig-b* 470)
(setf *ts-rund-eckig-h* 600)
(setf *ts-rund-eckig-d* 450)
(setf *ts-rund-eckig-r* 5)
(setf *ts-rund-eckig-teilung* 5)
(setf *ts-rund-eckig-versatz-x* 0)
(setf *ts-rund-eckig-versatz-y* 0)

(defvar *ts-rund-eckig-ist-aussen*)
(setf *ts-rund-eckig-ist-aussen* nil)


(defvar *ts-rund-eckig-s*)
(setf *ts-rund-eckig-s* 1)
(defvar *ts-rund-eckig-st*)
(setf *ts-rund-eckig-st* 10)

(defvar *ts-rund-eckig-global-p1*)
(defvar *ts-rund-eckig-global-p2*)
(defvar *ts-rund-eckig-global-p3*)
(defvar *ts-rund-eckig-global-ar*)
(defvar *ts-rund-eckig-global-ir*)

;;***************************************************************************
;;     DIALOGS                                                              *
;;***************************************************************************

(sd-defdialog 'ts-rund-eckig-dialog
;;:toolbox-button nil
:dialog-title '(sd-multi-lang-string "Round->Square" :german "Rund->Eckig" :schinese "Round->Square")
:toolbox-button t
:dialog-type :terminate
:dialog-control :parallel
:variables 
  `(
     (name_merken)
     (besitzer_s :initial-value "/")
     (name :value-type :string
           :initial-value (sd-gen-obj-basename :part :parent "/")
           :title ,(sd-multi-lang-string
                          "Name"
                  :german "Name")
           :prompt-text ,(sd-multi-lang-string "Enter the name of the new part." :german "Name des neuen Teils angeben." :schinese "Enter the name of the new part."
                         )
           :before-input (setf name_merken name)
           :after-input
             ;; Check ob Teil schon ex
             (progn
               (when (check-teil-vorhanden name besitzer_s)
                  (progn
                    (sd-display-error (sd-multi-lang-string "Name exists or not valid" :german "Name bereits vorhanden od. ungültig" :schinese "Name exists or not valid")
                    )
                    (setf name name_merken)
                  )
               )
             )
     )
     (besitzer :value-type :assembly
           :title ,(sd-multi-lang-string
                          "Owner"
                  :german "Besitzer")
           :prompt-text ,(sd-multi-lang-string "Specify the assembly that will be the owner." :german "Baugruppe, die Besitzer werden soll, angeben." :schinese "Specify the assembly that will be the owner.")
               :initial-value (sd-pathname-to-obj "/")
               :after-input
                 (progn
                   (besitzer-string-setzen)
                   (setf new-name (name-setzen))
                   (when (sd-string/= new-name "")
                      (sd-set-variable-status 'name :value new-name)
                   )
                 )
     )
    (t1 :title ,(sd-multi-lang-string "dimensions on bottom" :german "Abmessungen Unten" :schinese "dimensions on bottom"))
    (l :value-type :positive-length
          :title ,(sd-multi-lang-string "Length" :german "Länge" :schinese "Length")
	  :prompt-text ,(sd-multi-lang-string "Enter length of rectangle" :german "Länge des Rechteckes angeben." :schinese "Enter length of rectangle")
          :initial-value *ts-rund-eckig-l*
          :after-input (setf *ts-rund-eckig-l* l)
    )
    (b :value-type :positive-length
          :title ,(sd-multi-lang-string "Width" :german "Breite" :schinese "Width")
          :prompt-text ,(sd-multi-lang-string "Enter with of rectangle" :german "Breite des Rechteckes angeben." :schinese "Enter with of rectangle")
          :initial-value *ts-rund-eckig-b*
          :after-input (setf *ts-rund-eckig-b* b)
    )
    (r :value-type :positive-length
          :title ,(sd-multi-lang-string "Radius" :german "Radius" :schinese "Radius")
          :prompt-text ,(sd-multi-lang-string "Enter radius of fillet on the edges of the rectange" :german "Rundungsradius an den Eckpunkten des Rechteckes angeben." :schinese "Enter radius of fillet on the edges of the rectange")
          :initial-value *ts-rund-eckig-r*
          :after-input (setf *ts-rund-eckig-r* r)
    )
    (t2 :title ,(sd-multi-lang-string "dimensions on top" :german "Abmessungen Oben" :schinese "dimensions on top"))
    (d :value-type :positive-length
          :title ,(sd-multi-lang-string "Diameter" :german "Durchmesser" :schinese "Diameter")
          :prompt-text ,(sd-multi-lang-string "Enter diameter of top circle" :german "Durchmesser angeben." :schinese "Enter diameter of top circle")
          :initial-value *ts-rund-eckig-d*
          :after-input (setf *ts-rund-eckig-d* d)
    )
    (d_ist_aussen :value-type :boolean
          :title ,(sd-multi-lang-string "Outer diameter to use" :german "Durchmesser ist aussen" :schinese "Outer diameter to use")
          :toggle-type :wide-toggle
          :initial-value *ts-rund-eckig-ist-aussen* 
          :after-input (setf *ts-rund-eckig-ist-aussen* t)
    )
    (d_ist_innen :value-type :boolean
          :title ,(sd-multi-lang-string "Inner diameter to use" :german "Durchmesser ist innen" :schinese "Inner diameter to use")
          :title ,(sd-multi-lang-string "Diameter" :german "Durchmesser" :schinese "Diameter")
          :toggle-type :wide-toggle
          :initial-value (not *ts-rund-eckig-ist-aussen*)
          :after-input (setf *ts-rund-eckig-ist-aussen* nil)
    )
    (versatz-x :value-type :length
          :title ,(sd-multi-lang-string "X-Offset" :german "Versatz X" :schinese "X-Offset")
          :prompt-text ,(sd-multi-lang-string "Enter offset in x direction." :german "Versatz in X Richtung angeben." :schinese "Enter offset in x direction.")
          :initial-value *ts-rund-eckig-versatz-x*
          :after-input (setf *ts-rund-eckig-versatz-x* versatz-x)
    )
    (versatz-y :value-type :length
          :title ,(sd-multi-lang-string "Y-Offset" :german "Versatz Y" :schinese "Y-Offset")
          :prompt-text ,(sd-multi-lang-string "Enter offset in y direction." :german "Versatz in Y Richtung angeben." :schinese "Enter offset in y direction.")
          :initial-value *ts-rund-eckig-versatz-y*
          :after-input (setf *ts-rund-eckig-versatz-y* versatz-y)
    )
    ("")
    (h :value-type :positive-length
          :title ,(sd-multi-lang-string "Height" :german "Höhe" :schinese "Height")
          :prompt-text ,(sd-multi-lang-string "Enter height" :german "Breite H angeben." :schinese "Enter height")
          :initial-value *ts-rund-eckig-h*
          :after-input (setf *ts-rund-eckig-h* h)
    )
    (teilung :value-type :positive-integer
          :title ,(sd-multi-lang-string "Partition" :german "Teilung" :schinese "Partition")
          :prompt-text ,(sd-multi-lang-string "Enter partition (Number of segments on 90°)" :german "Teilung (Anzahl der Segmente auf 90°) angeben" :schinese "Enter partition (Number of segments on 90°)")
          :check-function ts-rund-eckig-check-teilung
          :initial-value *ts-rund-eckig-teilung*
          :after-input (setf *ts-rund-eckig-teilung* teilung)
    )
    (t3 :title ,(sd-multi-lang-string "Slot" :german "Schlitz" :schinese "Slot"))
    (s :value-type :positive-length
          :title ,(sd-multi-lang-string "Width" :german "Breite" :schinese "Width")
          :prompt-text ,(sd-multi-lang-string "Enter width of slot" :german "Breite des Schlitzes angeben." :schinese "Enter width of slot")
          :initial-value *ts-rund-eckig-s*
          :after-input (setf *ts-rund-eckig-s* s)
    )
    (st :value-type :positive-length
          :title ,(sd-multi-lang-string "Depth" :german "Tiefe" :schinese "Depth")
          :prompt-text ,(sd-multi-lang-string "Enter depth of slot" :german "Tiefe des Schlitzes angeben." :schinese "Enter depth of slot")
          :initial-value *ts-rund-eckig-st*
          :after-input (setf *ts-rund-eckig-st* st)
    )
    
   )
:mutual-exclusion '((d_ist_aussen d_ist_innen))
:local-functions
  '(
    ;;---------------------------------------------------
    (check-teil-vorhanden (n bes_s)
      (let (teil_exist teilename)
        (if (sd-string= bes_s "/")
          (setf teilename (format nil "/~a" n))
          (setf teilename (format nil "~a/~a" bes_s n))
        )

        (setf teil_exist (sd-pathname-to-obj teilename))

        teil_exist
      )
    )
    ;;---------------------------------------------------
    (name-setzen ()
     (let (teilename teil_exist new-name)

        (if (check-teil-vorhanden name besitzer_s)
          (setf new-name (sd-gen-obj-basename :part :parent besitzer_s))
          (setf new-name "")
        )

        new-name
     )
    )
    ;;---------------------------------------------------
    (besitzer-string-setzen ()
       (setf besitzer_s (sd-inq-obj-pathname besitzer))
    ) ;; end besitzer-string-setzen
    ;;---------------------------------------------------


    (volumen-erzeugen ()
     (let (curr_wp nwp1 nwp2)

      (cond 
       ((>= r (/ l 2.0))
         (sd-display-error (sd-multi-lang-string 
              "Radius has to be less than the half of the length of the rectangele" 
              :german "Radius darf nicht grösser als die halbe Rechtecklänge sein."
              :schinese "Radius has to be less than the half of the length of the rectangele" 
                           )
         )
       )
       (t
         (volumen-erzeugen2)
       )
      )
     )
    )

    (volumen-erzeugen2 ()
     (let (curr_wp nwpset nwp1 nwp2 nwp3 p1 p2 p3 p4 p5 p6 p7 p8
           p11 p12 p21 p22 p31 p32 p41 p42
           p1_3d p2_3d 
           teilename_pfad curr_geom_mode
           p_schlitz_2 p_schlitz_1 p_schlitz_3
           v23 v12 vnormal vx_dir l12
          )

      (setf curr_geom_mode (sd-inq-geometry-mode))
      (sd-call-cmds (GEOMETRY_MODE :REAL))

      (if (sd-string= besitzer_s "/")
        (setf teilename_pfad (format nil "/~a" name))
        (setf teilename_pfad (format nil "~a/~a" besitzer_s name))
      )

      (setf curr_wp (sd-inq-curr-wp))

      (setf nwpset (sd-gen-obj-basename :wpset :parent "/"))
      (sd-call-cmds (create_wpset :name nwpset :owner "/"))
      (setf nwpset (format nil "/~a" nwpset))

      (setf nwp2 (sd-gen-obj-basename :workplane :parent nwpset))
      (sd-call-cmds (create_workplane :new :owner nwpset :name nwp2
                       :pt_pt_pt (make-gpnt3d :x versatz-x :y versatz-y :z h)
                                 (make-gpnt3d :x (+ versatz-x 1) :y versatz-y :z h)
                                 (make-gpnt3d :x versatz-x :y (+ versatz-y 1) :z h)))
      (sd-call-cmds (ts-rund-eckig-vieleck 0,0 (/ d 2.0) 
            teilung d_ist_aussen))
      (setf p2_3d (make-gpnt3d :x (gpnt2d_x *ts-rund-eckig-global-p1*)
                               :y (gpnt2d_y *ts-rund-eckig-global-p1*)
                               :z 0.0)) ;; 0.0 weil select 2D Koordinaten liefert
      (setf p_schlitz_2 (sd-vec-xform 
           (make-gpnt3d :x (gpnt2d_x *ts-rund-eckig-global-p2*)
                        :y (gpnt2d_y *ts-rund-eckig-global-p2*)
                        :z 0.0)
           :source-space (sd-inq-curr-wp)
           :dest-space :global))
      (setf p_schlitz_3 (sd-vec-xform 
           (make-gpnt3d :x (gpnt2d_x *ts-rund-eckig-global-p3*)
                        :y (gpnt2d_y *ts-rund-eckig-global-p3*)
                        :z 0.0)
           :source-space (sd-inq-curr-wp)
           :dest-space :global))
      ;;(display (format nil "p_schlitz_2 = ~a" p_schlitz_2))
      ;;(display (format nil "p_schlitz_3 = ~a" p_schlitz_3))

      ;;(display (format nil "p2_3d = ~a" p2_3d))
      
      (setf vertex2 (get-vertex p2_3d))
      ;;(display (format nil "vertex2 = ~a" vertex2))
      
      (setf nwp1 (sd-gen-obj-basename :workplane :parent nwpset))
      (sd-call-cmds (create_workplane :new :owner nwpset :name nwp1
                       :pt_pt_pt 0,0,0 1,0,0 0,1,0))


      (setf p1 (make-gpnt2d :x (/ l -2.0) :y (/ b -2.0)))
      (setf p11 (make-gpnt2d :x (/ l -2.0) :y (+ (/ b -2.0) r)))
      (setf p12 (make-gpnt2d :x (+ (/ l -2.0) r) :y (/ b -2.0)))
      (setf p2 (make-gpnt2d :x (/ l 2.0) :y (/ b -2.0)))
      (setf p21 (make-gpnt2d :x (- (/ l 2.0) r) :y (/ b -2.0)))
      (setf p22 (make-gpnt2d :x (/ l 2.0) :y (+ (/ b -2.0) r)))
      (setf p3 (make-gpnt2d :x (/ l 2.0) :y (/ b 2.0)))
      (setf p31 (make-gpnt2d :x (/ l 2.0) :y (- (/ b 2.0) r)))
      (setf p32 (make-gpnt2d :x (- (/ l 2.0) r) :y (/ b 2.0)))
      (setf p4 (make-gpnt2d :x (/ l -2.0) :y (/ b 2.0)))
      (setf p41 (make-gpnt2d :x (+ (/ l -2.0) r) :y (/ b 2.0)))
      (setf p42 (make-gpnt2d :x (/ l -2.0) :y (- (/ b 2.0) r)))
      (setf p5 (make-gpnt2d :x 0.0 :y (/ b -2.0)))
      (setf p6 (make-gpnt2d :x (/ l 2.0) :y 0.0))
      (setf p7 (make-gpnt2d :x 0.0 :y (/ b 2.0)))
      (setf p8 (make-gpnt2d :x (/ l -2.0) :y 0.0))

      ;;(sd-call-cmds (polygon p22 :points p6 p31))
      ;;(sd-call-cmds (polygon p32 :points p7 p41))
      ;;(sd-call-cmds (polygon p42 :points p8 p11))
      ;;(sd-call-cmds (polygon p12 :points p5 p21))
      (setf pm1 (make-gpnt2d :x (+ (/ l -2.0) r) :y (+ (/ b -2.0) r)))
      (setf pm2 (make-gpnt2d :x (- (/ l 2.0) r) :y (+ (/ b -2.0) r)))
      (setf pm3 (make-gpnt2d :x (- (/ l 2.0) r) :y (- (/ b 2.0) r)))
      (setf pm4 (make-gpnt2d :x (+ (/ l -2.0) r) :y (- (/ b 2.0) r)))
      (sd-call-cmds (ts-rund-eckig-bogen-zeichnen pm1 r pi teilung *ts-rund-eckig-global-ar* p8 p5))
      (sd-call-cmds (ts-rund-eckig-bogen-zeichnen pm2 r (* pi 1.5) teilung *ts-rund-eckig-global-ar* p5 p6))
      (sd-call-cmds (ts-rund-eckig-bogen-zeichnen pm3 r 0 teilung *ts-rund-eckig-global-ar* p6 p7))
      (sd-call-cmds (ts-rund-eckig-bogen-zeichnen pm4 r (* pi 0.5) teilung *ts-rund-eckig-global-ar* p7 p8))

      (setf p1_3d (make-gpnt3d :x (gpnt2d_x p6) :y (gpnt2d_y p6) :z 0.0))
      (setf vertex1 (get-vertex p1_3d))

      ;;(display (format nil "vertex1 = ~a" vertex1))

      ;;(display (format nil "*ts-rund-eckig-global-p1* = ~a" *ts-rund-eckig-global-p1*))


      (sd-call-cmds (create_match_line vertex1 vertex2))
      (sd-call-cmds (add_loft :loft_part teilename_pfad :tool nwpset))

      ;;(sd-call-cmds (delete_3d nwpset))

      (sd-call-cmds (ts-rund-eckig-definiere-feature h versatz-x versatz-y))

      ;;  -------------------------------------------------------------
      ;; den Schlitz machen
      (setf p_schlitz_1 (make-gpnt3d :x 0.0 :y (/ b -2.0) :z 0.0))
      (setf v23 (sd-vec-normalize (sd-vec-subtract p_schlitz_3 p_schlitz_2)))
      (setf v12 (sd-vec-subtract p_schlitz_2 p_schlitz_1))
      (setf l12 (sd-vec-length v12))
      (setf v12 (sd-vec-normalize v12))
      (setf vnormal (sd-vec-normalize (sd-vec-cross-product v23 v12)))
      (setf vx_dir (sd-vec-cross-product v12 vnormal))
      (setf p_schlitz_4 (sd-vec-add p_schlitz_1 vx_dir))

      ;;(display (format nil "p_schlitz_1 = ~a" p_schlitz_1))
      ;;(display (format nil "v23 = ~a" v23))
      ;;(display (format nil "v12 = ~a" v12))
      ;;(display (format nil "vnormal = ~a" vnormal))
      ;;(display (format nil "vx_dir = ~a" vx_dir))
      ;;(display (format nil "p_schlitz_4 = ~a" p_schlitz_4))

      (setf nwp1 (sd-gen-obj-basename :workplane :parent "/"))
      (sd-call-cmds (create_workplane :new :owner "/" :name nwp1
                       :pt_pt_pt p_schlitz_1 p_schlitz_4 p_schlitz_2))
      (sd-call-cmds (RECTANGLE (make-gpnt2d :x (* s -0.5) :y (* l12 -1.0))
                               (make-gpnt2d :x (* s 0.5) :y (* l12 2.0))))
      (sd-call-cmds (mill :type :DISTANCE_TYPE :distance st :direction :-w  
                      :keep_wp :no))

      (when curr_wp (sd-call-cmds (current_wp curr_wp)))
     )
    )

    (get-vertex ( pkt )
     (let (alle_vertex v (vert nil) vek p (fehler nil))
      ;; leider ist der Punkt nicht ueber :select pkt selektierbar
      ;;  weiss nicht warum !!
      ;; daher hier diese Lsg
      (setf alle_vertex (sd-call-cmds (get_selection
                       :curr_wp_only
                       :focus_type *sd-match-vertex-2d-seltype*
                       :select :all_2d) :failure (setf fehler t)))
      (loop while (and (not vert) alle_vertex) 
      do
       (progn

        (setf v (pop alle_vertex))
        (setf p (sd-inq-vertex-geo v))
        ;;(display (format nil "p=~a" p))
        (setf vek (sd-vec-subtract p pkt))
        (when (or (sd-vec-null-p vek)
                (< (sd-vec-length vek) 0.00001)
            )
         (setf vert v)
        )
       )
      ) ;; loop

      vert
     )
    )


   )
:ok-action
  '(progn
     (volumen-erzeugen)
   )
)

;;***************************************************************************
;;     CHECK-FUNCTIONS                                                      *
;;***************************************************************************

(defun ts-rund-eckig-check-teilung ( teilung )

  (if (> teilung 2)
    :ok
    (values :error (sd-multi-lang-string "Partition has to be greater than 2"
                     :german "Teilung muss grösser als 2 sein."
                     :schinese "Partition has to be greater than 2"
                   ))
  )
)

;;***************************************************************************
;;     FUNCTIONS                                                            *
;;***************************************************************************

(defun ts-rund-eckig-bogen-zeichnen ( pm radius startwi teilung arad pvor pnach)
 (let (z v wi p0 p1 wi_2 evn r2)


  (setf v (make-gpnt2d :x radius :y 0.0))
  (setf v (ts-rund-eckig-vec2-rotate-cs v startwi))
  (setf evn (sd-vec-normalize (ts-rund-eckig-vec2-rotate-cs v (/ pi 2.0))))
  (setf wi (/ (/ pi 2.0) teilung))
  (setf wi_2 (/ wi 2.0))
  (setf r2 (/ radius (cos wi_2)))
  (setf y1 (* (tan wi_2) radius))

  (setf p1 (sd-vec-add pm v))
  (setf p1 (sd-vec-add p1 (sd-vec-scale evn y1)))
  (sd-call-cmds (line :two_points pvor p1))

  (setf v (sd-vec-subtract p1 pm))
  (dotimes (z (- teilung 1))
   (progn
     (setf p0 (sd-vec-add pm (ts-rund-eckig-vec2-rotate-cs v (* wi z))))
     (setf p1 (sd-vec-add pm (ts-rund-eckig-vec2-rotate-cs v (* wi (+ z 1)))))
     (sd-call-cmds (line :two_points p0 p1))
   )
  )
  (sd-call-cmds (line :two_points p1 pnach))

 )
)

(defun ts-rund-eckig-definiere-feature (h versatz-x versatz-y)
  (let ((fehler nil) kanten)

   (setf kanten (sd-call-cmds (get_selection
                       :focus_type *sd-edge-3d-seltype*
                       :curr_part_only
                       ;;:check-function #'ts-rund-eckig-prufe-dir-xy
                       :select :start :all_3d
                       :remove :by_face 0,0,0
                               :by_face (make-gpnt3d :x versatz-x :y versatz-y :z h)
                       :select_done
     :failure (setf fehler t))))


   ;;(display "KANTEN")
   ;;(display kanten)
   ;;(display (format nil "length(kanten) = ~a" (length kanten)))

   (sd-call-cmds (define_feature :selection kanten :name 
    (sd-multi-lang-string "Edges_for_bending" :german "Kanten_zum_Biegen" :schinese "Edges_for_bending")))
  )
)

(defun ts-rund-eckig-prufe-dir-xy ( l )
 (display "ts-rund-eckig-prufe-dir-xy")
 :ok
)

;;--------------------------------------------------------------------------*
;;     Funktion: ts-rund-eckig-vieleck                                      *
;;     kopiert und modifiziert aus der Funktion ts-vieleck                  *
;;                                                                          *
;;     Parameter :                                                          *
;;                 mpkt ... Mittelpunkt des Vieleckes                       *
;;                 rad  ... Radius des Vieleckes                            *
;;                 anz  ... Anzahl der Eckpunkte  des Vieleckes             *
;;                           (mindestens 3)                                 *
;;                 aussen ... t ... rad ist Aussenradius des Vieleckes      *
;;                            nil ... rad ist Innenradius des Vieleckes     *
;;                                                                          *
;;     Returnwert: -----------                                              *
;;                                                                          *
;;  Schaumberger G.   03.06.1997                                            *
;;-------------------------------------------------------------------------*/
(defun ts-rund-eckig-vieleck (mpkt rad teilung aussen)
 (let ( wi p p2 p3 p4 p5 i v innenrad y richt_p  anz
      )

  (setf anz (* teilung 4))
  (setf wi (/ (* 2 pi) anz))

  (when (equal aussen nil)
    ;; Berechnung des Aussenradius
    (progn
      (setf rad (/ rad (cos (/ wi 2))))
    )
  )

  (setf innenrad (* rad (cos (* wi 0.5))))
  (setf y (* rad (sin (* wi 0.5))))
  (setf richt_p (make-gpnt2d :x innenrad :y (* y -1.0)))
  (setf v (sd-vec-subtract richt_p mpkt))
  (setf v (sd-vec-normalize v))
  (setf p (sd-vec-scale v rad)) ;; erster Punkt
  (setf i 0)
  (loop until (= i anz)
   do
    (progn
     (setf p2 (ts-rund-eckig-vec2-rotate-cs p wi)) ;; naechster Punkt
     (if (equal (mod i teilung) 0)
      (progn
       (setf p3 (sd-vec-add mpkt p))
       (setf p4 (sd-vec-add mpkt p2))
       (setf p5 (sd-vec-scale (sd-vec-add p3 p4) 0.5))
       (sd-call-cmds (line :two_points  p3 p5
                                        p5 p4))
      )
      (progn
       (sd-call-cmds (line :two_points (sd-vec-add mpkt p)
                       (sd-vec-add mpkt p2)))
      )
     )
     (setf p p2)
     (incf i)
    ) ;; progn
  ) ;; loop

  (setf *ts-rund-eckig-global-p1* (make-gpnt2d :x innenrad :y 0.0))
  (setf *ts-rund-eckig-global-p2* (make-gpnt2d :x 0.0 :y (* innenrad -1.0)))
  (setf *ts-rund-eckig-global-p3* (make-gpnt2d :x y :y (* innenrad -1.0)))
  (setf *ts-rund-eckig-global-ir* innenrad)
  (setf *ts-rund-eckig-global-ar* rad)

 
 ) ;; let
)
;;--------------------------------------------------------------------------*
;;     Funktion: ts-rund-eckig-vec2-rotate-cs                               *
;;                                                                          *
;;               kopierte Funktion ts-vec2-rotate-cs                        *
;;                                                                          *
;;               Rotiert Vector um den Winkel wi um den Ursprung            *
;;                                                                          *
;;     Parameter : wi ... Winkel in Bogenmass                               *
;;                 v ... Vektor, welcher rotiert werden soll                *
;;                                                                          *
;;     Returnwert: rotierter Vektor                                         *
;;                                                                          *
;;  Schaumberger G.    3.4.1996                                             *
;;-------------------------------------------------------------------------*/
(defun ts-rund-eckig-vec2-rotate-cs ( v wi)
   (let ((x)
         (y))
     (setf x (- (* (gpnt2d_x v) (cos wi))
                (* (gpnt2d_y v) (sin wi))))
     (setf y (+ (* (gpnt2d_x v) (sin wi))
                (* (gpnt2d_y v) (cos wi))))
     (make-gpnt2d :x x :y y)
   ) 
)