Author Topic: Pline Star for fun!  (Read 7896 times)

0 Members and 1 Guest are viewing this topic.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Pline Star for fun!
« on: March 07, 2009, 12:07:18 AM »
Star Lisp is an exercise & a way to show how to use the grread & grvecs functions.
I used subroutines I already had for most but did have to create one or two.
As this is a quick assembly of the code there may be a bug or two lurking.
I used the command circle to allow the use of osnaps with the radius but may
change that part of the code to grread as well. Note that the star pick for the
final size can be inside the first radius or you may drag outside the radius.
The star is created simply by dividing 360 degrees by the number of points chosen.

Have fun.

PS This is not a Star Polygon as that form has a fixed interior shape. This one is more fun.
I may add code for the Star Polygon if anyone need it.


<edit: Replaced lisp, bug fix.>
Code: [Select]
;;;=======================[ Star.lsp ]=======================
;;; Author: Copyright© 2009 Charles Alan Butler
;;; Version:  1.1 Mar. 07, 2009
;;; Purpose: To draw a pline star
;;; Sub_Routines: -See included
;;; Description: User enters the number of points, picks the
;;;   center point, picks or enters the inner/outer radius
;;;
;;;==========================================================
(defun C:STAR (/ np cp ent lastent rad usercmd
               ;;  localized functions
               *error* makePline activespace txt2num StarCalc GetUserPoint
              )
  (vl-load-com)

  ;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
  ;;  Local Functions Start Here
  ;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+

  (defun *error* (msg)
    (if (not
          (member msg '("console break" "Function cancelled" "quit / exit abort" "" nil))
        )
      (princ (strcat "\nError: " msg))
    )     ; if
    (and usercmd (setvar "CMDECHO" usercmd))
    (princ)
  )       ; end error function

  ;;  by CAB 10/05/2007
  ;;  Expects pts to be a list of 2D or 3D points
  ;;  Returns new pline object
  (defun makePline (spc pts)
    ;;  flatten the point list to 2d
    (if (= (length (car pts)) 2) ; 2d point list
      (setq pts (apply 'append pts))
      (setq pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts)))
    )
    (setq
      pts (vlax-make-variant
            (vlax-safearray-fill
              (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
              pts
            )
          )
    )
    (vla-addlightweightpolyline spc pts)
  )

;;; Returns object for active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
      (vla-get-modelspace doc)
      (vla-get-paperspace doc)
    )
  )

  ;;  CAB
  ;;+++++++++++++++++++++++++++++++
  ;;  convert the text to a number
  ;;+++++++++++++++++++++++++++++++
  (defun txt2num (txt / num)
    (or (setq num (distof txt 5))
        (setq num (distof txt 2))
        (setq num (distof txt 1))
        (setq num (distof txt 4))
        (setq num (distof txt 3))
    )
    num
  )

  ;;  calc points for star & return the list
  (defun StarCalc (cp np orad ip / ang iang irad 1stpt plst)
    (setq ang  (angle cp ip)
          iang (/ (* 2 pi) np)
          irad (distance cp ip)
          1stpt  (polar cp ang orad)
    )
    (repeat np
      (setq nxtpt (polar cp ang orad)
            plst  (cond (plst (cons nxtpt plst))
                        ((list nxtpt))
                  )
            plst  (cons (polar cp (+ ang (/ iang 2)) irad) plst)
            ang   (+ ang iang)
      )
    )
    (cons 1stpt plst)
  )

  ;;  grread subroutine to get user input & draw star w/ grvecs
  ;;  point picked will draw a pline star with picked inside diameter
  ;;  user may enter a number for the inside radius & press enter
  ;;  in this case the angle used to get the outer radius is used for
  ;;  the pline creation & not the angle from the grread
  (defun GetUserPoint (cp np orad lp msg / key str grr ip pr plst nLst lastpt doc num)
    (setq str "")
    (or msg (setq msg "\n"))
    (if (not (vl-string-search "\n" msg))
      (setq msg (strcat "\n" msg))
    )
    (princ msg)
    (while ; get the string from user, exit only for ENTER
      (cond
        ((eq 2 (car (setq grr (grread t 7 0)))) ; keyboard input
         (setq key (cadr grr))
         (cond
           ((= key 8) ; backspace
            (if (/= str "")
              (progn
                (setq str (substr str 1 (1- (strlen str))))
                (prompt (strcat (chr 8) " " (chr 8)))
              )
            )
            t ;stay in loop
           )
           ((= key 13) ; ENTER- where done here
            (if (and str (/= str "") (setq num (txt2num str)))
              (progn
                (setq plst (StarCalc cp np orad (polar cp (angle cp lp) num)))
                (setq Doc (vla-get-activedocument (vlax-get-acad-object)))
                (setq obj (makePline (activespace doc) (cdr pLst)))
                (vla-put-Closed obj :vlax-true)
              )
              (princ "\nUser Quit.")
            )
            nil ; exit loop
           )
           ((member (chr key) '("H" "h"))
             ;;--------------------------------------
             ;;  H E L P     message for dialog box.
             ;;--------------------------------------
             (alert
               (strcat
                 "Star.lsp                       (c) 2009 Charles Alan Butler"
                 "\nAbbreviated help at this time."
                 "\nThis LISP routine will allow you to draw a pline star."
                 "\nUser enters the number of points the picks the center for the"
                 "\nstar pline. The next radius is chossen with the mouse."
                 "\nPoint picked will draw a pline star with picked fixed diameter"
                 "\nuser may enter a number for the other radius & press enter"
                 "\nin this case the angle used to get the outer radius is used for"
                 "\nthe pline creation & not the angle from the grread"
                 "Please report any problems you may have. CAB at TheSwamp.org\n"
                 )
             )
             t ; stay in loop
           )
           ;;  if a valid key press add to string
           ((wcmatch (chr key) "[hH],[0-9],-,`#,` ,`,,`.")
            (if (or (null str) (= str ""))
              (setq str (chr key))
              (setq str (strcat str (chr key)))
            )
            (princ (chr key))

           )
           ((princ "\nInvalid Keypress.") (princ (strcat msg str)))
         ) ; end cond
        )
        ((eq 3 (car grr)) ; point picked, make final star
         (setq ip (cadr grr))
         (setq plst (StarCalc cp np orad ip))
         (setq Doc (vla-get-activedocument (vlax-get-acad-object)))
         (setq obj (makePline (activespace doc) (cdr pLst)))
         (vla-put-Closed obj :vlax-true)
         nil ; exit
        )
        ((eq 5 (car grr)) ; point from mouse, update star
         (setq ip (cadr grr))
         (if (or (null lastpt)
                 (> (distance ip lastpt) 0.00001)
             )
           (progn
             (setq plst (StarCalc cp np orad ip)
                   nLst nil
                   pr   nil
             )
             (mapcar
               '(lambda (x)
                  (cond
                    (pr   (setq nLst (cons x (cons pr nlst))
                                pr   x )
                    )
                    (nLst  (setq nLst (cons x nlst)
                                 pr   x )
                    )
                    ((setq nLst (list x)))
                  )
                )
                plst
             )
             (redraw)
             (grvecs (cons 256 nLst))
           )
         )
         (setq lastpt ip)
        )
        ;;((princ "\nKeyboard entry only."))
      )   ; end cond 1
    )     ; while
    (redraw)
    (princ)
  )




  ;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
  ;;  Routine Starts here
  ;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
  (setq usercmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (while
    (progn
      (initget 7)
      (setq np (getint "\nEnter the number of points >2 "))
      (or (null np)
          (and (< np 3)
               (princ "\nMust enter >2."))
      )
    )
  )
  (setq lastent (entlast))
  (if (and (setq cp (getpoint "\nPick the center point."))
           (listp cp)
      )
    (progn
      (command "_.circle" "_non" cp pause)
      (setq ent (entlast) ; get the circle ename
            lp  (getvar "lastpoint") ; get the point used to pick the raidus
      )
      (if (not (equal ent lastent)) ; make sure the circle was created
        (progn
          (setq rad (cdr (assoc 40 (entget ent))))
          (or (entdel ent) (princ)) ; debug CAB
          (getuserpoint cp np rad lp "\nPick size and angle or enter radius. ")
        )
        (princ) ; debug CAB
      )
    )
  )
  (*error* "")
  (princ)
)         ; end defun Star
(prompt "\nStar Loaded, enter Star to run.")
(princ)
« Last Edit: March 07, 2009, 06:01:19 PM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

gile

  • Gator
  • Posts: 2507
  • Marseille, France
Re: Pline Star for fun!
« Reply #1 on: March 07, 2009, 02:17:00 AM »
Nice one Cab,

Here's one I wrote some time ago. It draws star polygons, the user specify the number of points and the 'density'.

Code: [Select]
;;; StarPg (gile) 05/01/07
;;; Draws a star polygon
;;; The user specify the number of brunches and the density

(defun c:StarPg (/ br imax ind cen som ang dist n zdir lst1 lst2)
  (vl-load-com)
  (or *StarPointsNumber* (setq *StarPointsNumber* 5))
  (if (setq br (getint (strcat "\nEnter the number of points <"
       (itoa *StarPointsNumber*)
       ">: "
       )
       )
      )
    (setq *StarPointsNumber* br)
    (setq br *StarPointsNumber*)
  )
  (if (< 4 br)
    (progn
      (setq imax (fix (/ (- br 0.5) 2)))
      (if (< 2 imax)
(while (not (<= 2 ind imax))
  (if (not (setq
     ind (getint
   (strcat
     "\nEnter the density (from 2 to "
     (itoa imax)
     ") <"
     (itoa imax)
     ">: "
   )
)
   )
      )
    (setq ind imax)
  )
)
(setq ind imax)
      )
      (initget 1)
      (setq cen (getpoint "\nPick the star center: ")
    som cen
      )
      (while (equal cen som)
(initget 1)
(setq
  som (getpoint cen
"\nPick a point summit: "
      )
)
      )
      (setq ang (angle cen som)
    dist (distance cen som)
    n (* 2 br)
    zdir (trans '(0 0 1) 1 0 T)
      )
      (repeat br
(setq
  lst1
   (cons
     (polar cen (+ ang (/ (* (setq n (- n 2)) pi) br)) dist)
     lst1
   )
)
      )
      (repeat br
(setq lst2
       (cons (inters (nth n lst1)
     (nth (rem (+ n br (- ind)) br) lst1)
     (nth (rem (+ n (1- ind)) br) lst1)
     (nth (setq n (rem (+ n (1- br)) br)) lst1)
     )
     lst2
       )
)
      )
      (entmake
(append
  (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (* 2 br))
'(70 . 1)
(cons 38 (caddr (trans cen 1 zdir)))
(cons 210 zdir)
  )
  (mapcar
    (function
      (lambda (pt)
(cons 10 (trans pt 1 zdir))
      )
    )
    (apply 'append
   (apply 'mapcar (cons 'list (list lst1 lst2)))
    )
  )
)
      )
    )
    (prompt "\nThe number of points have to be greater than 4.")
  )
  (princ)
)
« Last Edit: March 07, 2009, 08:43:21 AM by CAB »
Speaking English as a French Frog

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Pline Star for fun!
« Reply #2 on: March 07, 2009, 08:39:37 AM »
Great, Thanks for sharing Gile.  8-)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

