home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 5.img / R11SUPP.EXE / RPOLY.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1990-07-30  |  3.6 KB  |  117 lines
  1. ;;; --------------------------------------------------------------------------;
  2. ;;; RPOLY.LSP
  3. ;;;   Copyright (C) 1990 by Autodesk, Inc.
  4. ;;;  
  5. ;;;   Permission to use, copy, modify, and distribute this software and its
  6. ;;;   documentation for any purpose and without fee is hereby granted.  
  7. ;;;
  8. ;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. 
  9. ;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF 
  10. ;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
  11. ;;;
  12. ;;;   Written by Kelvin R. Throop in October 1985
  13. ;;;
  14. ;;;   Based on the technique described in Philip J. Davis,
  15. ;;;   "Circulant Matrices", Wiley 1979.
  16. ;;;
  17. ;;; --------------------------------------------------------------------------;
  18. ;;; DESCRIPTION
  19. ;;;
  20. ;;;   Refinement of a random polygon by iterative replacement of
  21. ;;;   its vertices by the midpoints of its edges.  This miraculously
  22. ;;;   transforms most random polygons into an ellipse-shaped convex
  23. ;;;   polygon.
  24. ;;;
  25. ;;;   Added error checking and an error function - April 1988
  26. ;;;
  27. ;;;   Added version number, line rubberbanding and the ability to 
  28. ;;;   retain each iteration of the polygon. Jeff Wilson 12June1990
  29. ;;;
  30. ;;; --------------------------------------------------------------------------;
  31. (defun drawpoly (p / dp dl)
  32.   (setq dp p)
  33.   (setq dl (length p))
  34.   (command "pline")
  35.   (repeat dl
  36.     (command (car dp))
  37.     (setq dp (cdr dp))
  38.   )
  39.   (command "c")
  40. )
  41.  
  42. (defun myerror (s)                    ; If an error (such as CTRL-C) occurs
  43.                                       ; while this command is active...
  44.   (if (/= s "Function cancelled")
  45.     (princ (strcat "\nError: " s))
  46.   )
  47.   (setvar "cmdecho" ocmd)             ; Restore saved modes
  48.   (setvar "blipmode" oblp)
  49.   (setq *error* olderr)               ; Restore old *error* handler
  50.   (princ)
  51. )
  52.  
  53. (defun C:RPOLY (/ olderr ocmd oblp cycno pl p pvert cyc plast pn pe pc delpoly)
  54.   (princ "\nRefine Polygon, Version 1.1 by Autodesk,Inc.")
  55.   (setq olderr  *error*
  56.         *error* myerror)
  57.   (setq ocmd (getvar "cmdecho"))
  58.   (setq oblp (getvar "blipmode"))
  59.   (setvar "cmdecho" 0)
  60.   (setq cycno 0)
  61.   (setq pl nil)
  62.   (command "undo" "mark")
  63.   (setq p1 (getpoint "\nFirst point: "))
  64.   (setq pl (cons p1 pl))
  65.   (while (setq p (getpoint p1 "\nNext point: "))
  66.     (command "line" p1 p "")
  67.     (setq p1 p)
  68.     (setq pl (cons p pl))
  69.   )
  70.   (command "undo" "back")
  71.   (setvar "blipmode" 0)
  72.   (setq pvert (length pl))
  73.   (if pl 
  74.     (progn
  75.       (drawpoly pl)
  76.       (initget 6)
  77.       (while (setq cyc (getint "\nNumber of cycles: "))
  78.         (initget "Yes No")
  79.         (setq delpoly 
  80.           (getkword "Retain polygon at each cycle? <Y>/N: ")
  81.         )
  82.         (princ "Cycles:")
  83.         (repeat cyc
  84.           (setq plast (nth (1- pvert) pl))
  85.           (setq pn nil)
  86.           (setq pe pl)
  87.           (repeat pvert
  88.             (setq pc (car pe))
  89.             (setq pe (cdr pe))
  90.             (setq pn (cons (list (/ (+ (car pc) (car plast)) 2)
  91.                                  (/ (+ (cadr pc) (cadr plast)) 2))
  92.                            pn)
  93.             )
  94.             (setq plast pc)
  95.           )
  96.           (setq pl pn)
  97.           (setq cycno (1+ cycno))
  98.           (princ " ")
  99.           (princ cycno)
  100.           (if (cond 
  101.                 ((= delpoly "No") t)
  102.                 (t nil)
  103.               )
  104.             (command "erase" "l" "")
  105.           )
  106.           (drawpoly pn)
  107.         )
  108.         (initget 6)
  109.       )
  110.     )
  111.   )
  112.   (setvar "cmdecho" ocmd)
  113.   (setvar "blipmode" oblp)
  114.   (setq *error* olderr)               ; Restore old *error* handler
  115.   (princ)
  116. )
  117.