home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 168.img / ACAD3.ZIP / RPOLY.LSP < prev    next >
Lisp/Scheme  |  1988-04-15  |  3KB  |  91 lines
  1.  
  2. ; ************************************************************************
  3. ;                              RPOLY.LSP
  4. ;
  5. ;       Written by Kelvin R. Throop in October 1985
  6. ;
  7. ;       Based on the technique described in Philip J. Davis,
  8. ;       "Circulant Matrices", Wiley 1979.
  9. ;
  10. ;       Refinement of a random polygon by iterative replacement of
  11. ;       its vertices by the midpoints of its edges.  This miraculously
  12. ;       transforms most random polygons into an ellipse-shaped convex
  13. ;       polygon.
  14. ;
  15. ;       Added error checking and an error function - April 1988
  16. ;
  17. ; ************************************************************************
  18.                                                                            
  19. (defun drawpoly (p / dp dl)
  20.         (setq dp p)
  21.         (setq dl (length p))
  22.         (command "pline")
  23.         (repeat dl
  24.            (command (car dp))
  25.            (setq dp (cdr dp))
  26.         )
  27.         (command "c")
  28. )
  29.  
  30. (defun myerror (s)                    ; If an error (such as CTRL-C) occurs
  31.                                       ; while this command is active...
  32.         (if (/= s "Function cancelled")
  33.            (princ (strcat "\nError: " s))
  34.         )
  35.         (setvar "cmdecho" ocmd)       ; Restore saved modes
  36.         (setvar "blipmode" oblp)
  37.         (setq *error* olderr)         ; Restore old *error* handler
  38.         (princ)
  39. )
  40.  
  41. (defun C:RPOLY (/ olderr ocmd oblp cycno pl p pvert cyc plast pn pe pc)
  42.         (setq olderr  *error*
  43.               *error* myerror)
  44.         (setq ocmd (getvar "cmdecho"))
  45.         (setq oblp (getvar "blipmode"))
  46.         (setvar "cmdecho" 0)
  47.         (setq cycno 0)
  48.         (setq pl nil)
  49.         (while (setq p (getpoint "Next point: "))
  50.            (setq pl (cons p pl))
  51.         )
  52.         (setvar "blipmode" 0)
  53.         (setq pvert (length pl))
  54.  
  55.         (if pl 
  56.            (progn
  57.               (drawpoly pl)
  58.               (initget 6)
  59.               (while (setq cyc (getint "\nCycle count: "))
  60.                  (repeat cyc
  61.                     (setq plast (nth (1- pvert) pl))
  62.                     (setq pn nil)
  63.                     (setq pe pl)
  64.                     (repeat pvert
  65.                        (setq pc (car pe))
  66.                        (setq pe (cdr pe))
  67.                        (setq pn (cons (list (/ (+ (car pc) (car plast)) 2)
  68.                                             (/ (+ (cadr pc) (cadr plast)) 2))
  69.                                       pn)
  70.                        )
  71.                        (setq plast pc)
  72.                     )
  73.                     (setq pl pn)
  74.                     (setq cycno (1+ cycno))
  75.                     (princ "Cycle ")
  76.                     (princ cycno)
  77.                     (terpri)
  78.                  )
  79.                  (command "erase" "l" "")
  80.                  (drawpoly pn)
  81.                  (command "zoom" "e")
  82.                  (initget 6)
  83.               )
  84.            )
  85.         )
  86.         (setvar "cmdecho" ocmd)
  87.         (setvar "blipmode" oblp)
  88.         (setq *error* olderr)         ; Restore old *error* handler
  89.         (princ)
  90. )
  91.