cjw

  • Guest
Re: Pline Star for fun!
« Reply #3 on: March 07, 2009, 12:01:58 PM »
Thank you!

Use grread... wowo...very funny... :-D

Quote
Star Lisp is an exercise & a way to show how to use the grread & grvecs functions.

Learn it...


ronjonp

  • Needs a day job
  • Posts: 7526
Re: Pline Star for fun!
« Reply #4 on: March 07, 2009, 03:25:50 PM »
Very cool Charles  8-)

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Pline Star for fun!
« Reply #5 on: March 07, 2009, 03:37:20 PM »
Thanks all.  :-)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Pline Star for fun!
« Reply #6 on: March 07, 2009, 06:02:43 PM »
Updated the code. Fixed bugs when using Backspace in numerical entries. & updated the Help.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

gile

  • Gator
  • Posts: 2507
  • Marseille, France
Re: Pline Star for fun!
« Reply #7 on: March 09, 2009, 06:59:39 AM »
Hi,

Since grread statments seems to be fashion these days, I add one (with some comments) to the code I gave upper.

DSTAR command:
- works whatever the current UCS,
- respects the current orthomode value,
- allows to toggle orthomode (using F8 transparently)
- accepts command line inputs: a point or the circumscribe circle radius (current radius is diplayed in the status line)
- loops through available densities (according to the number of points) while right clicking.

