112 lines
3.3 KiB
Common Lisp
112 lines
3.3 KiB
Common Lisp
;;; --------------------------------------------------------------------------;
|
|
;;; RPOLY.LSP
|
|
;;; Copyright (C) 1990 by Autodesk, Inc.
|
|
;;;
|
|
;;; Entwickelt von Kelvin R. Throop im Oktober 1985
|
|
;;;
|
|
;;; Basierend auf der technischen Beschreibung von
|
|
;;; Philip J. Davis , "Circulant Matrices", Wiley 1979.
|
|
;;;
|
|
;;; --------------------------------------------------------------------------;
|
|
;;; BESCHREIBUNG
|
|
;;;
|
|
;;; Verfeinerung von beliebigen Polygonen durch zyklisches
|
|
;;; Ersetzen der Scheitelpunkte durch die Kantenmittelpunkte.
|
|
;;; Wie durch ein Wunder werden dann die meisten Polygone fr�her
|
|
;;; oder sp„ter zu elliptisch konvexen Gebilden.
|
|
;;;
|
|
;;; Fehler�berpr�fung und Fehlerbehandlungsroutine
|
|
;;; hinzugef�gt - April 1988
|
|
|
|
;;; Versionsnummer, Gummibandlinie, und die F„higkeit jeden Verfeinerungs-
|
|
;;; zyklus der Polylinie festzuhalten. Jeff Wilson 12. Juni 1990
|
|
;;;
|
|
;;; --------------------------------------------------------------------------;
|
|
|
|
(defun drawpoly (p / dp dl)
|
|
(setq dp p)
|
|
(setq dl (length p))
|
|
(command "plinie")
|
|
(repeat dl
|
|
(command (car dp))
|
|
(setq dp (cdr dp))
|
|
)
|
|
(command "s")
|
|
)
|
|
|
|
(defun myerror (s) ; Wenn ein Fehler (z.B. CTRL-C)
|
|
; w„hrend dieses Befehls auftritt
|
|
(if (/= s "Funktion abgebrochen")
|
|
(princ (strcat "\nFehler: " s))
|
|
)
|
|
(setvar "cmdecho" ocmd) ; "cmdecho" wiederherstellen
|
|
(setvar "blipmode" oblp) ; "blipmode" wiederherstellen
|
|
(setq *error* olderr) ; Fehlerroutine wiederherstellen
|
|
(princ)
|
|
)
|
|
|
|
(defun C:RPOLY (/ olderr ocmd oblp cycno pl p pvert cyc plast pn pe pc delpoly)
|
|
(princ "\nPolygonverfeinerung, Version 1.1 von Autodesk,Inc.")
|
|
(setq olderr *error*
|
|
*error* myerror)
|
|
(setq ocmd (getvar "cmdecho"))
|
|
(setq oblp (getvar "blipmode"))
|
|
(setvar "cmdecho" 0)
|
|
(setq cycno 0)
|
|
(setq pl nil)
|
|
(command "zur�ck" "mark")
|
|
(setq p1 (getpoint "\nErster Punkt: "))
|
|
(setq pl (cons p1 pl))
|
|
(while (setq p (getpoint p1 "\nN„chster Punkt: "))
|
|
(command "linie" p1 p "")
|
|
(setq p1 p)
|
|
(setq pl (cons p pl))
|
|
)
|
|
(command "zur�ck" "r�ck")
|
|
(setvar "blipmode" 0)
|
|
(setq pvert (length pl))
|
|
(if pl
|
|
(progn
|
|
(drawpoly pl)
|
|
(initget 6)
|
|
(while (setq cyc (getint "\nAnzahl Zyklen: "))
|
|
(initget "Ja Nein")
|
|
(setq delpoly
|
|
(getkword "Polygonform nach jedem Zyklus festhalten ? <J>/N: ")
|
|
)
|
|
(princ "Zyklen:")
|
|
(repeat cyc
|
|
(setq plast (nth (1- pvert) pl))
|
|
(setq pn nil)
|
|
(setq pe pl)
|
|
(repeat pvert
|
|
(setq pc (car pe))
|
|
(setq pe (cdr pe))
|
|
(setq pn (cons (list (/ (+ (car pc) (car plast)) 2)
|
|
(/ (+ (cadr pc) (cadr plast)) 2))
|
|
pn)
|
|
)
|
|
(setq plast pc)
|
|
)
|
|
(setq pl pn)
|
|
(setq cycno (1+ cycno))
|
|
(princ " ")
|
|
(princ cycno)
|
|
(if (cond
|
|
((= delpoly "Nein") t)
|
|
(t nil)
|
|
)
|
|
(command "l”schen" "l" "")
|
|
)
|
|
(drawpoly pn)
|
|
)
|
|
(initget 6)
|
|
)
|
|
)
|
|
)
|
|
(setvar "cmdecho" ocmd)
|
|
(setvar "blipmode" oblp)
|
|
(setq *error* olderr) ; Fehlerbehandlungsroutine wiederherstellen
|
|
(princ)
|
|
)
|
|
|