Code: [Select]
;;; DSTAR (gile) 2009/03/09
;;; Draws a star polygon
;;; The user specify the number of brunches, the star center and a point vertex location.

(defun c:dstar (/ *error* makestar br imax ind cen loop gr star str pt)

  ;;;======================== LOCAL SUB ========================;;;

  ;; Local *error*
  (defun *error* (msg)
    (or (= msg "Function cancelled")
(princ (strcat "Error: " msg))
     )
    (and star (entdel star) (setq star nil))
    (grtext)
    (princ)
  )

  ;; Creates the pline
  (defun makestar (cen ang dist br ind / n zdir lst1 lst2)
    (setq n    (* 2 br)
  zdir (trans '(0 0 1) 1 0 T)
    )
    (and (= (getvar "ORTHOMODE") 1) (setq ang (OrthoRound ang)))
    (repeat br
      (setq
lst1
(cons
   (polar cen (+ ang (/ (* (setq n (- n 2)) pi) br)) dist)
   lst1
)
      )
    )
    (repeat br
      (setq lst2
     (cons (inters (nth n lst1)
   (nth (rem (+ n br (- ind)) br) lst1)
   (nth (rem (+ n (1- ind)) br) lst1)
   (nth (setq n (rem (+ n (1- br)) br)) lst1)
   )
   lst2
     )
      )
    )
    (entmakex
      (append
(list '(0 . "LWPOLYLINE")
      '(100 . "AcDbEntity")
      '(100 . "AcDbPolyline")
      (cons 90 (* 2 br))
      '(70 . 1)
      (cons 38 (caddr (trans cen 1 zdir)))
      (cons 210 zdir)
)
(mapcar
  (function
    (lambda (pt)
      (cons 10 (trans pt 1 zdir))
    )
  )
  (apply 'append
(apply 'mapcar (cons 'list (list lst1 lst2)))
  )
)
      )
    )
  )

  ;;;======================== MAIN ========================;;;
 
  (or *StarPointNumber* (setq *StarPointNumber* 5))
  (if (setq br (getint (strcat "\nSpecify the number of points: <"
       (itoa *StarPointNumber*)
       ">: "
       )
       )
      )
    (setq *StarPointNumber* br)
    (setq br *StarPointNumber*)
  )
  (if (< 4 br)
    (progn
      (setq imax (fix (/ (- br 0.5) 2))
    ind imax
      )
      (initget 1)
      (setq cen (getpoint "\nSpecify the star center: ")
    loop T
      )
      (princ "\nSpecify a point vertex (or enter circle radius): ")

      ;; grread loop
      (while (and (setq gr (grread T 12 0)) loop)
(and star (entdel star) (setq star nil))
(cond

  ;; Dragging
  ((= 5 (car gr))
   (setq ang  (angle cen (cadr gr))
dist (distance cen (cadr gr))
   )
   (if (/= 0 dist)
     (setq star (makestar cen ang dist br ind))
   )
   (grtext -1 (strcat "Radius: " (rtos dist)))
  )

  ;; Picked point = ends loop
  ((= 3 (car gr))
    (makestar cen ang dist br ind)
    (setq loop nil)
    (grtext)
  )

  ;; Right click = loops through available densities
  ((member (car gr) '(11 25))
   (setq ind (+ 2 (rem (- (1+ ind) 2) (1- imax))))
  )

  ;; Enter = reads the command line input
  ((equal gr '(2 13))
    (cond

      ;; valid distance = ends loop
      ((and str (setq dist (distof str)) (< 0 dist))
(makestar cen ang dist br ind)
(setq loop nil)
(grtext)
      )

      ;; valid point = ends loop
      ((and str (setq pt (str->pt str)))
(makestar cen (angle cen pt) (distance cen pt) br ind)
(setq loop nil)
(grtext)
      )

      ;; invalid input
      (T
(setq str nil)
(princ "\nInvalid point or distance. Specify a point vertex (or enter circle radius): ")
      )
    )
  )

  ;; F8 = toggles orthomode
  ((equal gr '(2 15))
    (setvar "ORTHOMODE" (boole 6 1 (getvar "ORTHOMODE")))
    (princ (chr 8))
    (princ (chr 32))
  )

  ;; getting and printing command line input
  (T
   (if (= (cadr gr) 8) ;_ backspace
     (or
       (and str
    (/= str "")
    (setq str (substr str 1 (1- (strlen str))))
    (princ (chr 8))
    (princ (chr 32))
       )
       (setq str nil)
     )
     (or
       (and str (setq str (strcat str (chr (cadr gr)))))
       (setq str (chr (cadr gr)))
     )
   )
   (and str (princ (chr (cadr gr))))
  )
)
      )
    )
    (prompt "\nThe number of points have to be greater than 4.")
  )
  (princ)
)

;;;======================== SUB ROUTINES ========================;;;

;; OrthoRound
;; Returns the angle rounded to pi/2
;;
;; Argument: an angle (radians)

(defun OrthoRound (ang)
  (* (/ pi 2) (fix (/ (+ (/ pi 4) ang) (/ pi 2))))
)

;; STR2PT
;; Convert a string into a 3d point (input with grread)
;;
;; Argument: a string (ex: "25,63")
;; Return: a 3d point (ex (25.0 63.0 0.0) or nil if invalid string

(defun str2pt (str)
  (setq str (mapcar 'read (str2lst str ",")))
  (if (and (vl-every 'numberp str)
   (< 1 (length str) 4)
      )
    (trans str 0 0)
  )
)

;; STR2LST
;; Transforms a string with separator into a list of strings
;;
;; Arguments
;; str = the string
;; sep = the separator pattern

(defun str2lst (str sep / pos)
  (if (setq pos (vl-string-search sep str))
    (cons (substr str 1 pos)
  (str2lst (substr str (+ (strlen sep) pos 1)) sep)
    )
    (list str)
  )
)
« Last Edit: March 09, 2009, 07:03:11 AM by gile »
Speaking English as a French Frog

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Pline Star for fun!
« Reply #8 on: March 09, 2009, 09:18:25 AM »
Just took it for a test drive & worked great. 8-)

It is very well documented too, Thanks Gile.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.