Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 310297
Tên lệnh: gcd
hỏi vấn đề tạo liên kết LSP và dialog DCL

Bác Tot trả lời nhanh quá!

Mần cho Thanhduan rồi đây:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/27610-hoi-van-de-tao-lien-ket-lsp-va-dialog-dcl/page-3
(defun C:GCD ( / dcl_id  LtsLayer LtsStyle h Text_ghichu )
(setq dcl_id (load_dialog "GHICHU.DCL"))
(if (not (new_dialog "GHICHU" dcl_id))
 (exit)
)
  
(action_tile "Text_ghichu"  "(setq TextGhiChu...
>>

Bác Tot trả lời nhanh quá!

Mần cho Thanhduan rồi đây:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/27610-hoi-van-de-tao-lien-ket-lsp-va-dialog-dcl/page-3
(defun C:GCD ( / dcl_id  LtsLayer LtsStyle h Text_ghichu )
(setq dcl_id (load_dialog "GHICHU.DCL"))
(if (not (new_dialog "GHICHU" dcl_id))
 (exit)
)
  
(action_tile "Text_ghichu"  "(setq TextGhiChu $value)")
(mode_tile "Text_ghichu" 2)
(action_tile "Height_Text"  "(setq h $value)")
(mode_tile "Height_Text" 2)
 
(start_list "LTSLAY")
(mapcar 'add_list (setq LstLayer (Getlayer)))
(end_list)
  
(if #CurLay
(set_tile "LTSLAY" #CurLay)
(set_tile "LTSLAY"  "0")
)
(action_tile "LTSLAY" "(setq #CurLay $value)")
 
(if (null #Color) (setq #Color 2))
(fill-rec "color" #color )
(action_tile "color" "(if (setq #color (acad_colordlg #color)) (fill-rec \"color\" #color ))")
 
 
(start_list "LTSTEXTSTYLE")
(mapcar 'add_list (setq LstTextStyle (GetTextStyle)))
(end_list)
  
 
(if #CurStyle
(set_tile "LTSTEXTSTYLE" #CurStyle)
(set_tile "LTSTEXTSTYLE" "Standard")
)
(action_tile "LTSTEXTSTYLE" "(setq #CurStyle $value)")
 
(if (not TextGhiChu) (setq TextGhiChu (get_tile "Text_ghichu")))
(if (not #CurLay) (setq #CurLay (get_tile "LTSLAY")))
(if (not #CurStyle) (setq #CurStyle (get_tile "LTSTEXTSTYLE")))
  
(action_tile "Accept" "(setq UseButton 1)(done_dialog)")
(action_tile "Cancel" "(setq UseButton 2)(done_dialog)")
 
(start_dialog)
(unload_dialog dcl_id)
(if (= UseButton 1)
(progn
 (GCT TextGhiChu h #CurLay #CurStyle #color)
)
)
(if (= UseButton 2)
(alert (strcat "\nTho\U+00E1t"))
)
(Princ)
)
(defun Getlayer ( / lyr l)
  (setq l nil)
  (vlax-for lyr
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
       )
        )
    (setq l (cons (vla-get-name lyr) l))
  )
  l
)
(defun GetTextStyle ( / styl_ l)
  (setq l nil)
  (vlax-for styl_
(vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
       )
        )
    (setq l (cons (vla-get-name styl_) l))
  )
  l
)
(defun GCT(TextGhiChu h LayerText TextStyle col / i Olmode Gocxoay);;;;GHI CHU TEXT
  (command "Style" "Times New Roman"  "Times New Roman"  0 1 0 "" "" "" )
  (while (setq P1 (Getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n TEXT ghi ch\U+00FA: "))
(setq P2 (Getpoint  P1 "\nChon huong ghi chu TEXT: "))
   (setq Gocxoay (Angle (trans P1 1 0)
                             (trans P2 1 0)
     )
)
(entmake (list  (cons 0 "TEXT") (cons 10 P1) (cons 8 (nth (atoi LayerText) LstLayer))
(cons 40 (atof h)) (cons 50 Gocxoay)
(cons 7 (nth (atoi TextStyle) LstTextStyle)) (cons 1 TextGhiChu) (cons 62 col) ))  
  )
)
;;;-------------------------------------------------------------
(defun fill-rec (MyTile col / x y)
(start_image MyTile)
(setq x (dimx_tile MyTile) y (dimy_tile MyTile))
(fill_image 0 0 x y col)
(end_image)

DCL:

GHICHU

: dialog

{

label = "Ch\U+01B0\U+01A1ng tr\U+00ECnh ghi ch\U+00FA";

            : boxed_column

            {

                        : edit_box

                        {

                                    label = "Nh\U+1EADp t\U+00EAn c\U+1EA7n vi\U+1EBFt ghi ch\U+00FA";

                                    key = "Text_ghichu";

                                    edit_width = 30;

                                    alignment = left;

                                    edit_limit = 50;

                                    value = "Vi\U+1EBFt ghi ch\U+00FA v\U+00E0o \U+0111\U+00E2y";

 

                        }

                        //:row{

                        : edit_box

                        {

                                    label = "Nh\U+1EADp chi\U+1EC1u cao ch\U+1EEF:";

                                    key = "Height_Text";

                                    edit_width = 3.0;

                                    alignment = left;

                                    edit_limit = 5;

                                    value = 1;

                        }

                        //}

            }

            : boxed_column

            {

            : row

                        {

                         : column

                         {

                              : popup_list

                              {

                                  label       = "L\U+1EF1a ch\U+1ECDn Layer" ;

                                  key         = "LTSLAY" ;

                                  edit_width  = 50 ; 

                                  list        = "" ;

                                  alignment = left;

                              }

                              : popup_list

                              {

                                  label       = "L\U+1EF1a ch\U+1ECDn TextStyle" ;

                                  key         = "LTSTEXTSTYLE" ;

                                  edit_width  = 50 ; 

                                  list        = "" ;

                                  alignment = left;

                              }

                                    :image_button{key = "color"; width=1; height=2; alignment=centered;}

                         }

                        }

            }         

            : boxed_column

            {

                        : button

                        {

                                    label = "Pick >>>";

                                    key = "Accept";

                                    is_default = true;

                                    fixed_width = centered;

                        }

                        : button

                        {

                                    label = "H\U+1EE7y";

                                    key = "Cancel";

                                    is_default = false;

                                    fixed_width = centered;

                        }

 

            }

 

}

;; free lisp from cadviet.com
(defun C:GCD ( / dcl_id  LtsLayer LtsStyle h Text_ghichu )
(setq dcl_id (load_dialog "GHICHU.DCL"))
(if (not (new_dialog "GHICHU" dcl_id))
 (exit)
)
  
(action_tile "Text_ghichu"  "(setq TextGhiChu $value)")
(mode_tile "Text_ghichu" 2)
(action_tile "Height_Text"  "(setq h $value)")
(mode_tile "Height_Text" 2)
 
(start_list "LTSLAY")
(mapcar 'add_list (setq LstLayer (Getlayer)))
(end_list)
  
(if #CurLay
(set_tile "LTSLAY" #CurLay)
(set_tile "LTSLAY"  "0")
)
(action_tile "LTSLAY" "(setq #CurLay $value)")
 
(if (null #Color) (setq #Color 2))
(fill-rec "color" #color )
(action_tile "color" "(if (setq #color (acad_colordlg #color)) (fill-rec \"color\" #color ))")
 
 
(start_list "LTSTEXTSTYLE")
(mapcar 'add_list (setq LstTextStyle (GetTextStyle)))
(end_list)
  
 
(if #CurStyle
(set_tile "LTSTEXTSTYLE" #CurStyle)
(set_tile "LTSTEXTSTYLE" "Standard")
)
(action_tile "LTSTEXTSTYLE" "(setq #CurStyle $value)")
 
(if (not TextGhiChu) (setq TextGhiChu (get_tile "Text_ghichu")))
(if (not #CurLay) (setq #CurLay (get_tile "LTSLAY")))
(if (not #CurStyle) (setq #CurStyle (get_tile "LTSTEXTSTYLE")))
  
(action_tile "Accept" "(setq UseButton 1)(done_dialog)")
(action_tile "Cancel" "(setq UseButton 2)(done_dialog)")
 
(start_dialog)
(unload_dialog dcl_id)
(if (= UseButton 1)
(progn 
 (GCT TextGhiChu h #CurLay #CurStyle #color)
)
)
(if (= UseButton 2)
(alert (strcat "\nTho\U+00E1t"))
)
(Princ)
)
(defun Getlayer ( / lyr l)
  (setq l nil)
  (vlax-for lyr
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
       )
        ) 
    (setq l (cons (vla-get-name lyr) l))
  )
  l
)
(defun GetTextStyle ( / styl_ l)
  (setq l nil)
  (vlax-for styl_
(vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
       )
        ) 
    (setq l (cons (vla-get-name styl_) l))
  )
  l
)
(defun GCT(TextGhiChu h LayerText TextStyle col / i Olmode Gocxoay);;;;GHI CHU TEXT
  (command "Style" "Times New Roman"  "Times New Roman"  0 1 0 "" "" "" )
  (while (setq P1 (Getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n TEXT ghi ch\U+00FA: "))
(setq P2 (Getpoint  P1 "\nChon huong ghi chu TEXT: "))
   (setq Gocxoay (Angle (trans P1 1 0)
                             (trans P2 1 0)
     )
(entmake (list  (cons 0 "TEXT") (cons 10 P1) (cons 8 (nth (atoi LayerText) LstLayer))
(cons 40 (atof h)) (cons 50 Gocxoay)
(cons 7 (nth (atoi TextStyle) LstTextStyle)) (cons 1 TextGhiChu) (cons 62 col) ))   
  )
)
;;;-------------------------------------------------------------
(defun fill-rec (MyTile col / x y)
(start_image MyTile)
(setq x (dimx_tile MyTile) y (dimy_tile MyTile))
(fill_image 0 0 x y col)
(end_image)
)
;; free lisp from cadviet.com
(defun C:GCD ( / dcl_id  LtsLayer LtsStyle h Text_ghichu )
(setq dcl_id (load_dialog "GHICHU.DCL"))
(if (not (new_dialog "GHICHU" dcl_id))
 (exit)
)
  
(action_tile "Text_ghichu"  "(setq TextGhiChu $value)")
(mode_tile "Text_ghichu" 2)
(action_tile "Height_Text"  "(setq h $value)")
(mode_tile "Height_Text" 2)
 
(start_list "LTSLAY")
(mapcar 'add_list (setq LstLayer (Getlayer)))
(end_list)
  
(if #CurLay
(set_tile "LTSLAY" #CurLay)
(set_tile "LTSLAY"  "0")
)
(action_tile "LTSLAY" "(setq #CurLay $value)")
 
(if (null #Color) (setq #Color 2))
(fill-rec "color" #color )
(action_tile "color" "(if (setq #color (acad_colordlg #color)) (fill-rec \"color\" #color ))")
 
 
(start_list "LTSTEXTSTYLE")
(mapcar 'add_list (setq LstTextStyle (GetTextStyle)))
(end_list)
  
 
(if #CurStyle
(set_tile "LTSTEXTSTYLE" #CurStyle)
(set_tile "LTSTEXTSTYLE" "Standard")
)
(action_tile "LTSTEXTSTYLE" "(setq #CurStyle $value)")
 
(if (not TextGhiChu) (setq TextGhiChu (get_tile "Text_ghichu")))
(if (not #CurLay) (setq #CurLay (get_tile "LTSLAY")))
(if (not #CurStyle) (setq #CurStyle (get_tile "LTSTEXTSTYLE")))
  
(action_tile "Accept" "(setq UseButton 1)(done_dialog)")
(action_tile "Cancel" "(setq UseButton 2)(done_dialog)")
 
(start_dialog)
(unload_dialog dcl_id)
(if (= UseButton 1)
(progn 
 (GCT TextGhiChu h #CurLay #CurStyle #color)
)
)
(if (= UseButton 2)
(alert (strcat "\nTho\U+00E1t"))
)
(Princ)
)
(defun Getlayer ( / lyr l)
  (setq l nil)
  (vlax-for lyr
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
       )
        ) 
    (setq l (cons (vla-get-name lyr) l))
  )
  l
)
(defun GetTextStyle ( / styl_ l)
  (setq l nil)
  (vlax-for styl_
(vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
       )
        ) 
    (setq l (cons (vla-get-name styl_) l))
  )
  l
)
(defun GCT(TextGhiChu h LayerText TextStyle col / i Olmode Gocxoay);;;;GHI CHU TEXT
  (command "Style" "Times New Roman"  "Times New Roman"  0 1 0 "" "" "" )
  (while (setq P1 (Getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n TEXT ghi ch\U+00FA: "))
(setq P2 (Getpoint  P1 "\nChon huong ghi chu TEXT: "))
   (setq Gocxoay (Angle (trans P1 1 0)
                             (trans P2 1 0)
     )
(entmake (list  (cons 0 "TEXT") (cons 10 P1) (cons 8 (nth (atoi LayerText) LstLayer))
(cons 40 (atof h)) (cons 50 Gocxoay)
(cons 7 (nth (atoi TextStyle) LstTextStyle)) (cons 1 TextGhiChu) (cons 62 col) ))   
  )
)
;;;-------------------------------------------------------------
(defun fill-rec (MyTile col / x y)
(start_image MyTile)
(setq x (dimx_tile MyTile) y (dimy_tile MyTile))
(fill_image 0 0 x y col)
(end_image)
)

<<

Filename: 310297_gcd.lsp
Tác giả: pphung183
Bài viết gốc: 310305
Tên lệnh: troy
Giải trí với Lisp đi nào!

;-------------------------------------------------------------------------------
; Program Name: Troy.lsp  - Asteroids AutoLISP game
; Created By:   Terry Miller (Email: terrycadd@yahoo.com)
;               (URL: http://web2.airmail.net/terrycad)
;               For the International version of this game, download Troy-I.lsp
;               from the above website.
; Date Created: 1-20-06
; Notes:        Troy is an Asteroids AutoLISP game driven by the grread...
>>
;-------------------------------------------------------------------------------
; Program Name: Troy.lsp  - Asteroids AutoLISP game
; Created By:   Terry Miller (Email: terrycadd@yahoo.com)
;               (URL: http://web2.airmail.net/terrycad)
;               For the International version of this game, download Troy-I.lsp
;               from the above website.
; Date Created: 1-20-06
; Notes:        Troy is an Asteroids AutoLISP game driven by the grread function.
;               It can be run inside of an existing drawing. When it's finished,
;               it purges all entities, styles and layers it created. You have
;               three ships to use to shoot down as many Troys as possible. If
;               a Troy runs into your ship, it blows up your ship and you loose
;               10 points. Each Troy you blow up, you gain its value in points.
;               Use the mouse to keep the game moving. Pick the mouse to fire
;               at Troys. Each fire cost you 1 point. Press P to pause the game.
;               Press Q to quit the game before it ends, in order to purge all
;               entities, styles and layers it created. If you press the escape
;               key to abort the game, simply rerun Troy again and select the
;               Clear option. So do not press the escape key to abort the game.
; Disclaimer:   This program is free to download and share and learn from. It
;               contains many useful functions that may be applied else where.
;               Every effort on my part has been to create a grread game that
;               will run in most versions of AutoCAD, and when finished it will
;               return to the environment before it started.  Troy is now yours
;               to tweak, debug, add to, rename, use parts of, or create another
;               grread game from. It is now your responsibility when, and within
;               what drawings you should run it. If you are unsure of how it may
;               affect certain drawing environments, do a saveas before running
;               it. Do not save a drawing without running the Troy Clear option.
;-------------------------------------------------------------------------------
; Revision History
; Rev  By     Date    Description
;-------------------------------------------------------------------------------
; 1    TM   1-20-06   Initial version.
; 2    TM   6-20-06   Revised PurgeGroups function.
; 3    TM   6-24-06   Revised program to switch to the Model tab if there are
;                     viewports on the current Layout tab.
; 4    TM   6-26-06   Added Settings option to adjust number of Troys, speed of
;                     Troys and Color Scheme.
; 5    TM   1-1-07    The *_nth list functions were revised for maximum speed.
;-------------------------------------------------------------------------------
; c:Troy - Asteroids AutoLISP game
;-------------------------------------------------------------------------------
(defun c:Troy (/ Colors$ Loop Option$ Settings$)
  (initget "Intro Clear Settings Play")
  (if (not (setq Option$ (getkword "\nTroy options : ")))
    (setq Option$ "Play")
  );if
  (cond
    ((= Option$ "Clear")(TroyClear)(princ "\nTroy objects Cleared."))
    ((= Option$ "Settings")
      (initget "Troys Speed Colors Defaults")
      (if (not (setq Settings$ (getkword "\nSettings : ")))
        (setq Settings$ "Defaults")
      );if
      (cond
        ((= Settings$ "Troys")
          (setq Loop t)
          (while Loop
            (if (not (setq *MinTroys#* (getint "\nMinimum number of Troys <5>: ")))
              (setq *MinTroys#* 5)
            );if
            (if (not (setq *MaxTroys#* (getint "\nMaximum number of Troys <10>: ")))
              (setq *MaxTroys#* 10)
            );if
            (if (or (< *MinTroys#* 1) (<= *MaxTroys#* *MinTroys#*))
              (princ "\nThe maximum number must be greater than the minimum number,\nand the minimum number must be greater than 0.")
              (setq Loop nil)
            );if
          );while
          (if (> *MaxTroys#* 20)
            (princ "\nIncreasing the maximum number of Troys may slow down the game.")
          );if
        );case
        ((= Settings$ "Speed")
          (setq Loop t)
          (while Loop
            (if (not (setq *TroySpeed~* (getreal "\nAdjust speed of Troys\nEnter a number between 0.5 and 5.0 <1.0>: ")))
              (setq *TroySpeed~* 1.0)
            );if
            (if (or (< *TroySpeed~* 0.5)(> *TroySpeed~* 5.0))
              (princ "\nThe number must in the range of 0.5 to 5.0.\nThe larger the number the faster the Troys move.")
              (setq Loop nil)
            );if
          );while
        );case
        ((= Settings$ "Colors")
          (initget "Bright Dim Ghost")
          (if (not (setq Colors$ (getkword "\nColor Scheme : ")))
            (setq Colors$ "Bright")
          );if
          (setq *ColorScheme#*
            (cond
              ((= Colors$ "Bright") 1)
              ((= Colors$ "Dim")    2)
              ((= Colors$ "Ghost")  3)
            );cond
          );setq
        );case
        ((= Settings$ "Defaults")
          (setq *MinTroys#* 5 *MaxTroys#* 10 *TroySpeed~* 1.0 *ColorScheme#* 1)
        );case
      );cond
      (c:Troy)
    );case
    (t (Troy Option$))
  );if
  (princ)
);defun c:Troy
;-------------------------------------------------------------------------------
; Troy - Troy main function
;-------------------------------------------------------------------------------
(defun Troy (Option$ / AddArray: Ang~ AxisPt BuildShip: CenPt ChangeArray: CirAng~
  CirEnt^ CirLimits~ CirPt1 CirPt2 Color1 Color1_5 Color2 Color3 Color4 Color5
  Color6 Color7 Color8 Cnt# Code# Counter# CreateArray: Dia1~ Dia2~ Direction#
  Dist~ Ent^ Ent1^ Ent2^ Flame$ Flame^ FlameArray@ HalfStep~ Inc# Inc1~ Inc2~
  Increase~ Item Limit# Loop MainEnt^ MainList@ MainNum# NorthEast NorthWest
  Nth# Nths@ Num# NumSteps# Offset~ OldDirection# Option$ Passed Pnts# Points#
  Previous@ Pt Pt1 Pt2 Pt3 Pt4 Pt5 Pt6 Pt7 Pt8 Pt9 Pt10 Pt11 Pt12 Radius~ Read@
  Refresh: Rotate~ ShipName$ SouthEast SouthWest SS& StepDist~ SubList@ TextEnt^
  Total# TroyArray@ Unit~ Value ViewExtents@ ViewSize~ Xmin~ Xmax~ Ymin~ Ymax~)
  ;-----------------------------------------------------------------------------
  ; AddArray: - Add new Troy entity specs to the TroyArray@ list
  ; Arguments: 1
  ;   StartPt = Specify starting point or nil
  ; Returns: A list of a new random Troy specs to be added to TroyArray@ list
  ;-----------------------------------------------------------------------------
  (defun AddArray: (StartPt / Ang~ Num#)
    (if StartPt
      (setq CirPt1 StartPt)
      (setq CirPt1 (polar CenPt (* (GetRnd 6283) 0.001) CirLimits~))
    );if
    (setq Num# (GetRnd 8))
    (setq StepDist~;Determines Troys Speed
      (cond;                                   Points Dia Units
        ((= Num# 0)(* Unit~ 0.100 *TroySpeed~*));50     2.0
        ((= Num# 1)(* Unit~ 0.125 *TroySpeed~*));75     2.5
        ((= Num# 2)(* Unit~ 0.150 *TroySpeed~*));100    3.0
        ((= Num# 3)(* Unit~ 0.175 *TroySpeed~*));125    3.5
        ((= Num# 4)(* Unit~ 0.200 *TroySpeed~*));150    4.0
        ((= Num# 5)(* Unit~ 0.225 *TroySpeed~*));175    4.5
        ((= Num# 6)(* Unit~ 0.250 *TroySpeed~*));200    5.0
        ((= Num# 7)(* Unit~ 0.275 *TroySpeed~*));225    5.5
        ((= Num# 8)(* Unit~ 0.300 *TroySpeed~*));250    6.0
      );cond
    );setq
    (setq HalfStep~ (/ StepDist~ 2.0))
    (setq Points# (+ (* Num# 25) 50));50 to 250
    (setq Radius~ (/ (* Unit~ (* 0.1 (+ (+ (* Num# 5) 10) 10))) 2.0))
    (command "CIRCLE" CirPt1 Radius~)
    (setq Ent1^ (entlast))
    (command "CHPROP" Ent1^ "" "C" Color8 "")
    (command "HATCH" "AR-CONC" (* (getvar "VIEWSIZE") 0.0045) "" Ent1^ "")
    (setq Ent2^ (entlast))
    (command "CHPROP" Ent2^ "" "C" Color8 "")
    (command "-GROUP" "C" (UniqueName) "" Ent1^ Ent2^ "")
    (setq CirEnt^ (entlast))
    (setq CirAng~ (+ (- (angle CirPt1 CenPt) (dtr 30)) (* (GetRnd 1047) 0.001)))
    (setq CirPt2 (polar CirPt1 CirAng~ StepDist~))
    (setq Offset~ (+ (* Radius~ 2)(* Radius~ (GetRnd 10))))
    (setq Ang~ (atan (/ HalfStep~ Offset~)))
    (setq Pt (polar CirPt1 CirAng~ HalfStep~))
    (if (< CirAng~ (angle CirPt1 CenPt))
      (setq AxisPt (polar Pt (+ CirAng~ (dtr 90)) Offset~) Direction# 1)
      (setq AxisPt (polar Pt (- CirAng~ (dtr 90)) Offset~) Direction# -1)
    );if
    (setq NumSteps# (+ (GetRnd 10) 2))
    (list CirEnt^ CirPt1 CirPt2 AxisPt Radius~ Direction# NumSteps# Points#)
  );defun AddArray:
  ;-----------------------------------------------------------------------------
  ; ChangeArray: - Change or Move entity in the TroyArray@ list
  ; Arguments: 1
  ;   List@ = A sublist within the TroyArray@ list
  ; Returns: Changes or Moves Troy entities in the TroyArray@ list
  ;-----------------------------------------------------------------------------
  (defun ChangeArray: (List@ / Ang~ Num#)
    (setq CirEnt^ (nth 0 List@)
          CirPt1 (nth 1 List@)
          CirPt2 (nth 2 List@)
          AxisPt (nth 3 List@)
          Radius~ (nth 4 List@)
          Direction# (nth 5 List@)
          NumSteps# (nth 6 List@)
          Points# (nth 7 List@)
          StepDist~ (distance CirPt1 CirPt2)
          HalfStep~ (/ StepDist~ 2.0)
          Ang~ (- (* pi 0.5)(acos (/ HalfStep~ (distance AxisPt CirPt2))))
    );setq
    (command "MOVE" CirEnt^ "" CirPt1 CirPt2)
    (setq NumSteps# (1- NumSteps#))
    (if (= NumSteps# 0)
      (progn
        (setq NumSteps# (+ (GetRnd 10) 2))
        (setq OldDirection# Direction#)
        (setq Num# (GetRnd 10))
        (if (> Num# 5)
          (setq Direction# 1);ccw
          (setq Direction# -1);cw
        );if
        (setq Offset~ (+ (* Radius~ 2)(* Radius~ (GetRnd 10))))
        (if (= OldDirection# 1);ccw
          (if (= Direction# 1);ccw
            (setq AxisPt (polar CirPt2 (angle CirPt2 AxisPt) Offset~))
            (setq AxisPt (polar CirPt2 (angle AxisPt CirPt2) Offset~))
          );if
          (if (= Direction# -1);cw
            (setq AxisPt (polar CirPt2 (angle CirPt2 AxisPt) Offset~))
            (setq AxisPt (polar CirPt2 (angle AxisPt CirPt2) Offset~))
          );if
        );if
        (setq Ang~ (- (* pi 0.5)(acos (/ HalfStep~ Offset~))))
        (if (= Direction# 1);ccw
          (setq Pt (polar AxisPt (+ (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
          (setq Pt (polar AxisPt (- (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
        );if
        (setq CirPt1 CirPt2 CirPt2 Pt)
      );progn
      (if (= Direction# 1);ccw
        (progn
          (setq Pt (polar AxisPt (+ (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
          (setq CirPt1 CirPt2 CirPt2 Pt)
        );progn
        (progn
          (setq Pt (polar AxisPt (- (angle AxisPt CirPt2) (* Ang~ 2)) (distance AxisPt CirPt2)))
          (setq CirPt1 CirPt2 CirPt2 Pt)
        );progn
      );if
    );if
    ;(command "LINE" AxisPt CirPt1 ""); Uncomment to see Troys paths while debuging
    ;If you're tweaking or debugging this code, you've got to uncommend the above line
    ;at least once to see these patterns. Run Troy in the Intro or Play mode for about
    ;10 seconds then press the escape key to abruptly abort the game. Then turn off
    ;all layers except for the Troy layer, and do a zoom extents and print it.
    (list CirEnt^ CirPt1 CirPt2 AxisPt Radius~ Direction# NumSteps# Points#)
  );defun ChangeArray:
  ;-----------------------------------------------------------------------------
  ; CreateArray: - Creates the initial TroyArray@ list
  ; Arguments: 1
  ;   TowardCenter = 1 for toward center, else away from center
  ; Returns: Creates the initial TroyArray@ list moving in direction specified.
  ;-----------------------------------------------------------------------------
  (defun CreateArray: (TowardCenter)
    (setq TroyArray@ nil)
    (if (= TowardCenter 1)
      (progn
        (setq Rotate~ (* (GetRnd 6283) 0.001))
        (repeat 10
          (setq TroyArray@ (append TroyArray@ (list (AddArray: (polar CenPt Rotate~ CirLimits~)))))
          (setq Rotate~ (+ Rotate~ (/ pi 5.0)))
        );repeat
      );progn
      (progn
        (setq Rotate~ (* (GetRnd 6283) 0.001)
              Dist~ (/ (distance NorthWest NorthEast) 7)
              Increase~ (/ (* Dist~ 3) 20.0)
        );setq
        (repeat 10
          (setq Pt (polar CenPt Rotate~ Dist~))
          (setq List@ (AddArray: Pt))
          (setq List@ (Switch_nth 1 2 List@))
          (setq List@ (Change_nth 5 (* (nth 5 List@) -1) List@))
          (setq TroyArray@ (append TroyArray@ (list List@)))
          (setq Rotate~ (+ Rotate~ 0.897 (* (GetRnd 359) 0.001))
                Dist~ (+ Dist~ Increase~)
          );setq
        );repeat
      );progn
    );if
  );defun CreateArray:
  ;-----------------------------------------------------------------------------
  ; BuildShip: - Draws Ships
  ; Arguments: 2
  ;   Num# = The number of ship created in the function BuildShip:
  ;   InsPt = Insertion base point of the ship
  ; Returns: Draws and makes a block of ship at the insertion point specified.
  ; Also creates the variables MainEnt^ and MainList@ of the ships specs.
  ;-----------------------------------------------------------------------------
  (defun BuildShip: (Num# InsPt / SS&)
    (if (not (member Num# (list 0 1 2 3)))(setq Num# 1))
    (cond
      ((= Num# 0);Red Ship in Intro
        (setq Pt1 (polar InsPt (dtr 90) (* Unit~ 0.5))
              Pt1 (polar Pt1 pi (* Unit~ 0.875))
              Pt2 (polar Pt1 pi (* Unit~ 0.375))
              Pt2 (polar Pt2 (dtr 270) (* Unit~ 0.125))
              Pt3 (polar Pt2 pi (* Unit~ 0.25))
              Pt3 (polar Pt3 (dtr 270) (* Unit~ 0.125))
              Pt4 (polar Pt3 (dtr 270) (* Unit~ 0.75))
              Pt4 (polar Pt4 0 (* Unit~ 0.5))
              Pt5 (polar Pt4 0 (* Unit~ 1.25))
              Pt5 (polar Pt5 (dtr 270) (* Unit~ 0.5))
              Pt6 (polar InsPt 0 (* Unit~ 2.5))
              Pt7 (polar Pt6 (dtr 90) (* Unit~ 0.5))
              Pt7 (polar Pt7 pi Unit~)
              Pt8 (polar Pt7 pi (* Unit~ 0.5))
              Pt8 (polar Pt8 (dtr 90) (* Unit~ 0.125))
              Pt9 (polar Pt3 0 (* Unit~ 0.5))
              Pt10 (polar InsPt (dtr 270) (* Unit~ 0.25))
              Pt11 (polar Pt9 0 (* Unit~ 2.25))
              Pt12 (polar InsPt (dtr 90) Unit~)
        );setq
        (setq SS& (ssadd))
        (command "COLOR" Color1);Red
        (command "ARC" Pt1 Pt2 Pt3)(ssadd (entlast) SS&)
        (command "ARC" Pt3 Pt4 Pt5)(ssadd (entlast) SS&)
        (command "ARC" "" Pt6)(ssadd (entlast) SS&)
        (command "ARC" Pt6 Pt7 Pt8)(ssadd (entlast) SS&)
        (command "COLOR" Color4);Cyan
        (command "ARC" Pt9 Pt10 Pt11)(ssadd (entlast) SS&)
        (command "ARC" Pt11 Pt12 Pt9)(ssadd (entlast) SS&)
        (command "COLOR" "BYLAYER")
        (setq ShipName$ (UniqueName))
        (command "BLOCK" ShipName$ InsPt SS& "")
        (command "INSERT" ShipName$ InsPt 1 1 0)
        (setq MainEnt^ (entlast))
        (setq MainList@ (entget MainEnt^))
      );case
      ((= Num# 1);Green Ship
        (setq Pt (polar InsPt pi Unit~) Pt (polar Pt (dtr 90) (* Unit~ 0.5)))
        (command "PLINE" Pt (polar Pt (dtr 270) Unit~) (polar InsPt 0 (* Unit~ 2)) "C")
        (command "CHPROP" "L" "" "C" Color3 "");Green
        (setq ShipName$ (UniqueName))
        (command "BLOCK" ShipName$ InsPt "L" "")
        (command "INSERT" ShipName$ InsPt 1 1 0)
        (setq MainEnt^ (entlast))
        (setq MainList@ (entget MainEnt^))
      );case
      ((= Num# 2);Cyan Ship
        (setq Pt (polar InsPt pi Unit~) Pt1 (polar Pt (dtr 270) Unit~)
              Pt4 (polar Pt1 (dtr 90) (* Unit~ 2)) Pt (polar InsPt 0 Unit~)
              Pt2 (polar Pt (dtr 270) (* Unit~ 0.5)) Pt3 (polar Pt2 (dtr 90) Unit~)
        );setq
        (command "PLINE" (polar InsPt pi (* Unit~ 0.5)) Pt1 (polar InsPt (dtr 270) (* Unit~ 0.5))
          Pt2 (polar InsPt 0 (* Unit~ 2)) Pt3 (polar InsPt (dtr 90) (* Unit~ 0.5)) Pt4 "C"
        );command
        (command "CHPROP" "L" "" "C" Color4 "");Cyan
        (setq ShipName$ (UniqueName))
        (command "BLOCK" ShipName$ InsPt "L" "")
        (command "INSERT" ShipName$ InsPt 1 1 0)
        (setq MainEnt^ (entlast))
        (setq MainList@ (entget MainEnt^))
      );case
      ((= Num# 3);Magenta Ship
        (setq Pt (polar InsPt pi Unit~) Pt1 (polar Pt (dtr 270) (* Unit~ 0.5))
              Pt4 (polar Pt1 (dtr 90) Unit~) Pt2 (polar Pt1 0 (* Unit~ 1.5))
              Pt3 (polar Pt4 0 (* Unit~ 1.5))
        );setq
        (command "PLINE" InsPt Pt1 (polar InsPt (dtr 270) Unit~) Pt2
          (polar InsPt 0 (* Unit~ 2)) Pt3 (polar InsPt (dtr 90) Unit~) Pt4 "C"
        );command
        (command "CHPROP" "L" "" "C" Color6 "");Magenta
        (setq ShipName$ (UniqueName))
        (command "BLOCK" ShipName$ InsPt "L" "")
        (command "INSERT" ShipName$ InsPt 1 1 0)
        (setq MainEnt^ (entlast))
        (setq MainList@ (entget MainEnt^))
      );case
    );cond
    (princ)
  );defun BuildShip:
  ;-----------------------------------------------------------------------------
  ; Refresh: - Erases Troy entities and creates a new TroyArray@ list
  ;-----------------------------------------------------------------------------
  (defun Refresh: ( )
    (setq SS& (ssget "x" (list '(8 . "Troy"))))
    (command "ERASE" SS& "")
    (setq FlameArray@ nil TroyArray@ nil Counter# 0 MainNum# (1+ MainNum#))
    (CreateArray: (GetRnd 1))
    (princ)
  );defun Refresh:
  ;=============================================================================
  ; Start of Main Function
  ;=============================================================================
  (if (not *MinTroys#*) (setq *MinTroys#* 5))
  (if (not *MaxTroys#*) (setq *MaxTroys#* 10))
  (if (not *TroySpeed~*) (setq *TroySpeed~* 1.0))
  (if (not *ColorScheme#*) (setq *ColorScheme#* 1))
  (if (not *Speed#) (Speed))
  (if (not *Clayer$*) (setq *Clayer$* (getvar "CLAYER")))
  (if (not *Osmode#*) (setq *Osmode#* (getvar "OSMODE")))
  (if (not *TextStyle$*) (setq *TextStyle$* (getvar "TEXTSTYLE")))
  (if (not *TextSize~*) (setq *TextSize~* (getvar "TEXTSIZE")))
  (setvar "BLIPMODE" 0)(setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)(setvar "GRIDMODE" 0)(graphscr)
  (if (>= (atoi (getvar "ACADVER")) 15)
    (progn
      (if (not *CTab$*) (setq *CTab$* (getvar "CTAB")))
      (if (/= (getvar "CTAB") "Model")
        (progn
          (command "PSPACE")
          (if (setq SS& (ssget "x" (list '(-4 . "<AND")'(0 . "VIEWPORT")(cons 410 (getvar "CTAB"))'(-4 . "AND>"))))
            (if (> (sslength SS&) 1)
              (command "LAYOUT" "S" "Model")
            );if
          );if
        );progn
      );if
      (setq *TroyTab$* (getvar "CTAB"))
    );progn
  );if
  (if (tblsearch "LAYER" "Troy")
    (command "LAYER" "T" "Troy" "U" "Troy" "ON" "Troy" "M" "Troy" "")
    (command "LAYER" "M" "Troy" "")
  );if
  (if (setq SS& (ssget "x" (list '(8 . "Troy"))))
    (command "ERASE" SS& "")
  );if
  (setq ViewExtents@ (ViewExtents))
  (command "ZOOM" "W" (car ViewExtents@)(cadr ViewExtents@))
  (setq Xmin~ (car (nth 0 ViewExtents@))
        Ymax~ (cadr (nth 0 ViewExtents@))
        Xmax~ (car (nth 1 ViewExtents@))
        Ymin~ (cadr (nth 1 ViewExtents@))
        NorthWest (car ViewExtents@)
        SouthEast (cadr ViewExtents@)
        SouthWest (list Xmin~ Ymin~)
        NorthEast (list Xmax~ Ymax~)
        CenPt (getvar "VIEWCTR")
        ViewSize~ (getvar "VIEWSIZE")
        Unit~ (/ (getvar "VIEWSIZE") 50.0)
        Limit# (1+ (fix (/ (distance CenPt (car ViewExtents@)) Unit~)))
        CirLimits~ (* (+ Limit# 3) Unit~)
        North (polar CenPt (dtr 90) (+ (* Unit~ 3) (/ (getvar "VIEWSIZE") 2.0)))
        South (polar CenPt (dtr 270) (+ (* Unit~ 3) (/ (getvar "VIEWSIZE") 2.0)))
        East (polar CenPt 0 (+ (* Unit~ 3) (/ (distance NorthWest NorthEast) 2.0)))
        West (polar CenPt pi (+ (* Unit~ 3) (/ (distance NorthWest NorthEast) 2.0)))
  );setq
  ; Customize Color Schemes as desired and add to top menu in c:Troy
  (cond
    ((= *ColorScheme#* 1);  Bright colors
      (setq Color1     1 ;Red      Red ship
            Color1_5  30 ;Orange   Exploding Troys
            Color2     2 ;Yellow   Bonus points
            Color3     3 ;Green    1st ship
            Color4     4 ;Cyan     2nd ship
            Color5     5 ;Blue     Letter O in TroyIntro
            Color6     6 ;Magenta  3rd ship
            Color7     7 ;White    Not used
            Color8    33 ;Grey     Troys
      );setq
    );case
    ((= *ColorScheme#* 2);  Dim colors
      (setq Color1    12 ;Red      Red ship
            Color1_5  32 ;Orange   Exploding Troys
            Color2    52 ;Yellow   Bonus points
            Color3    86 ;Green    1st ship
            Color4   152 ;Cyan     2nd ship
            Color5   162 ;Blue     Letter O in TroyIntro
            Color6   192 ;Magenta  3rd ship
            Color7     7 ;White    Not used
            Color8   250 ;Grey     Troys
      );setq
    );case
    ((= *ColorScheme#* 3);  Ghost colors
      (setq Color1   250 ;Red      Red ship
            Color1_5 250 ;Orange   Exploding Troys
            Color2   250 ;Yellow   Bonus points
            Color3   250 ;Green    1st ship
            Color4   250 ;Cyan     2nd ship
            Color5   250 ;Blue     Letter O in TroyIntro
            Color6   250 ;Magenta  3rd ship
            Color7   250 ;White    Not used
            Color8   250 ;Grey     Troys
      );setq
    );case
  );cond
  ; Create Flame$ block
  (setq SS& (ssadd))(setq Pt SouthEast)
  (command "COLOR" Color2);Yellow
  (command "LINE" Pt (setq Pt (polar Pt 0 Unit~)) "")(ssadd (entlast) SS&)
  (command "COLOR" Color1);Red
  (command "LINE" Pt (setq Pt (polar Pt 0 Unit~)) "")(ssadd (entlast) SS&)
  (command "COLOR" "BYLAYER")(setq Flame$ (UniqueName))
  (command "BLOCK" Flame$ SouthEast SS& "")
  (if (= Option$ "Intro")(TroyIntro))
  ;(command "RECTANG" (car ViewExtents@)(cadr ViewExtents@)); Uncomment while debuging
  ;(command "CIRCLE" CenPt CirLimits~); Uncomment while debuging
  ; Build Ship 1
  (BuildShip: 1 CenPt)
  ; Create first Troys
  (CreateArray: (GetRnd 1))
  (command "STYLE" "Troy" "ROMANS" "0.0" "0.75" "" "" "" "")
  ;-----------------------------------------------------------------------------
  ; Start of grread Loop
  ;-----------------------------------------------------------------------------
  (setq Loop t Counter# 0 Total# 100 MainNum# 1)
  (setq Previous@ (list 5 (polar CenPt 0 Unit~)));Start the Loop moving
  (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
  (while Loop
    ; Read the mouse movements and picks
    (if (not (setq Read@ (grread t 8)))
      (setq Read@ Previous@)
    );if
    (setq Code# (nth 0 Read@))
    (setq Value (nth 1 Read@))
    (cond
      ((= Code# 3); Fire if picked
        (setq Ang~ (angle CenPt Value)
              Pt1 (polar CenPt Ang~ (* Unit~ 2))
              Pt2 (polar Pt1 Ang~ Unit~)
        );setq
        (command "INSERT" Flame$ Pt1 1 1 (rtd Ang~))
        (setq FlameArray@ (append FlameArray@ (list (list (entlast) Pt1 Pt2 Ang~))))
        (setq Total# (1- Total#))
        (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
      );case
      ((= Code# 5); Rotate if moved
        (setq Previous@ Read@)
        (setq Ang~ (angle CenPt Value))
        (setq MainList@ (entmod (subst (cons 50 Ang~) (assoc 50 MainList@) MainList@)))
      );case
      ((= Code# 2); Key was pressed
        (cond
          ((or (= Value 80)(= Value 112));P or p then pause
            (getpoint "\nTroy paused.  Pick mouse to continue. ")
            (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
          );case
          ((or (= Value 81)(= Value 113));Q or q then quit
            (setq Loop nil)
          );case
          (t (princ "\nMove mouse to rotate ship, pick mouse to fire, press P to Pause, or Q to quit.")
             (princ (strcat "\nTotal: " (itoa Total#) "\n"))
          );case
        );case
      );case
    );cond
    ; Move flame objects
    (if FlameArray@
      (progn
        (setq Cnt# 0 Nths@ nil)
        (foreach List@ FlameArray@
          (setq Flame^ (nth 0 List@)
                Pt1 (nth 1 List@)
                Pt2 (nth 2 List@)
                Ang~ (nth 3 List@)
          );setq
          (if (or (and (> (car Pt2)(car East))(> (car Pt2)(car Pt1)))
                  (and (< (car Pt2)(car West))(< (car Pt2)(car Pt1)))
                  (and (> (cadr Pt2)(cadr North))(> (cadr Pt2)(cadr Pt1)))
                  (and (< (cadr Pt2)(cadr South))(< (cadr Pt2)(cadr Pt1)))
              );or
            (progn
              (command "ERASE" Flame^ "")
              (setq Nths@ (append Nths@ (list Cnt#)))
            );progn
            (progn
              (command "MOVE" Flame^ "" Pt1 Pt2)
              (setq Pt1 Pt2 Pt2 (polar Pt2 Ang~ Unit~))
              (setq List@ (list Flame^ Pt1 Pt2 Ang~))
              (setq FlameArray@ (Change_nth Cnt# List@ FlameArray@))
            );progn
          );if
          (setq Cnt# (1+ Cnt#))
        );foreach
        (if Nths@
          (setq FlameArray@ (Remove_nths Nths@ FlameArray@))
        );if
      );progn
    );if
    ; Check if Troys are hit
    (setq Cnt# 0 Nths@ nil)
    (foreach List@ TroyArray@ ; Troy list
      (if FlameArray@ ; Flame list
        (progn
          (setq CirEnt^ (nth 0 List@)
                CirPt1 (nth 1 List@)
                Radius~ (nth 4 List@)
                Points# (nth 7 List@)
          );setq
          (setq Num# 0 Num@ nil)
          (foreach SubList@ FlameArray@
            (setq Flame^ (nth 0 SubList@)
                  Pt2 (nth 2 SubList@)
            );setq
            (if (and (> (car Pt2) (+ Xmin~ Radius~))(< (car Pt2) (- Xmax~ Radius~))
                     (> (cadr Pt2) (+ Ymin~ Radius~))(< (cadr Pt2) (- Ymax~ Radius~)))
              (if (<= (distance Pt2 CirPt1) Radius~)
                (progn
                  (command "ERASE" CirEnt^ Flame^ "")
                  (setq Num@ (append Num@ (list Num#)))
                  (setq Nths@ (append Nths@ (list Cnt#)))
                  (command "TEXT" "M" CirPt1 Unit~ 0 (itoa Points#))
                  (command "CHPROP" "L" "" "C" Color2 "")
                  (setq TextEnt^ (entlast))
                  (setq Total# (+ Total# Points#))
                  (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
                  (command "COLOR" Color1_5)
                  (setq Dia1~ (* Radius~ 2) Dia2~ (* Radius~ 3) Ang~ (dtr 270) Pnts# 7)
                  (repeat 3
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3.5) Ang~ (+ Ang~ (/ (* pi 2) (* Pnts# 3))))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3) Ang~ (dtr 90))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3.5) Ang~ (- Ang~ (/ (* pi 2) (* Pnts# 3))))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3) Ang~ (dtr 270))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3.5) Ang~ (- Ang~ (/ (* pi 2) (* Pnts# 3))))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3) Ang~ (dtr 90))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3.5) Ang~ (+ Ang~ (/ (* pi 2) (* Pnts# 3))))
                    (command "ERASE" (entlast) "")
                    (StarBurst CirPt1 Dia1~ Dia2~ Pnts# Ang~)(delay 0.125)
                    (setq Dia2~ (* Radius~ 3) Ang~ (dtr 270))
                    (command "ERASE" (entlast) "")
                  );repeat
                  (command "COLOR" "BYLAYER")
                  (command "ERASE" TextEnt^"")
                );progn
              );if
            );if
            (setq Num# (1+ Num#))
          );foreach
          (if Num@
            (setq FlameArray@ (Remove_nths Num@ FlameArray@))
          );if
        );progn
      );if
      (if TroyArray@
        (setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
        (CreateArray: 1)
      );if
      (setq Cnt# (1+ Cnt#))
    );foreach
    (if Nths@
      (setq TroyArray@ (Remove_nths Nths@ TroyArray@))
    );if
    (if (not TroyArray@)
      (CreateArray: 1)
    );if
    ; Erase Troys that are out of limits
    (setq Cnt# 0)
    (foreach List@ TroyArray@
      (setq CirEnt^ (nth 0 List@)
            CirPt1 (nth 1 List@)
            CirPt2 (nth 2 List@)
      );setq
      (if (or (and (> (car CirPt1)(car East))(> (car CirPt2)(car CirPt1)))
              (and (< (car CirPt1)(car West))(< (car CirPt2)(car CirPt1)))
              (and (> (cadr CirPt1)(cadr North))(> (cadr CirPt2)(cadr CirPt1)))
              (and (< (cadr CirPt1)(cadr South))(< (cadr CirPt2)(cadr CirPt1)))
          );or
        (progn
          (command "ERASE" CirEnt^ "")
          (setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
          (setq Counter# (1+ Counter#))
          (if (= Counter# 3);Add Troys per Counter#
            (progn
              (setq Counter# 0)
              (if (< (length TroyArray@) *MaxTroys#*)
                (setq TroyArray@ (append TroyArray@ (list (AddArray: nil))))
              );if
            );progn
          );if
        );progn
      );if
      (setq Cnt# (1+ Cnt#))
    );foreach
    ; Check if Troys ran into Ship or total points is <= 0
    (setq Cnt# 0 Passed t)
    (while Passed
      (setq List@ (nth Cnt# TroyArray@)
            CirEnt^ (nth 0 List@)
            CirPt1 (nth 1 List@)
            Radius~ (nth 4 List@)
      );setq
      (if (or (< (distance CenPt CirPt1) (+ Radius~ (* Unit~ 2.5))) (<= Total# 0))
        (progn
          (command "ERASE" MainEnt^ "")
          (cond
            ((= MainNum# 1)(setq Color# Color3));Green
            ((= MainNum# 2)(setq Color# Color4));Cyan
            ((= MainNum# 3)(setq Color# Color6));Magenta
          );cond
          (command "COLOR" Color#)
          (setq Dia1~ 1 Dia2~ 4 Ang~ (dtr 270) Inc# 0 Inc1~ 0.125 Inc2~ 0.375)
          (repeat 20
            (if (= Inc# 11)(setq Inc1~ -0.125 Inc2~ -0.375))
            (StarBurst CenPt (* Unit~ Dia1~) (* Unit~ Dia2~) 5 Ang~)(delay 0.5)
            (setq Dia1~ (+ Dia1~ Inc1~) Dia2~ (+ Dia2~ Inc2~))
            (setq Ang~ (+ Ang~ (/ (* pi 2) 3)))
            (command "ERASE" (entlast) "")
            (setq Inc# (1+ Inc#))
          );repeat
          (command "COLOR" "BYLAYER")
          (setq Total# (- Total# 10))
          (if (<= Total# 0)
            (progn
              (setq MainNum# 3)
              (princ "\nCommand:\nTotal: 0")
            );progn
            (princ (strcat "\nCommand:\nTotal: " (itoa Total#) "\n"))
          );if
          (cond
            ((= MainNum# 1); Build Ship 2
              (Refresh:)
              (BuildShip: 2 CenPt)
            );case
            ((= MainNum# 2); Build Ship 3
              (Refresh:)
              (BuildShip: 3 CenPt)
            );case
            ((= MainNum# 3); Finished!
              (setq Passed nil Loop nil)
            );case
          );cond
          (setq Passed nil)
        );progn
      );if
      (setq Cnt# (1+ Cnt#))
      (if (> Cnt# (1- (length TroyArray@)))
        (setq Passed nil)
      );if
    );while
    (if (< (length TroyArray@) *MinTroys#*)
      (setq TroyArray@ (append TroyArray@ (list (AddArray: nil))))
    );if
    (if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
      (command "ZOOM" "W" (car ViewExtents@)(cadr ViewExtents@))
    );if
  );while
  (TroyClear)
  (princ (strcat "\nCommand:\nTotal: " (itoa Total#) " Finished!"))
  (princ)
);defun Troy
;-------------------------------------------------------------------------------
; TroyIntro - Introduction
;-------------------------------------------------------------------------------
(defun TroyIntro (/ Color# Divisions# Fire# Fourth# Inc~ Increase~ Ltr# Move#
  O-Ang~ O-Cnt# O-Ent^ O-Ins O-List@ O-Pt O-Pts@ O-Size~ Path# Path@ Path1@
  Path2@ Path3@ Path4@ R-Ang~ R-Cen R-Cnt# R-Ent^ R-Ins R-List@ R-Pt R-Pts@
  R-Size~ Rotate~ Rnd# RndLtr@ Sevenths Step~ T-Ang~ T-Cen T-Cnt# T-Ent^ T-Ins
  T-List@ T-Pt T-Pts@ T-Size~ Tl-Ang~ TxSize~ TxSizeInc~ TxSizeMax~ TxSizeMin~
  Y-Ang~ Y-Cnt# Y-Ent^ Y-Ins Y-List@ Y-Pt Y-Pts@ Y-Size~)
  (princ "\nTroy Intro.\n")
  (command "STYLE" "Troy" "ROMAND" "0.0" "1" "" "" "" "")
  (setq T-Pt (polar CenPt pi (* Unit~ 4.5))
        R-Pt (polar CenPt pi (* Unit~ 1.5))
        O-Pt (polar CenPt 0 (* Unit~ 1.5))
        Y-Pt (polar CenPt 0 (* Unit~ 4.5))
        TxSizeMax~ (* Unit~ 3)
        TxSizeMin~ (* Unit~ 0.5)
        Inc~ (* Unit~ 2);Speed of letters
        Pt0 (polar R-Pt (- (angle R-Pt SouthWest) 0.009) (distance R-Pt SouthWest))
        Pt (polar R-Pt (angle R-Pt Pt0) (/ (distance R-Pt Pt0) 2.0))
        Pt (polar Pt (+ (angle R-Pt Pt0) (* pi 0.5)) (/ (distance R-Pt Pt0) 7.0))
        R-Cen (Center3Pt R-Pt Pt Pt0)
        Radius~ (distance R-Pt R-Cen)
        Ang~ (* (- (* pi 0.5) (acos (/ (/ Inc~ 2.0) Radius~))) 2)
        Inc# (fix (/ (- (angle R-Cen R-Pt) (angle R-Cen SouthWest)) Ang~))
        Pt0 (polar T-Pt (- (angle T-Pt NorthWest) 0.043) (distance R-Pt SouthWest))
        Pt (polar T-Pt (angle T-Pt Pt0) (/ (distance R-Pt Pt0) 2.0))
        Pt (polar Pt (+ (angle T-Pt Pt0) (* pi 0.5)) (/ (distance R-Pt Pt0) 7.0))
        T-Cen (Center3Pt T-Pt Pt Pt0)
        TxSizeInc~ (/ (- TxSizeMax~ TxSizeMin~) (float Inc#))
        TxSize~ TxSizeMax~
        T-Pts@ (list T-Pt)
        R-Pts@ (list R-Pt)
        O-Pts@ (list O-Pt)
        Y-Pts@ (list Y-Pt)
        T-Ang~ 0
  );setq
  (repeat Inc#
    (setq T-Pt (polar T-Cen (- (angle T-Cen T-Pt) Ang~) Radius~)
          T-Pts@ (append T-Pts@ (list T-Pt))
          R-Pt (polar R-Cen (- (angle R-Cen R-Pt) Ang~) Radius~)
          R-Pts@ (append R-Pts@ (list R-Pt))
          O-Pt (polar CenPt (angle R-Pt CenPt) (distance R-Pt CenPt))
          O-Pts@ (append O-Pts@ (list O-Pt))
          Y-Pt (polar CenPt (angle T-Pt CenPt) (distance T-Pt CenPt))
          Y-Pts@ (append Y-Pts@ (list Y-Pt))
          T-Ang~ (- T-Ang~ (dtr 30))
          TxSize~ (- TxSize~ TxSizeInc~)
    );setq
  );repeat
  (setq T-Pts@ (reverse T-Pts@)
        R-Pts@ (reverse R-Pts@)
        O-Pts@ (reverse O-Pts@)
        Y-Pts@ (reverse Y-Pts@)
        R-Ang~ T-Ang~ O-Ang~ T-Ang~ Y-Ang~ T-Ang~
        T-Size~ TxSize~ R-Size~ TxSize~ O-Size~ TxSize~ Y-Size~ TxSize~
        T-Cnt# 0 R-Cnt# 0 O-Cnt# 0 Y-Cnt# 0 Fourth# (/ Inc# 4)
  );setq
  (setq T-Pt (last T-Pts@) R-Pt (last R-Pts@) O-Pt (last O-Pts@) Y-Pt (last Y-Pts@) RndLtr@ (list 0))
  (while (/= (length RndLtr@) 5)
    (setq Rnd# (1+ (GetRnd 3)))
    (cond
      ((= Rnd# 1)(setq Pt T-Pt))
      ((= Rnd# 2)(setq Pt R-Pt))
      ((= Rnd# 3)(setq Pt O-Pt))
      ((= Rnd# 4)(setq Pt Y-Pt))
    );cond
    (if (not (member Pt RndLtr@))
      (setq RndLtr@ (append RndLtr@ (list Pt)))
    );if
  );while
  (setq Rotate~ (* (GetRnd 6283) 0.001)
        Dist~ (/ (distance NorthWest NorthEast) 10)
        Increase~ (/ (* Dist~ 3) 20.0)
  );setq
  (repeat 20
    (setq Pt (polar CenPt Rotate~ Dist~))
    (setq List@ (AddArray: Pt))
    (setq List@ (Switch_nth 1 2 List@))
    (setq List@ (Change_nth 5 (* (nth 5 List@) -1) List@))
    (setq TroyArray@ (append TroyArray@ (list List@)))
    (setq Rotate~ (+ Rotate~ 0.897 (* (GetRnd 359) 0.001))
          Dist~ (+ Dist~ Increase~)
    );setq
  );repeat
  (setq Step~ (* Unit~ 1.5);Speed of red ship
        Pt1 (polar SouthWest (dtr 90) (/ (distance SouthWest NorthWest) 6.0))
        Pt2 (polar Pt1 0 (/ (distance SouthWest SouthEast) 3.0))
        Pt (polar Pt1 0 (/ (distance Pt1 Pt2) 2.0))
        Pt (polar Pt (dtr 90) (* Unit~ 2))
        Pt (Center3Pt Pt1 Pt Pt2)
        Radius~ (distance Pt Pt1)
        Tl-Ang~ (- (angle Pt Pt1) (angle Pt Pt2))
        Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
        Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
        Pt2 (polar Pt (- (angle Pt Pt1) (* Ang~ Divisions#)) Radius~)
  );setq
  (setq Path1@ (list Pt1))
  (repeat Divisions#
    (setq Pt1 (polar Pt (- (angle Pt Pt1) Ang~) Radius~))
    (setq Path1@ (append Path1@ (list Pt1)))
  );repeat
  (setq Pt (polar Pt (angle Pt Pt2) (* Radius~ 2)))
  (repeat (fix (1+ (/ Divisions# 2.0)))
    (setq Pt1 (polar Pt (+ (angle Pt Pt1) Ang~) Radius~))
    (if (< (angle Pt Pt1) (dtr 270))
      (setq Path1@ (append Path1@ (list Pt1)))
    );if
  );repeat
  (setq Pt1 (last Path1@)
        Pt2 (inters Pt1 (polar Pt1 0 Unit~) NorthEast SouthEast nil)
        Ang~ (atan (/ 1 2.0))
        Radius~ (* (distance Pt1 Pt2) (tan Ang~))
        Pt (polar Pt1 (dtr 90) Radius~)
        Tl-Ang~ (atan (/ (distance Pt1 Pt2) Radius~))
        Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
        Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
  );setq
  (repeat Divisions#
    (setq Pt1 (polar Pt (+ (angle Pt Pt1) Ang~) Radius~))
    (setq Path1@ (append Path1@ (list Pt1)))
  );repeat
  (setq Pt Pt2
        Radius~ (distance Pt Pt1)
        Ang~ (* 2 (- (* pi 0.5) (acos (/ (* Step~ 0.5) Radius~))))
        Tl-Ang~ (- (angle Pt Pt1) (* pi 0.5))
        Divisions# (fix (1+ (/ Tl-Ang~ Ang~)))
  );setq
  (repeat Divisions#
    (setq Pt2 Pt1)
    (setq Pt1 (polar Pt (- (angle Pt Pt1) Ang~) Radius~))
    (if (> (angle Pt Pt1) (* pi 0.5))
      (setq Path1@ (append Path1@ (list Pt1)))
    );if
  );repeat
  (setq Ang~ (angle Pt2 Pt1))
  (repeat 5
    (setq Pt1 (polar Pt1 Ang~ Step~))
    (setq Path1@ (append Path1@ (list Pt1)))
  );repeat
  (setq Ang~ (angle (nth 1 Path1@) (nth 0 Path1@)))
  (repeat 5
    (setq Pt (polar (nth 0 Path1@) Ang~ Step~))
    (setq Path1@ (Insert_nth 0 Pt Path1@))
  );repeat
  (foreach Item Path1@
    (setq Pt2 (MirrorPt Item CenPt 0))
    (setq Path2@ (append Path2@ (list Pt2)))
    (setq Pt3 (MirrorPt Item CenPt (dtr 90)))
    (setq Path3@ (append Path3@ (list Pt3)))
    (setq Pt4 (MirrorPt Pt3 CenPt 0))
    (setq Path4@ (append Path4@ (list Pt4)))
  );foreach
  (setq Path# (1+ (GetRnd 3)))
  (cond
    ((= Path# 1)(setq Path@ Path1@))
    ((= Path# 2)(setq Path@ Path2@))
    ((= Path# 3)(setq Path@ Path3@))
    ((= Path# 4)(setq Path@ Path4@))
  );cond
  ;-----------------------------------------------------------------------------
  ; First Loop
  ;-----------------------------------------------------------------------------
  (setq Loop t)
  (while Loop
    (if (<= T-Cnt# Inc#)
      (if (= T-Cnt# 0)
        (progn
          (command "TEXT" "M" (nth T-Cnt# T-Pts@) T-Size~ (rtd T-Ang~) "T")
          (setq T-Ent^ (entlast))
          (command "CHPROP" T-Ent^ "" "C" Color3 "");Green
          (setq T-List@ (entget T-Ent^)
                T-Size~ (+ T-Size~ TxSizeInc~)
                T-Ang~ (+ T-Ang~ (dtr 30))
                T-Cnt# (1+ T-Cnt#)
                T-Ins (nth T-Cnt# T-Pts@)
          );setq
        );progn
        (progn
          (setq T-List@ (entmod (subst (cons 50 T-Ang~) (assoc 50 T-List@) T-List@)))
          (setq T-List@ (entmod (subst (cons 11 T-Ins) (assoc 11 T-List@) T-List@)))
          (setq T-List@ (entmod (subst (cons 40 T-Size~) (assoc 40 T-List@) T-List@)))
          (setq T-Size~ (+ T-Size~ TxSizeInc~)
                T-Ang~ (+ T-Ang~ (dtr 30))
                T-Cnt# (1+ T-Cnt#)
          );setq
          (if (<= T-Cnt# Inc#) (setq T-Ins (nth T-Cnt# T-Pts@)))
        );progn
      );if
    );if
    (if (>= T-Cnt# Fourth#)
      (if (<= R-Cnt# Inc#)
        (if (= R-Cnt# 0)
          (progn
            (command "TEXT" "M" (nth R-Cnt# R-Pts@) R-Size~ (rtd R-Ang~) "R")
            (setq R-Ent^ (entlast))
            (command "CHPROP" R-Ent^ "" "C" Color4 "");Cyan
            (setq R-List@ (entget R-Ent^)
                  R-Size~ (+ R-Size~ TxSizeInc~)
                  R-Ang~ (+ R-Ang~ (dtr 30))
                  R-Cnt# (1+ R-Cnt#)
                  R-Ins (nth R-Cnt# R-Pts@)
            );setq
          );progn
          (progn
            (setq R-List@ (entmod (subst (cons 50 R-Ang~) (assoc 50 R-List@) R-List@)))
            (setq R-List@ (entmod (subst (cons 11 R-Ins) (assoc 11 R-List@) R-List@)))
            (setq R-List@ (entmod (subst (cons 40 R-Size~) (assoc 40 R-List@) R-List@)))
            (setq R-Size~ (+ R-Size~ TxSizeInc~)
                  R-Ang~ (+ R-Ang~ (dtr 30))
                  R-Cnt# (1+ R-Cnt#)
            );setq
            (if (<= R-Cnt# Inc#) (setq R-Ins (nth R-Cnt# R-Pts@)))
          );progn
        );if
      );if
    );if
    (if (>= R-Cnt# Fourth#)
      (if (<= O-Cnt# Inc#)
        (if (= O-Cnt# 0)
          (progn
            (command "TEXT" "M" (nth O-Cnt# O-Pts@) O-Size~ (rtd O-Ang~) "O")
            (setq O-Ent^ (entlast))
            (command "CHPROP" O-Ent^ "" "C" Color5 "");Blue
            (setq O-List@ (entget O-Ent^)
                  O-Size~ (+ O-Size~ TxSizeInc~)
                  O-Ang~ (+ O-Ang~ (dtr 30))
                  O-Cnt# (1+ O-Cnt#)
                  O-Ins (nth O-Cnt# O-Pts@)
            );setq
          );progn
          (progn
            (setq O-List@ (entmod (subst (cons 50 O-Ang~) (assoc 50 O-List@) O-List@)))
            (setq O-List@ (entmod (subst (cons 11 O-Ins) (assoc 11 O-List@) O-List@)))
            (setq O-List@ (entmod (subst (cons 40 O-Size~) (assoc 40 O-List@) O-List@)))
            (setq O-Size~ (+ O-Size~ TxSizeInc~)
                  O-Ang~ (+ O-Ang~ (dtr 30))
                  O-Cnt# (1+ O-Cnt#)
            );setq
            (if (<= O-Cnt# Inc#) (setq O-Ins (nth O-Cnt# O-Pts@)))
          );progn
        );if
      );if
    );if
    (if (>= O-Cnt# Fourth#)
      (if (<= Y-Cnt# Inc#)
        (if (= Y-Cnt# 0)
          (progn
            (command "TEXT" "M" (nth Y-Cnt# Y-Pts@) Y-Size~ (rtd Y-Ang~) "Y")
            (setq Y-Ent^ (entlast))
            (command "CHPROP" Y-Ent^ "" "C" Color6 "");Magenta
            (setq Y-List@ (entget Y-Ent^)
                  Y-Size~ (+ Y-Size~ TxSizeInc~)
                  Y-Ang~ (+ Y-Ang~ (dtr 30))
                  Y-Cnt# (1+ Y-Cnt#)
                  Y-Ins (nth Y-Cnt# Y-Pts@)
            );setq
          );progn
          (progn
            (setq Y-List@ (entmod (subst (cons 50 Y-Ang~) (assoc 50 Y-List@) Y-List@)))
            (setq Y-List@ (entmod (subst (cons 11 Y-Ins) (assoc 11 Y-List@) Y-List@)))
            (setq Y-List@ (entmod (subst (cons 40 Y-Size~) (assoc 40 Y-List@) Y-List@)))
            (setq Y-Size~ (+ Y-Size~ TxSizeInc~)
                  Y-Ang~ (+ Y-Ang~ (dtr 30))
                  Y-Cnt# (1+ Y-Cnt#)
            );setq
            (if (<= Y-Cnt# Inc#) (setq Y-Ins (nth Y-Cnt# Y-Pts@)))
          );progn
        );if
      );if
    );if
    ; Erase Troys that are out of limits
    (setq Cnt# 0)
    (foreach List@ TroyArray@
      (setq CirEnt^ (nth 0 List@)
            CirPt1 (nth 1 List@)
            Radius~ (nth 4 List@)
      );setq
      (if (> (distance CenPt CirPt1) CirLimits~)
        (progn
          (command "ERASE" CirEnt^ "")
          (setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
        );progn
        (setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
      );if
      (setq Cnt# (1+ Cnt#))
    );foreach
    (delay 0.15);Speed of Loop
    (if (> Y-Cnt# Inc#)(setq Loop nil))
    (if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
      (command "ZOOM" "W" (car ViewExtents@)(cadr ViewExtents@))
    );if
  );while
  ;-----------------------------------------------------------------------------
  ; Second Loop
  ;-----------------------------------------------------------------------------
  (setq Loop t Move# 0 Ltr# 0 Sevenths# (/ (length Path@) 7) Fire# (1+ Sevenths#))
  (BuildShip: 0 (nth 0 Path@))
  (if (> Path# 2)
    (setq MainList@ (entmod (subst (cons 42 -1.0) (assoc 42 MainList@) MainList@)))
  );if
  (while Loop
    ; Move Ship
    (setq Pt1 (nth Move# Path@)
          Pt2 (nth (1+ Move#) Path@)
          Ang~ (angle Pt1 Pt2)
    );setq
    ;(command "LINE" Pt1 Pt2 "");Uncomment while debuging
    (setq MainList@ (entmod (subst (cons 50 Ang~) (assoc 50 MainList@) MainList@)))
    (setq MainList@ (entmod (subst (cons 10 Pt1) (assoc 10 MainList@) MainList@)))
    ; Fire at Troy Letters
    (setq Fire# (1+ Fire#))
    (if (= Fire# (fix (* Sevenths# 2.5)))(setq Fire# Sevenths#));First time
    (if (= Fire# Sevenths#);Fire in these intervals
      (progn
        (setq Fire# 0 Ltr# (1+ Ltr#))
        (if (member Ltr# (list 1 2 3 4))
          (progn
            (setq Pt (nth Ltr# RndLtr@)
                  Ang~ (angle Pt1 Pt)
                  Pt1 (polar Pt1 Ang~ (* Unit~ 2))
                  Pt2 (polar Pt1 Ang~ Unit~)
            );setq
            (command "INSERT" Flame$ Pt1 1 1 (rtd Ang~))
            (setq FlameArray@ (append FlameArray@ (list (list (entlast) Pt1 Pt2 Ang~))))
          );progn
        );if
      );progn
    );if
    ; Move flame objects
    (if FlameArray@
      (progn
        (setq Cnt# 0 Nth# nil)
        (foreach List@ FlameArray@
          (setq Flame^ (nth 0 List@)
                Pt1 (nth 1 List@)
                Pt2 (nth 2 List@)
                Ang~ (nth 3 List@)
          );setq
          (if (or (and (> (car Pt2)(car East))(> (car Pt2)(car Pt1)))
                  (and (< (car Pt2)(car West))(< (car Pt2)(car Pt1)))
                  (and (> (cadr Pt2)(cadr North))(> (cadr Pt2)(cadr Pt1)))
                  (and (< (cadr Pt2)(cadr South))(< (cadr Pt2)(cadr Pt1)))
              );or
            (progn
              (command "ERASE" Flame^ "")
              (setq Nth# Cnt#)
            );progn
            (progn
              (command "MOVE" Flame^ "" Pt1 Pt2)
              (setq Pt1 Pt2 Pt2 (polar Pt2 Ang~ Unit~))
              (setq List@ (list Flame^ Pt1 Pt2 Ang~))
              (setq FlameArray@ (Change_nth Cnt# List@ FlameArray@))
            );progn
          );if
          (setq Cnt# (1+ Cnt#))
        );foreach
        (if Nth#
          (setq FlameArray@ (Delete_nth Nth# FlameArray@))
        );if
      );progn
    );if
    ; Check to see if Troy Letters are hit
    (if FlameArray@
      (progn
        (setq Num# 0)
        (foreach List@ FlameArray@
          (setq Ent^ (nth 0 List@)
                Pt2 (nth 2 List@)
                Pt nil
          );setq
          (cond
            ((<= (distance Pt2 T-Pt) Unit~)
              (command "ERASE" T-Ent^ Ent^ "")
              (setq FlameArray@ (Delete_nth Num# FlameArray@))
              (setq Pt T-Pt T-Pt SouthWest Color# Color3);Green
            );case
            ((<= (distance Pt2 R-Pt) Unit~)
              (command "ERASE" R-Ent^ Ent^ "")
              (setq FlameArray@ (Delete_nth Num# FlameArray@))
              (setq Pt R-Pt R-Pt SouthWest Color# Color4);Cyan
            );case
            ((<= (distance Pt2 O-Pt) Unit~)
              (command "ERASE" O-Ent^ Ent^ "")
              (setq FlameArray@ (Delete_nth Num# FlameArray@))
              (setq Pt O-Pt O-Pt SouthWest Color# Color5);Blue
            );case
            ((<= (distance Pt2 Y-Pt) Unit~)
              (command "ERASE" Y-Ent^ Ent^ "")
              (setq FlameArray@ (Delete_nth Num# FlameArray@))
              (setq Pt Y-Pt Y-Pt SouthWest Color# Color6);Magenta
            );case
          );cond
          ; Explode Letter
          (if Pt
            (progn
              (command "COLOR" Color#)
              (setq Dia1~ 0.5 Dia2~ 3 Ang~ (* (GetRnd 6283) 0.001) Inc# 0 Inc1~ 0.125 Inc2~ 0.375)
              (repeat 10
                (if (= Inc# 6)(setq Inc1~ -0.125 Inc2~ -0.375))
                (StarBurst Pt (* Unit~ Dia1~) (* Unit~ Dia2~) (+ (GetRnd 5) 5) Ang~)(delay 0.125)
                (setq Dia1~ (+ Dia1~ Inc1~) Dia2~ (+ Dia2~ Inc2~))
                (setq Ang~ (* (GetRnd 6283) 0.001))
                (command "ERASE" (entlast) "")
                (setq Inc# (1+ Inc#))
              );repeat
              (command "COLOR" "BYLAYER")
            );progn
          );if
          (setq Num# (1+ Num#))
        );foreach
      );progn
    );if
    ; Erase Troys that are out of limits
    (setq Cnt# 0)
    (foreach List@ TroyArray@
      (setq CirEnt^ (nth 0 List@)
            CirPt1 (nth 1 List@)
            Radius~ (nth 4 List@)
      );setq
      (if (> (distance CenPt CirPt1) CirLimits~)
        (progn
          (command "ERASE" CirEnt^ "")
          (setq TroyArray@ (Change_nth Cnt# (AddArray: nil) TroyArray@))
        );progn
        (setq TroyArray@ (Change_nth Cnt# (ChangeArray: List@) TroyArray@))
      );if
      (setq Cnt# (1+ Cnt#))
    );foreach
    (delay 0.15);Speed of Loop
    (setq Move# (1+ Move#))
    (if (= Move# (1- (length Path@)))(setq Loop nil))
    (if (or (/= (getvar "VIEWCTR") CenPt)(/= (getvar "VIEWSIZE") ViewSize~))
      (command "ZOOM" "W" (car ViewExtents@)(cadr ViewExtents@))
    );if
  );while
  (setq SS& (ssget "x" (list '(8 . "Troy"))))
  (command "ERASE" SS& "")
  (princ)
);defun TroyIntro
;-------------------------------------------------------------------------------
; TroyClear - Troy clear function
;-------------------------------------------------------------------------------
(defun TroyClear (/ Block$ Passed SS&)
  (if *TroyTab$* (command "LAYOUT" "S" *TroyTab$*))
  (if *Clayer$* (setvar "CLAYER" *Clayer$*))
  (if *Osmode#* (setvar "OSMODE" *Osmode#*))
  (if *TextStyle$* (setvar "TEXTSTYLE" *TextStyle$*))
  (if *TextSize~* (setvar "TEXTSIZE" *TextSize~*))
  (command "COLOR" "BYLAYER")
  (if (setq SS& (ssget "x" (list '(8 . "Troy"))))
    (command "ERASE" SS& "")
  );if
  (setq Block$ (strcat (substr (UniqueName) 1 5) "*"))
  (foreach Item (GetBlockList)
    (if (wcmatch Item Block$) (setq Passed t))
  );foreach
  (if Passed (command "PURGE" "BL" Block$ "N"))
  (if (tblsearch "LAYER" "Troy") (command "PURGE" "LA" "Troy" "N"))
  (if (tblsearch "STYLE" "Troy") (command "PURGE" "ST" "Troy" "N"))
  (setq *Clayer$* nil *Osmode#* nil *TextStyle$* nil *TextSize~* nil)
  (PurgeGroups)
  (if *CTab$*
    (progn (command "LAYOUT" "S" *CTab$*)(setq *CTab$* nil *TroyTab$* nil))
  );if
  (repeat 45 (princ (strcat "\n" (chr 160))))
  (princ)
);defun TroyClear
;-------------------------------------------------------------------------------
; Start of Troy Support Utility Functions
;-------------------------------------------------------------------------------
; acos
; Arguments: 1
;   x = real number between 0 and 1. May be passed as the sum of dividing two
;       sides of a right triangle.
; Returns: acos of x, the radian degrees between sides of a right triangle
;-------------------------------------------------------------------------------
(defun acos (x)
  (atan (/ (sqrt (- 1 (* x x))) x))
);defun acos
;-------------------------------------------------------------------------------
; asin
; Arguments: 1
;   sine = real number between -1 to 1
; Returns: arcsin of sine
;-------------------------------------------------------------------------------
(defun asin (sine / cosine)
  (setq cosine (sqrt (- 1.0 (expt sine 2))))
  (if (zerop cosine)
    (setq cosine 0.000000000000000000000000000001)
  );if
  (atan (/ sine cosine))
);defun asin
;-------------------------------------------------------------------------------
; Center3Pt - Center point of 3 points on a circle
; Arguments: 3
;   Pt1 = First point
;   Pt2 = Second point
;   Pt3 = Third point
; Returns: Center point of 3 points on a circle
;-------------------------------------------------------------------------------
(defun Center3Pt (Pt1 Pt2 Pt3 / Pt Pt4 Pt5 Pt6 Pt7)
  (setq Pt4 (polar Pt1 (angle Pt1 Pt2) (/ (distance Pt1 Pt2) 2.0))
        Pt5 (polar Pt4 (+ (angle Pt1 Pt2) (* pi 0.5)) 1)
        Pt6 (polar Pt2 (angle Pt2 Pt3) (/ (distance Pt2 Pt3) 2.0))
        Pt7 (polar Pt6 (+ (angle Pt2 Pt3) (* pi 0.5)) 1)
        Pt (inters Pt4 Pt5 Pt6 Pt7 nil)
  );setq
);defun Center3Pt
;-------------------------------------------------------------------------------
; Change_nth - Changes the nth item in a list with a new item value.
; Arguments: 3
;   Num# = Nth number in list to change
;   Value = New item value to change to
;   OldList@ = List to change item value
; Returns: A list with the nth item value changed.
;-------------------------------------------------------------------------------
(defun Change_nth (Num# Value OldList@)
  (if (<= 0 Num# (1- (length OldList@)))
    (if (> Num# 0)
      (cons (car OldList@) (Change_nth (1- Num#) Value (cdr OldList@)))
      (cons Value (cdr OldList@))
    );if
    OldList@
  );if
);defun Change_nth
;-------------------------------------------------------------------------------
; delay - time delay function
; Arguments: 1
;   Percent~ - Percentage of *Speed# variable
; Returns: time delay
;-------------------------------------------------------------------------------
(defun delay (Percent~ / Number~)
  (if (not *Speed#) (Speed))
  (repeat (fix (* *Speed# Percent~)) (setq Number~ pi))
  (princ)
);defun delay
;-------------------------------------------------------------------------------
; Delete_nth - Deletes the nth item from a list.
; Arguments: 2
;   Num# = Nth number in list to delete
;   OldList@ = List to delete the nth item
; Returns: A list with the nth item deleted.
;-------------------------------------------------------------------------------
(defun Delete_nth (Num# OldList@)
  (setq Num# (1+ Num#))
  (vl-remove-if '(lambda (x) (zerop (setq Num# (1- Num#)))) OldList@)
);defun Delete_nth
;-------------------------------------------------------------------------------
; dtr - Degrees to Radians.
; Arguments: 1
;   Deg~ = Degrees
; Syntax: (dtr Deg~)
; Returns: Value in radians.
;-------------------------------------------------------------------------------
(defun dtr (Deg~)
  (* pi (/ Deg~ 180.0))
);defun dtr
;-------------------------------------------------------------------------------
; GetBlockList
;-------------------------------------------------------------------------------
(defun GetBlockList (/ BlockList@ Block$ List@)
  (if (setq List@ (tblnext "BLOCK" t))
    (while List@
      (setq Block$ (cdr (assoc 2 List@)))
      (if (/= (substr Block$ 1 1) "*")
        (setq BlockList@ (append BlockList@ (list Block$)))
      );if
      (setq List@ (tblnext "BLOCK"))
    );while
  );if
  (if BlockList@
    (setq BlockList@ (Acad_StrlSort BlockList@))
  );if
  BlockList@
);defun GetBlockList
;-------------------------------------------------------------------------------
; GetRnd - Generates a random number
; Arguments: 1
;   Num# = Maximum random integer number range greater than or less than 0.
; Returns: Random integer number between 0 and Num#.
;-------------------------------------------------------------------------------
(defun GetRnd (Num# / MaxNum# PiDate$ RndNum# Minus Loop)
  (if (or (/= (type Num#) 'INT)(= Num# 0))
    (progn
      (princ "\nSyntax: (GetRnd Num#) Num# = Maximum random integer number range\ngreater than or less than 0.")
      (exit)
    );progn
  );if
  (if (< Num# 0)
    (setq MaxNum# (abs (1- Num#)) Minus t)
    (setq MaxNum# (1+ Num#))
  );if
  (if (not *RndNum*) (setq *RndNum* 10000))
  (setq Loop t)
  (while Loop
    (if (or (null *int*)(> *int* 100))
      (setq *int* 1)
      (setq *int* (1+ *int*))
    );if
    (setq PiDate$ (rtos (* (getvar "cdate") (* pi *int*)) 2 8 ))
    (cond
      ((>= MaxNum# 10000)
        (setq RndNum# (fix (* (atof (substr PiDate$ 13 5)) (* MaxNum# 0.00001))))
      )
      ((>= MaxNum# 1000)
        (setq RndNum# (fix (* (atof (substr PiDate$ 14 4)) (* MaxNum# 0.0001))))
      )
      ((>= MaxNum# 100)
        (setq RndNum# (fix (* (atof (substr PiDate$ 15 3)) (* MaxNum# 0.001))))
      )
      ((>= MaxNum# 10)
        (setq RndNum# (fix (* (atof (substr PiDate$ 16 2)) (* MaxNum# 0.01))))
      )
      ((>= MaxNum# 1)
        (setq RndNum# (fix (* (atof (substr PiDate$ 17 1)) (* MaxNum# 0.1))))
      )
      (t (setq RndNum# 0))
    );cond
    (if (/= RndNum# *RndNum*)
      (setq Loop nil)
    );if
  );while
  (setq *RndNum* RndNum#)
  (if Minus
    (setq RndNum# (* RndNum# -1))
  );if
  RndNum#
);defun GetRnd
;-------------------------------------------------------------------------------
; Insert_nth - Inserts a new item value into the nth number in list.
; Arguments: 3
;   Num# = Nth number in list to insert item value
;   Value = Item value to insert
;   OldList@ = List to insert item value
; Returns: A list with the new item value inserted.
;-------------------------------------------------------------------------------
(defun Insert_nth (Num# Value OldList@ / Temp@)
  (if (< -1 Num# (1+ (length OldList@)))
    (progn
      (repeat Num#
        (setq Temp@ (cons (car OldList@) Temp@)
              OldList@ (cdr OldList@)
        );setq
      );repeat
      (append (reverse Temp@) (list Value) OldList@)
    );progn
    OldList@
  );if
);defun Insert_nth
;-------------------------------------------------------------------------------
; MirrorPt - Mirror point
; Arguments: 3
;   Pt = Point to mirror
;   BasePt = Base point
;   Angle~ = Mirror angle in radians
; Returns: Returns location of mirrored point
;-------------------------------------------------------------------------------
(defun MirrorPt (Pt BasePt Angle~ / Pt1)
  (if (> Angle~ pi)
    (setq Angle~ (- Angle~ pi))
  );if
  (setq Pt1 (inters Pt (polar Pt (+ Angle~ (* pi 0.5)) 1)
                    BasePt (polar BasePt Angle~ 1) nil)
        Pt1 (polar Pt1 (angle Pt Pt1) (distance Pt Pt1))
  );setq
);defun MirrorPt
;-------------------------------------------------------------------------------
; Move_nth - Moves the nth Num1# item value to the nth Num2# location in a list.
; Arguments: 3
;   Num1# = Nth number in list to move item value
;   Num2# = Nth number in list to move item value of nth Num1# into
;   OldList@ = List to move item values
; Returns: A list with nth item value moved.
;-------------------------------------------------------------------------------
(defun Move_nth (Num1# Num2# OldList@ / Move_nth:)
  (defun Move_nth: (Num1# Num2# OldList@ Nth# Item)
    (cond
      ((and (> Nth# Num1#) (> Nth# Num2#))
        OldList@
      );case
      ((= Nth# Num1#)
        (Move_nth: Num1# (1+ Num2#) (cdr OldList@) (1+ Nth#) Item)
      );case
      ((= Nth# Num2#)
        (cons Item (Move_nth: (1+ Num1#) Num2# OldList@ (1+ Nth#) Item))
      );case
      ((cons (car OldList@)
        (Move_nth: Num1# Num2# (cdr OldList@) (1+ Nth#) Item))
      );case
    );cond
  );defun Move_nth:
  (if (and (/= Num1# Num2#) (<= 0 Num1# (1- (length OldList@))) (<= 0 Num2# (1- (length OldList@))))
    (Move_nth: Num1# Num2# OldList@ 0 (nth Num1# OldList@))
    OldList@
  );if
);defun Move_nth
;-------------------------------------------------------------------------------
; PurgeGroups - Purge Unused Groups
;-------------------------------------------------------------------------------
(defun PurgeGroups (/ AllGroups@ Cnt# Dictionary^ EntFirst^ EntList@ FirstGroup$
  Group^ GroupName$ Item Previous$ Pt SS& UsedGroups@)
  (setq Pt (polar (getvar "VIEWCTR") (* pi 1.5)(/ (getvar "VIEWSIZE") 2.0)))
  (command "LINE" Pt (polar Pt (* pi 1.5) 0.00000001) "")
  (setq EntFirst^ (entlast))
  (setq FirstGroup$ (UniqueName))
  (command "-GROUP" "C" FirstGroup$ "" EntFirst^ "")
  (setq EntList@ (entget EntFirst^))
  (setq Group^ (cdr (assoc 330 EntList@)))
  (setq EntList@ (entget Group^))
  (setq Dictionary^ (cdr (assoc 330 EntList@)))
  (setq EntList@ (entget Dictionary^))
  (foreach Item EntList@
    (if (= (car Item) 3)
      (if (not (member (cdr Item) AllGroups@))
        (setq AllGroups@ (append AllGroups@ (list (cdr Item))))
      );if
    );if
  );foreach
  (setq SS& (ssget "X"))
  (setq Cnt# 0)
  (repeat (sslength SS&)
    (setq EntList@ (entget (ssname SS& Cnt#)))
    (if (= (cdr (assoc 102 EntList@)) "{ACAD_REACTORS")
      (progn
        (setq Group^ (cdr (assoc 330 EntList@)))
        (setq EntList@ (entget Group^))
        (if (setq Dictionary^ (cdr (assoc 330 EntList@)))
          (progn
            (setq EntList@ (entget Dictionary^))
            (setq Previous$ "")
            (foreach Item EntList@
              (setq Item (cdr Item))
              (if (equal Item Group^)
                (setq GroupName$ Previous$)
              );if
              (setq Previous$ Item)
            );foreach
            (if (not (member GroupName$ UsedGroups@))
              (setq UsedGroups@ (append UsedGroups@ (list GroupName$)))
            );if
          );progn
        );if
      );progn
    );if
    (setq Cnt# (1+ Cnt#))
  );repeat
  (foreach GroupName$ AllGroups@
    (if (not (member GroupName$ UsedGroups@))
      (command "-GROUP" "E" GroupName$)
    );if
  );foreach
  (command "-GROUP" "E" FirstGroup$)
  (command "ERASE" EntFirst^ "")
  (princ)
);defun PurgeGroups
;-------------------------------------------------------------------------------
; Remove_nths - Removes the RemoveList@ of nths from a list.
; Arguments: 2
;   RemoveList@ = List of nths to remove
;   OldList@ = List to remove the list of nths from
; Returns: A list with the list of nths removed.
;-------------------------------------------------------------------------------
(defun Remove_nths (RemoveList@ OldList@)
  (if (and RemoveList@ OldList@)
    (if (zerop (car RemoveList@))
      (Remove_nths (mapcar '1- (cdr RemoveList@)) (cdr OldList@))
      (cons (car OldList@) (Remove_nths (mapcar '1- RemoveList@) (cdr OldList@)))
    );if
    OldList@
  );if
);defun Remove_nths
;-------------------------------------------------------------------------------
; rtd - Radians to degrees
; Arguments: 1
;   Rad~ = radians
; Syntax: (rtd R)
; Returns: value in degrees.
;-------------------------------------------------------------------------------
(defun rtd (Rad~)
  (* 180.0 (/ Rad~ pi))
);defun rtd
;-------------------------------------------------------------------------------
; Speed - Determines the computer processing speed and sets the global variable
; *speed# which may be used in delay loops.
;-------------------------------------------------------------------------------
(defun Speed (/ Cdate~ Cnt# NewSecond# OldSecond#)
  (setq Cdate~ (getvar "CDATE"))
  (setq NewSecond# (fix (* (- (* (- Cdate~ (fix Cdate~)) 100000)(fix (* (- Cdate~ (fix Cdate~)) 100000))) 10)))
  (repeat 2
    (setq Cnt# 0)
    (setq OldSecond# NewSecond#)
    (while (= NewSecond# OldSecond#)
      (setq Cdate~ (getvar "CDATE"))
      (setq NewSecond# (fix (* (- (* (- Cdate~ (fix Cdate~)) 100000)(fix (* (- Cdate~ (fix Cdate~)) 100000))) 10)))
      (setq Cnt# (1+ Cnt#))
    );while
  );repeat
  (setq *Speed# Cnt#)
  (princ)
);defun Speed
;-------------------------------------------------------------------------------
; StarBurst - Draws a starburst shape
; Arguments: 5
;   CenPt = Center of starburst
;   Dia1~ = Inside diameter
;   Dia2~ = Outside diameter
;   Sides# = Number of points
;   StartAng~ = Radian angle of first point
; Returns: Draws a starburst shape
;-------------------------------------------------------------------------------
(defun StarBurst (CenPt Dia1~ Dia2~ Sides# StartAng~ / Ang~ Ang1~ List@ List1@
  List2@ List3@ Cnt1# Cnt2# Pt)
  (setq Ang~ (/ pi Sides#))
  (setq Ang1~ (+ StartAng~ (/ Ang~ 2.0)))
  (repeat (* Sides# 2)
    (setq Pt (polar CenPt Ang1~ (/ Dia1~ 2.0)))
    (setq List1@ (append List1@ (list Pt)))
    (setq Ang1~ (+ Ang1~ Ang~))
  );repeat
  (setq Ang1~ (+ StartAng~ Ang~))
  (repeat Sides#
    (setq Pt (polar CenPt Ang1~ (/ (+ Dia1~ Dia2~) 4.0)))
    (setq List2@ (append List2@ (list Pt)))
    (setq Ang1~ (+ Ang1~ (* Ang~ 2)))
  );repeat
  (setq Ang1~ StartAng~)
  (repeat Sides#
    (setq Pt (polar CenPt Ang1~ (/ Dia2~ 2.0)))
    (setq List3@ (append List3@ (list Pt)))
    (setq Ang1~ (+ Ang1~ (* Ang~ 2)))
  );repeat
  (setq Cnt1# 0 Cnt2# 0)
  (repeat Sides#
    (setq List@ (append List@ (list (nth Cnt1# List3@))))
    (setq List@ (append List@ (list (nth Cnt2# List1@))))
    (setq Cnt2# (1+ Cnt2#))
    (setq List@ (append List@ (list (nth Cnt1# List2@))))
    (setq List@ (append List@ (list (nth Cnt2# List1@))))
    (setq Cnt2# (1+ Cnt2#))
    (setq Cnt1# (1+ Cnt1#))
  );repeat
  (setq List@ (append List@ (list (nth 0 List3@))))
  (command "PLINE" (foreach Pt List@ (command Pt)))
  (princ)
);defun StarBurst
;-------------------------------------------------------------------------------
; Switch_nth - Switches the nth Num1# and Num2# item values in a list.
; Arguments: 3
;   Num1# = nth number in list to switch with nth Num2#
;   Num2# = nth number in list to switch with nth Num1#
;   OldList@ = List to switch item values
; Returns: A list with two item values switched.
;-------------------------------------------------------------------------------
(defun Switch_nth (Num1# Num2# OldList@ / Index#)
  (setq Index# -1)
  (if (and (< -1 Num1# (length OldList@)) (< -1 Num2# (length OldList@)))
    (mapcar '(lambda (x) (setq Index# (1+ Index#))
      (cond
        ((= Index# Num2#) (nth Num1# OldList@))
        ((= Index# Num1#) (nth Num2# OldList@))
        (x)
      )) OldList@
    );mapcar
    OldList@
  );if
);defun Switch_nth
;-------------------------------------------------------------------------------
; tan - Tangent of radian degrees
; Arguments: 1
;   radians = Radian degrees
; Returns: Tangent of radian degrees
;-------------------------------------------------------------------------------
(defun tan (radians)
  (/ (sin radians) (cos radians))
);defun tan
;-------------------------------------------------------------------------------
; UniqueName - Creates a unique name for temp blocks and groups
;-------------------------------------------------------------------------------
(defun UniqueName (/ Loop Name$)
  (setq Loop t)
  (while Loop
    (setq Name$ (rtos (getvar "CDATE") 2 8))
    (setq Name$ (strcat (substr Name$ 4 5)(substr Name$ 10 8)))
    (if (/= Name$ *UniqueName$)
      (setq *UniqueName$ Name$ Loop nil)
    );if
  );while
  *UniqueName$
);defun UniqueName
;-------------------------------------------------------------------------------
; ViewExtents
; Returns: List of upper left and lower right points of current view
;-------------------------------------------------------------------------------
(defun ViewExtents (/ A B C D X)
  (setq B (getvar "VIEWSIZE")
        A (* B (/ (car (getvar "SCREENSIZE")) (cadr (getvar "SCREENSIZE"))))
        X (trans (getvar "VIEWCTR") 1 2)
        C (trans (list (- (car X) (/ A 2.0)) (+ (cadr X) (/ B 2.0))) 2 1)
        D (trans (list (+ (car X) (/ A 2.0)) (- (cadr X) (/ B 2.0))) 2 1)
  );setq
  (list C D)
);defun ViewExtents
;-------------------------------------------------------------------------------
(princ)

 


<<

Filename: 310305_troy.lsp
Tác giả: pphung183
Bài viết gốc: 310306
Tên lệnh: noel xmas
Giải trí với Lisp đi nào!

Cây Noel

(defun c:noel () (c:XMAS))
(defun c:XMAS (/ rad R N Z dZ a da d H I J K +- s c)
  (setq c (if (>= (getvar "acadver") "15")
    	vl-cmdf
    	command
  	)
  )
  (setq	d distance
	s setvar
  )
  (s "CMDECHO" 0)
  (s "UCSICON" 0)
  (s "TILEMODE" 1)
  (s "UCSFOLLOW" 0)
  (s "HIGHLIGHT" 0)
  (s "REGENMODE" 1)
  (c "_.LINE" "0,0" "1,1" "")
  (c "_.ZOOM" "_E")
  (C "_.LAYER" "_U" "*" "")
  (C "_.ERASE" (ssget "_X") "")
  (c "_.UCS" "_W")
  (C "_.VPOINT"...
>>

Cây Noel

(defun c:noel () (c:XMAS))
(defun c:XMAS (/ rad R N Z dZ a da d H I J K +- s c)
  (setq c (if (>= (getvar "acadver") "15")
    	vl-cmdf
    	command
  	)
  )
  (setq	d distance
	s setvar
  )
  (s "CMDECHO" 0)
  (s "UCSICON" 0)
  (s "TILEMODE" 1)
  (s "UCSFOLLOW" 0)
  (s "HIGHLIGHT" 0)
  (s "REGENMODE" 1)
  (c "_.LINE" "0,0" "1,1" "")
  (c "_.ZOOM" "_E")
  (C "_.LAYER" "_U" "*" "")
  (C "_.ERASE" (ssget "_X") "")
  (c "_.UCS" "_W")
  (C "_.VPOINT" "-3,-3,1.2")
  (C "_.ZOOM" "_C" "0,0,7" 15)
  (defun rad (Z) (* 0.75 (sqrt (- 12.0 Z))))
  (setq	N   25
	Z   1.0
	dZ  0.5
	a   0.0
	da  (/ pi N)
	hpi (* pi 0.5)
  )
  (while (< Z 12.0)
	(setq R (rad Z))
	(repeat N
  	(setq +- (if (= +- -)
 		+
 		-
   		)
    	H  (list 0.0 0.0 (+- Z (* dz 0.25)))
    	I  (polar H a R)
    	a  (+ a da)
    	I  (mapcar '+ I (list 0.0 0.0 (* dZ 0.5)))
    	J  (polar H a (+ R R))
    	a  (+ a da)
    	J  (mapcar '+ J (list 0.0 0.0 dZ))
    	K  (polar H a R)
    	K  (mapcar '+ K (list 0.0 0.0 (* dZ 0.1)))
  	)
  	(entmake (list '(0 . "3DFACE")
     		'(62 . 3)
     		'(70 . 0)
     		(cons 10 H)
     		(cons 11 I)
     		(cons 12 J)
     		(cons 13 K)
   		)
  	)
  	(if (and (zerop (rem (1- Z) 1)) (zerop (rem N 5)))
	(progn
  	(entmake (list '(0 . "CIRCLE")
     		(cons 10 J)
     		'(40 . 0.07)
     		'(39 . 0.35)
     		'(62 . 255)
   		)
  	)
  	(prompt " HO")
  	(setq J (mapcar '+ J (list 0.0 0.0 0.4)))
  	(entmake
    	(list '(0 . "3DFACE")
      	'(62 . 2)
      	'(70 . 0)
      	(cons 10 (polar J (+ a hpi) (* (d I K) 0.2)))
      	(cons 11 (polar J (- a hpi) (* (d I K) 0.2)))
      	(cons 12 (mapcar '+ J (list 0.0 0.0 (* dZ 0.5))))
      	(cons 13 (mapcar '+ J (list 0.0 0.0 (* dZ 0.5))))
    	)
  	)
	)
  	)
	)
	(terpri)
	(setq Z (+ Z dZ)
  	a (+ a (/ da 2))
	)
  )
  (entmake '((0 . "3DFACE")
 		(62 . 7)
 		(10 -0.536 0.57073 13.225)
 		(11 0.5123 -0.545566 13.225)
 		(12 -0.011815 0.012582 12.6687)
 		(13 -0.0118153 0.012582 12.6687)
 		(70 . 0)
    	)
  )
  (entmake '((0 . "3DFACE")
 		(62 . 7)
 		(10 -0.3357 0.3575 12.325)
 		(11 -0.0118 0.01258 13.7813)
 		(12 0.18839 -0.200611 12.8812)
 		(13 0.188387 -0.200611 12.8812)
 		(70 . 0)
    	)
  )
  (entmake '((0 . "3DFACE")
 		(62 . 7)
 		(10 -0.536 0.57073 13.225)
 		(11 0.31212 -0.33237 12.3249)
 		(12 0.111916 -0.11918 13.225)
 		(13 0.111916 -0.119179 13.225)
 		(70 . 0)
    	)
  )
;  (c "_.SHADE")
  (command "_zoom" "_e")
  (command "_zoom" ".9x")
  (command "_shademode" "_g")
  (setvar "cmdecho" 1)
  (alert "\nMerry Christmas!\Chuc Giang Sinh Vui ve !")
  (princ)
)


<<

Filename: 310306_noel_xmas.lsp
Tác giả: ketxu
Bài viết gốc: 110145
Tên lệnh: ffs
Cùng nhau học LISP
Thú thực với bác phamngoctukts là hnay cái này là cái đầu tiên e bắt đầu vào vòng lặp(vì e đã học lt đâu ^^),và ssget thì vẫn chưa biết dùng thành thạo :( Bác hướng dẫn cho e trong trường hợp này được k ạ?
E cứ tưởng thế này là được,nào ngờ chưa phải..Ssget trả về tập entity chọn đúng...
>>
Thú thực với bác phamngoctukts là hnay cái này là cái đầu tiên e bắt đầu vào vòng lặp(vì e đã học lt đâu ^^),và ssget thì vẫn chưa biết dùng thành thạo :( Bác hướng dẫn cho e trong trường hợp này được k ạ?
E cứ tưởng thế này là được,nào ngờ chưa phải..Ssget trả về tập entity chọn đúng không ạ :).Vậy nó dạng ntn ạ ?
E sửa thế này rồi...sai be bét :( Dòng 1,2 có vấn đề e chưa biết.Tham khảo 1 số code e thấy chọn cả lwpolyline có nghĩa là j ạ,cóđiều gì khác biệt ạ

<<

Filename: 110145_ffs.lsp
Tác giả: giaptk3
Bài viết gốc: 13484
Tên lệnh: sum
Chuyển bình đồ từ JPG sang DWG


cảm ơn bác. đó là tôi chỉ đưa ra ví dụ hình như thế thôi
không biết thì nên im lặng.

Filename: 13484_sum.lsp
Tác giả: luhaivinh
Bài viết gốc: 310494
Tên lệnh: bt2-1 bt2-2 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 c55 c66 c77 c88 c99 c100 c111
Chương 3 - Các hàm nhập liệu

em nộp bài nha thầy.

thầy xêm giùm có gì sai không?

;Chuong 2

(defun c:BT2-1(/ x y z e)
  (setq x (+ 2 7) y (- 3 1.25) z 5.0)
  (setq e (+ z (* 0.4 (- x y))))
  (setq ketqua (+ x y z e))
   )
(defun c:BT2-2(/ a b c)
  (setq ketqua nil)
  (setq a 2000)
  (setq b 1000)
  (setq c (* a b 0.5))
)
(defun trungbinhcongbaso(a b c)
  (/ (+ a b c) 3.0)
)
(defun dientichtamgiac(a b)
  (* a b 0.5)
)
(defun tichbonso(a b c d)
    (* a b c...
>>

em nộp bài nha thầy.

thầy xêm giùm có gì sai không?

;Chuong 2

(defun c:BT2-1(/ x y z e)
  (setq x (+ 2 7) y (- 3 1.25) z 5.0)
  (setq e (+ z (* 0.4 (- x y))))
  (setq ketqua (+ x y z e))
   )
(defun c:BT2-2(/ a b c)
  (setq ketqua nil)
  (setq a 2000)
  (setq b 1000)
  (setq c (* a b 0.5))
)
(defun trungbinhcongbaso(a b c)
  (/ (+ a b c) 3.0)
)
(defun dientichtamgiac(a b)
  (* a b 0.5)
)
(defun tichbonso(a b c d)
    (* a b c d)
)
(defun lapphuongmotso(a)
  (*  a a a)
)
;chuong 3.1

(defun c:c1(/ a b) ;cau 1 dientichtamgiacnhap
  (setq a (getreal "\nNhap chieu cao:"))
  (setq b (getreal "\nNhap chieu dai:"))
  (dientichtamgiac a b)
)

(defun c:c2(/ a b c);cau 2 trungbinhcongbasonhap
  (setq a (getreal "\nNhap so thu nhat:"))
  (setq b (getreal "\nNhap so thu hai:"))
  (setq c (getreal "\nNhap so thu ba:"))
  (trungbinhcongbaso a b c)
)

(defun c:c3(/ a b c d);cau 3 tichbonsonhap
  (setq a (getreal "\nNhap so thu nhat:"))
  (setq b (getreal "\nNhap so thu hai:"))
  (setq c (getreal "\nNhap so thu ba:"))
  (setq d (getreal "\nNhap so thu tu:"))
  (tichbonso a b c d)
)

(defun c:c4(/ a);cau 4 lapphuongmotsonhap
  (setq a (getreal "\nNhap so:"))
  (lapphuongmotso a )
)

(defun c:c5(/ d1 d2);cau 5 dientichvanhkhannhap
  (defun dientichvanhkhan(d1 d2)
  (- (* pi d1 d1 ) (* pi d2 d2 ))
   )
  (setq d1 (getreal "\nNhap ban kinh lon:"))
  (setq d2 (getreal "\nNhap ban kinh nho:"))
  (dientichvanhkhan d1 d2)
)

(defun c:c6(/ a b c p);cau 6 dientichtamgiaccanh
  (defun dttgc(a b c p)
  (sqrt (* p (- p a) (- p b) (- p c)))
    )
  (setq a (getreal "\nNhap canh thu nhat:"))
  (setq b (getreal "\nNhap canh thu hai:"))
  (setq c (getreal "\nNhap canh thu ba:"))
  (setq p (* (+ a b c) 0.5))
  (dttgc a b c p)
  )

(defun c:c7(/ d);cau 7 dientichmatthep
  (defun dtmt(d)
    (* pi d d 0.5 0.5)
    )
  (setq d (getdist "\nNhap duong kinh thep:"))
  (dtmt d)
  )
(defun c:c8(/ d);cau 8 khoiluongthep
  (defun klt(d)
    (* pi d d 0.5 0.5 11.7 7850 )
    )
  (setq d (getreal "\nNhap duong kinh thep:"))
  (klt d)
  )
(defun c:c9(/ a th);cau 9 khoiluongthepvungd
  (defun kltd(a th)
    (* (- (* a a) (* (- a th) (- a th))) 11.7 7850)
    )
  (setq a (getreal "\nNhap chieu dai canh ngoai:"))
  (setq th (getreal "\nNhap be day thep:"))
  (kltd a th)
  )
(defun c:c10(/ a1 a2);cau 10 khoiluongthepvungc
  (defun kltc(a1 a2)
    (* (- (* a1 a1) (* a2 a2)) 11.7 7850)
    )
  (setq a1 (getreal "\nNhap chieu dai canh ngoai:"))
  (setq a2 (getreal "\nNhap chieu dai canh trong:"))
  (kltc a1 a2)
  )
(defun c:c11(/ a);cau 11 doi don vi
  (defun doi (a)
    (/ a 1000)
   )
  (setq a (getreal "\nNhap gia tri (mm):"))
  (doi a)
  )

 ;chuong 3.2

(defun c:c55(/ dtvk d1 d2);cau 5 dientichvanhkhannhap
  (defun dtvk(d1 d2)
  (- (* pi d1 d1 ) (* pi d2 d2 ))
   )
  (setq d1 (getreal "\nNhap ban kinh lon:"))
  (setq d2 (getreal "\nNhap ban kinh nho:"))
  (dtvk d1 d2)
)

(defun c:c66(/ dttgc a b c p);cau 6 dientichtamgiaccanh
  (defun dttgc(a b c p)
  (sqrt (* p (- p a) (- p b) (- p c)))
    )
  (setq a (getreal "\nNhap canh thu nhat:"))
  (setq b (getreal "\nNhap canh thu hai:"))
  (setq c (getreal "\nNhap canh thu ba:"))
  (setq p (* (+ a b c) 0.5))
  (dttgc a b c p)
  )

(defun c:c77(/ dtmt d);cau 7 dientichmatthep
  (defun dtmt(d)
    (* pi d d 0.5 0.5)
    )
  (setq d (getreal "\nNhap duong kinh thep:"))
  (dtmt d)
  )
(defun c:c88(/ klt d);cau 8 khoiluongthep
  (defun klt(d)
    (* pi d d 0.5 0.5 11.7 7850 )
    )
  (setq d (getreal "\nNhap duong kinh thep:"))
  (klt d)
  )
(defun c:c99(/ kltd a th);cau 9 khoiluongthepvungd
  (defun kltd(a th)
    (* (- (* a a) (* (- a th) (- a th))) 11.7 7850)
    )
  (setq a (getreal "\nNhap chieu dai canh ngoai:"))
  (setq th (getreal "\nNhap be day thep:"))
  (kltd a th)
  )
(defun c:c100(/ a1 a2);cau 10 khoiluongthepvungc
  (defun kltc(a1 a2)
    (* (- (* a1 a1) (* a2 a2)) 11.7 7850)
    )
  (setq a1 (getreal "\nNhap chieu dai canh ngoai:"))
  (setq a2 (getreal "\nNhap chieu dai canh trong:"))
  (kltc a1 a2)
  )
(setq kltc nil)
(defun c:c111(/ a);cau 11 doi don vi
  (defun doi (a)
    (/ a 1000)
   )
  (setq a (getreal "\nNhap gia tri (mm):"))
  (doi a)
  )
(setq doi nil)

Bài tập 3.2

theo em để loại bỏ hàm con khỏi thục tục thi ta :

- Liệt kê hàm con sau dau /

- setq ham con la nil

---> Hiện giờ em vẫn chưa biết 2 cách trên co sự khác nhau rõ ràng mong thầy giải thich cho em biết rõ.

*** Thầy cho em hỏi tại sao khi dùng hai cách trên nhiều lúc em khử được hàm con nhưng cũng có lúc em lại không khử được?


<<

Filename: 310494_bt2-1_bt2-2_c1_c2_c3_c4_c5_c6_c7_c8_c9_c10_c11_c55_c66_c77_c88_c99_c100_c111.lsp
Tác giả: phuong44e1
Bài viết gốc: 281770
Tên lệnh: dttg tbc3s
Chương 3 - Các hàm nhập liệu
; bai tap cua phuong44e1
; 2014-02-28

; bai tap 3-1_Tinh dien tich tam giac tu hai canh da biet
(Defun c:DTTG (/ a h dientich)
      (setq a (getreal "\n Nhap gia tri canh day:"))
      (setq h (getreal "\n Nhap gia tri duong cao:"))
      (defun dientich (x y)
      (* 0.5 a h))
      (Prompt "\n Dien tich tam giac la: ")
      (dientich a h))


;************************************************

; bai tap 3-2_ Tinh trung binh cong cua 3 so nhap vao
(Defun c:TBC3S...
>>
; bai tap cua phuong44e1
; 2014-02-28

; bai tap 3-1_Tinh dien tich tam giac tu hai canh da biet
(Defun c:DTTG (/ a h dientich)
      (setq a (getreal "\n Nhap gia tri canh day:"))
      (setq h (getreal "\n Nhap gia tri duong cao:"))
      (defun dientich (x y)
      (* 0.5 a h))
      (Prompt "\n Dien tich tam giac la: ")
      (dientich a h))


;************************************************

; bai tap 3-2_ Tinh trung binh cong cua 3 so nhap vao
(Defun c:TBC3S (/ a b c)
      (setq a (getreal "\n Nhap gia tri a:"))
      (setq b (getreal "\n Nhap gia tri b:"))
      (setq c (getreal "\n Nhap gia tri c:"))
      (defun trungbinhcong3so (x y z)
      (/ (+ a b c) 3.0))
      (Prompt "\n Gia tri trung binh ba so la: ")
      (trungbinhcong3so a b c))
(setq trungbinhcong3so nil)  

Gửi lại bạn Ketxu 2 bài tập khử hàm được làm theo hai cách

1/ khai báo tên hàm định nghĩa vào thủ tục như 1 biến

2/ Gán hàm định nghĩa bàng nil

Không biết đã đạt hay chưa?


<<

Filename: 281770_dttg_tbc3s.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 265862
Tên lệnh: test
Nhờ các anh sửa giúp lisp chuyển vị trí text sang trái (Justifi : Left)

Cho em hỏi chút là sao em sửa đoạn mã này dùng với mã căn lề trái 0 (Left) mà sao nó tại hiểu là giữa (Center) nhỉ? 

;;;acAlignmentLeft = 0
 

;;;acAlignmentLeft = 0

;;;acAlignmentCenter =1

(defun c:test ( / )
(setq e1 (entsel "Choose a text: "))
(setq en (entget(car e1)))
(entmod 
(subst (cons 73 0) (assoc 73 en) en) ;;;0 = Left...
>>

Cho em hỏi chút là sao em sửa đoạn mã này dùng với mã căn lề trái 0 (Left) mà sao nó tại hiểu là giữa (Center) nhỉ? 

;;;acAlignmentLeft = 0
 

;;;acAlignmentLeft = 0

;;;acAlignmentCenter =1

(defun c:test ( / )
(setq e1 (entsel "Choose a text: "))
(setq en (entget(car e1)))
(entmod 
(subst (cons 73 0) (assoc 73 en) en) ;;;0 = Left (Center ?)
)
);entmod
(princ)
)

 

(setq e1 (entsel "Choose a text: "))
(setq en (entget(car e1)))
(entmod 
(defun c:test ( / )
(setq e1 (entsel "Choose a text: "))
(setq en (entget(car e1)))
(entmod 
(subst (cons 73 0) (assoc 73 en) en)
)
);entmod
(princ)
)
;;;acAlignmentLeft = 0
;;;acAlignmentCenter =1
(setq e1 (entsel "Choose a text: "))
(setq en (entget(car e1)))
(entmod 
(subst (cons 73 0) (assoc 73 en) en)
)
);entmod
(princ)
)

<<

Filename: 265862_test.lsp
Tác giả: lenhatanh
Bài viết gốc: 310559
Tên lệnh: excel
AutoCAD với Excel

Tôi có một file Excel và một lisp để mở file Excel rồi ghi số liệu mới vào.

Tôi muốn lisp thực hiện theo hai cách sau:

1- Mở file Excel, xóa toàn bộ nội dung cũ trong các Sheet để ghi số liệu mới.

2- Mở file Excel, xóa toàn bộ các Sheet cũ, tạo các Sheet mới và ghi số liệu mới.

Tôi quá kém về các hàm Vla... nên không thực hiện được, nhờ mọi người giúp đỡ...

>>

Tôi có một file Excel và một lisp để mở file Excel rồi ghi số liệu mới vào.

Tôi muốn lisp thực hiện theo hai cách sau:

1- Mở file Excel, xóa toàn bộ nội dung cũ trong các Sheet để ghi số liệu mới.

2- Mở file Excel, xóa toàn bộ các Sheet cũ, tạo các Sheet mới và ghi số liệu mới.

Tôi quá kém về các hàm Vla... nên không thực hiện được, nhờ mọi người giúp đỡ nhé,

xin cảm ơn.

fIle Excel:  http://www.cadviet.com/upfiles/3/88193_du_tkk_1.rar

file lsp:

; Test lisp 09/09/2014
;-----------------------------------------------------------------------------------------
(defun C:excel()
  (vl-load-com)
  (setq lst_Sheet '("Kenh_chinh" "Kenh_CI" "Kenh_CII" "Kenh_CIII" "Kenh_ND"))
  (if (not fn)
    (progn
	  (setq fn (getfiled "Select Excel File" "" "xls" 0))
	  (if fn
        (progn
		  (WriteToExcel fn lst_Sheet T)
		)
		(progn
		  (WriteToExcel nil lst_Sheet T)
        )
	  )	
	)
  )
)
;------------------------------------------------------------------------------
(defun WriteToExcel (ExcelFile$ lst_Sheet Visible / Sheet$ Sheets@ Worksheet n)
  (if (= (type ExcelFile$) 'STR)
    (if (findfile ExcelFile$)
      (setq *ExcelFile$ ExcelFile$)
      (progn
        (alert (strcat "Excel file " ExcelFile$ " not found."))
        (exit)
      )
    )
    (setq *ExcelFile$ "")
  )
  (gc)
  (if (setq *ExcelApp% (vlax-get-object "Excel.Application"))
    (progn
      (alert "Close all Excel spreadsheets to continue!")
      (vlax-release-object *ExcelApp%)(gc)
    )
  )
  (setq *ExcelApp% (vlax-get-or-create-object "Excel.Application"))
  (if ExcelFile$
    (if (findfile ExcelFile$)
      (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Open ExcelFile$)
      (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Add)
    )
    (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Add)
  )
  (if Visible
    (vla-put-visible *ExcelApp% :vlax-true)
  )
  (setq n 0)
  (repeat (length lst_Sheet)
    (setq SheetName$ (nth n lst_Sheet))
    (if (= (type SheetName$) 'STR)
      (progn
        (vlax-for Sheet$ (vlax-get-property *ExcelApp% "Sheets")
          (setq Sheets@ (append Sheets@ (list (vlax-get-property Sheet$ "Name"))))
        )
;		(if (member SheetName$ Sheets@)
;          (vlax-for Worksheet (vlax-get-property *ExcelApp% "Sheets")
;            (if (= (vlax-get-property Worksheet "Name") "Kenh_ND")
;              (vlax-invoke-method Worksheet "Delete")
;            )
;          )
;        )
		(if (member SheetName$ Sheets@)
          (vlax-for Worksheet (vlax-get-property *ExcelApp% "Sheets")
            (if (= (vlax-get-property Worksheet "Name") "Kenh_ND")
              (vlax-invoke-method Worksheet "ClearContents")
            )
          )
        )
        (if (member SheetName$ Sheets@)
          (vlax-for Worksheet (vlax-get-property *ExcelApp% "Sheets")
            (if (= (vlax-get-property Worksheet "Name") SheetName$)
              (vlax-invoke-method Worksheet "Activate")	  
            )
          )
          (vlax-put-property (vlax-invoke-method (vlax-get-property *ExcelApp% "Sheets") "Add") "Name" SheetName$)
		)
      )
    )
    (setq n (1+ n))
  )
  (princ)
)

<<

Filename: 310559_excel.lsp
Tác giả: ketxu
Bài viết gốc: 310728
Tên lệnh: vps
lisp tạo tỉ lệ cho viewport bên layout

Quick code và không bắt lỗi, bạn dùng tạm. Có tỉ lệ nào thì bạn thêm vào mục Scale

Code có sử dụng hàm LM:Listbox của LeeMac cho nhanh

 

(vl-load-com)
(defun c:vps(/ l sc LM:ListBox)	
	;; Private function :
	(defun LM:ListBox ( title data multiple / file tmp dch return ) 
	  (cond
		(
		  (not
			(and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
			  (write-line
				(strcat "listbox :...
>>

Quick code và không bắt lỗi, bạn dùng tạm. Có tỉ lệ nào thì bạn thêm vào mục Scale

Code có sử dụng hàm LM:Listbox của LeeMac cho nhanh

 

(vl-load-com)
(defun c:vps(/ l sc LM:ListBox)	
	;; Private function :
	(defun LM:ListBox ( title data multiple / file tmp dch return ) 
	  (cond
		(
		  (not
			(and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
			  (write-line
				(strcat "listbox : dialog { label = \"" title
				  "\"; spacer; : list_box { key = \"list\"; multiple_select = "
				  (if multiple "true" "false") "; } spacer; ok_cancel;}"
				)
				file
			  )
			  (not (close file)) (< 0 (setq dch (load_dialog tmp))) (new_dialog "listbox" dch)
			)
		  )
		)
		(
		  t     
		  (start_list "list")
		  (mapcar 'add_list data) (end_list)

		  (setq return (set_tile "list" "0"))
		  (action_tile "list" "(setq return $value)")

		  (setq return
			(if (= 1 (start_dialog))
			  (mapcar '(lambda ( x ) (nth x data)) (read (strcat "(" return ")")))
			)
		  )          
		)
	  )
	  (if (< 0 dch) (unload_dialog dch))
	  (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
	  return
	)
	;Main
	(ssget '((0 . "VIEWPORT")))
	(setq l '("1/2" "1/5" "1/10"))			;Scale them o day
	(setq sc (distof (car (LM:listbox "Select Scale :" l nil))))
	(vlax-for vp	(vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
		(vla-put-DisplayLocked vp 0)
		(vla-put-CustomScale vp sc)
	)
)

<<

Filename: 310728_vps.lsp
Tác giả: hiepttr
Bài viết gốc: 310874
Tên lệnh: game
Chương 10.2 : Text Window, Redraw

tiếp bài 3:

;;Bai 3: Lenh xoa tat ca doi tuong tren man hinh, chi de lai dong chu THIS IS A PRANK
;Sau do, yeu cau nguoi dung nhap dung chu Please thi tra va trang thai ban dau
(defun c:GAME( / cmd ss str)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget "X"))
(if ss 
	(progn
		(an ss)
		(entmake (list
			'(0 . "TEXT") 
			'(100 . "AcDbEntity") 
			'(100 . "AcDbText") 
			'(10 0 0) 
			(cons 40 (/ (getvar "viewsize") 12))
			'(1 . "THIS...
>>

tiếp bài 3:

;;Bai 3: Lenh xoa tat ca doi tuong tren man hinh, chi de lai dong chu THIS IS A PRANK
;Sau do, yeu cau nguoi dung nhap dung chu Please thi tra va trang thai ban dau
(defun c:GAME( / cmd ss str)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget "X"))
(if ss 
	(progn
		(an ss)
		(entmake (list
			'(0 . "TEXT") 
			'(100 . "AcDbEntity") 
			'(100 . "AcDbText") 
			'(10 0 0) 
			(cons 40 (/ (getvar "viewsize") 12))
			'(1 . "THIS IS A PRANK") 
			(cons 72 1)
			(list 11 (car (setq tam (getvar "viewctr"))) (cadr tam)))
		) ;entmake
		(setq tbao (entlast))
		(while (or (not str) (/= str "Please")) (setq str (getstring "\nNhap dung chu: <Please>  de hien thi lai cong viec: ")))
		(if (= str "Please") (hien ss))
		(entdel tbao)
	) ;progn
) ;if
(setvar "cmdecho" cmd)
(princ)
)
;=======================================================================================
;********************************************
(defun an (ss / i)
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i))
	(redraw ename 2)
) 	;repeat
)
;==============***************==============
(defun hien (ss / i)
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i))
	(redraw ename 1)
) 	;repeat
)

<<

Filename: 310874_game.lsp
Tác giả: Tot77
Bài viết gốc: 310838
Tên lệnh: apl
xin giúp lisp nối các block bằng pline

Bạn dùng thử cái này, cái này cách làm khác không giống của bác Ket.

Đầu tiên chọn điểm chèn của block đầu tiên, rồi rê chuột đến đâu nó vẽ đến đó. Khi rê để ý cái hình vuông màu số 5, muốn tăng kích thước hình vuông bấm T (không cần enter, chỉ T thôi) , muốn giảm bấm G , muốn undo bấm U. Dứt lệnh mới bấm enter.

Khi rê thì dùng chuột giữa để zoom.

>>

Bạn dùng thử cái này, cái này cách làm khác không giống của bác Ket.

Đầu tiên chọn điểm chèn của block đầu tiên, rồi rê chuột đến đâu nó vẽ đến đó. Khi rê để ý cái hình vuông màu số 5, muốn tăng kích thước hình vuông bấm T (không cần enter, chỉ T thôi) , muốn giảm bấm G , muốn undo bấm U. Dứt lệnh mới bấm enter.

Khi rê thì dùng chuột giữa để zoom.

(defun c:apl(/ pnt ctro l done p1 p2 p3 p4 ss ssn tg os)
  (setq os (getvar 'osmode))
  (mapcar 'setvar (list 'osmode 'plinewid) '( 72 0))
  (setq pnt (getpoint "Chon diem dau:") 
ctro 5
tg 1
l nil
done nil)  
  (command "pline" pnt)
  (prompt "\nChon diem tiep theo <Tang/Giam/Undo>:")
  (while (and (setq pnt (grread t)) (not done))
    (cond ((= 5 (car pnt))
  (setq p1 (polar (polar (last pnt) 0 (* -0.5 ctro)) 1.5708 (* -0.5 ctro))
p2 (polar p1 0 ctro)
p3 (polar p2 1.5708 ctro)
p4 (polar p3 0 (- ctro)))
  (redraw) (grvecs (list 5 p1 p2 p2 p3 p3 p4 p4 p1))
  (if (and (setq ss (ssget "C" p1 p3 '(( 0 . "INSERT"))))
   (not (equal (last l) (ssname ss 0))))      
    (progn
      (setq ssn (ssname ss 0))
      (setq l (append l (list ssn)))
      (command (cdr (assoc 10 (entget ssn))))
     )
  )) 
  ((and (= 2 (car pnt)) (= (last pnt) 116)) (setq ctro (+ ctro tg)))
  ((and (= 2 (car pnt)) (= (last pnt) 103)) (setq ctro (- ctro tg)))
  ((and (= 2 (car pnt)) (= (last pnt) 117))
   (command "u")
   (setq l (vl-remove (last l) l)))
 
  ((or (and (= 2 (car pnt)) (or (= (last pnt) 13) (= (last pnt) 32))) (= 3 (car pnt)))
(setq done t))
    )
  )
  (command "") (redraw) (setvar 'osmode os)
  (princ)
)

<<

Filename: 310838_apl.lsp
Tác giả: hiepttr
Bài viết gốc: 310922
Tên lệnh: nhay
Chương 10.2 : Text Window, Redraw

Lại có cái để thắc mắc đây :D :D :D

 

Bài 4:

 

;;Bai 4:
;Thu tuc nhap nhay 1 nhom doi tuong, trong do: Nhom doi tuong, so lan nhap nhay, toc do nhap nhay (lan/s)
;do nguoi dung chi dinh. Cuoi cung hien thi so doi tuong trong nhom, so lan nhay, thoi gian toi thieu thuc hien
;Quay ve man hinh ve neu nguoi dung an enter
(defun c:NHAY( / ss n v)
(prompt "\nChon doi tuong !")
(setq ss (ssget))
(if ss 
	(progn
		(setq n (getint...
>>

Lại có cái để thắc mắc đây :D :D :D

 

Bài 4:

 

;;Bai 4:
;Thu tuc nhap nhay 1 nhom doi tuong, trong do: Nhom doi tuong, so lan nhap nhay, toc do nhap nhay (lan/s)
;do nguoi dung chi dinh. Cuoi cung hien thi so doi tuong trong nhom, so lan nhay, thoi gian toi thieu thuc hien
;Quay ve man hinh ve neu nguoi dung an enter
(defun c:NHAY( / ss n v)
(prompt "\nChon doi tuong !")
(setq ss (ssget))
(if ss 
	(progn
		(setq n (getint "\nSo lan nhay:")
			  v (getreal "\nToc do nhay <lan/giay>:")
			  v (fix (/ 500 v )))
		(repeat n
			(an ss)
			(command "delay" v)
			(hien ss)
			(command "delay" v)
		)
	)
) ;if
;(textscr)
)
;=======================================================================================
;********************************************
(defun an (ss / i)
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i))
	(redraw ename 2)
) 	;repeat
)
;==============***************==============
(defun hien (ss / i)
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i))
	(redraw ename 1)
) 	;repeat
)

Theo cách tư duy của mình là vậy

>>> copy từng đoạn trong code trên, dán vào command ==> OK

Nhưng, AP lisp >>> NHAY tại command >>>> Not OK ??? (nhóm đối tượng ko nháy như khi mình copy/paste từng đoạn vào command)

Khó hiểu quá :blink:


<<

Filename: 310922_nhay.lsp
Tác giả: beuchay
Bài viết gốc: 310935
Tên lệnh: xx
Giúp đỡ về cắt DIM

10635873_956840754332977_419614177573241

>>

10635873_956840754332977_419614177573241

Có ai biết lỗi này trong cad ko ạ?
E dùng lệnh cắt dim bị lỗi,lúc được lúc ko,nếu lỗi thì sẽ bỏ hết SNAP(bắt điểm) thành ra lại phải tích lại bắt điểm.
Nó thông báo như vầy,e đã đổi thử lisp cad mà k ăn thua.

E đã thử dùng qua lệnh FLATTEN mà vẫn không được,mong mọi người giúp đỡ e

E cảm ơn.

LISP đây ạ

 

(DEFUN C:XX (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI PT13I PT14I
                PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
      *error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
    (PROGN
	(SETQ DS (ENTGET (SSNAME SS DEM)))
	(SETQ KDL (CDR (ASSOC 0 DS)))
	(IF (= "DIMENSION" KDL)
	   (PROGN
		(SETQ PT10 (CDR (ASSOC 10 DS)))
		(SETQ PT11 (CDR (ASSOC 11 DS)))
		(SETQ PT13 (CDR (ASSOC 13 DS)))
		(SETQ PT14 (CDR (ASSOC 14 DS)))
		(SETQ N70 (CDR (ASSOC 70 DS)))
		(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
		   (PROGN
			(SETQ GOCY (ANGLE PT10 PT14))
			(SETQ GOCX (+ GOCY (/ PI 2)))
		   )
		)
		(SETVAR "OSMODE" 0)
		(SETQ PTI (POLAR PT GOCX 2))
		(SETQ PT13I (POLAR PT13 GOCY 2))
		(SETQ PT14I (POLAR PT14 GOCY 2))
		(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
		(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
		(SETQ O13 (ASSOC 13 DS))
		(SETQ O14 (ASSOC 14 DS))
		(SETQ N13 (CONS 13 PT13N))
		(SETQ N14 (CONS 14 PT14N))
		(SETQ DS (SUBST N13 O13 DS))
		(SETQ DS (SUBST N14 O14 DS))
		(ENTMOD DS)
	   )
	)
	(SETQ DEM (+ DEM 1))
    )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)               ; Restore old *error* handler
(PRINC)
)

 

                PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
      *error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
    (PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
  (PROGN
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
  (PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
  )
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT13I (POLAR PT13 GOCY 2))
(SETQ PT14I (POLAR PT14 GOCY 2))
(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
(SETQ O13 (ASSOC 13 DS))
(SETQ O14 (ASSOC 14 DS))
(SETQ N13 (CONS 13 PT13N))
(SETQ N14 (CONS 14 PT14N))
(SETQ DS (SUBST N13 O13 DS))
(SETQ DS (SUBST N14 O14 DS))
(ENTMOD DS)
  )
)
(SETQ DEM (+ DEM 1))
    )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)               ; Restore old *error* handler
(PRINC)
)
                PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
      *error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
    (PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
  (PROGN
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
  (PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
  )
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT13I (POLAR PT13 GOCY 2))
(SETQ PT14I (POLAR PT14 GOCY 2))
(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
(SETQ O13 (ASSOC 13 DS))
(SETQ O14 (ASSOC 14 DS))
(SETQ N13 (CONS 13 PT13N))
(SETQ N14 (CONS 14 PT14N))
(SETQ DS (SUBST N13 O13 DS))
(SETQ DS (SUBST N14 O14 DS))
(ENTMOD DS)
  )
)
(SETQ DEM (+ DEM 1))
    )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)               ; Restore old *error* handler
(PRINC)
)

<<

Filename: 310935_xx.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 311164
Tên lệnh: bh1 bh2
Lisp thống kê diện tích Hatch theo Layer

mình kèm file đây: http://www.cadviet.com/upfiles/3/37170_fhatch.dwg

File lisp này vẽ đường bao của Hatch ngon ơ. Từ các đường bao thì vi phân chúng sẽ được các list điểm.

(defun c:bh1( / sl n)
  (setq sl (acet-ss-to-list...
>>

mình kèm file đây: http://www.cadviet.com/upfiles/3/37170_fhatch.dwg

File lisp này vẽ đường bao của Hatch ngon ơ. Từ các đường bao thì vi phân chúng sẽ được các list điểm.

(defun c:bh1( / sl n)
  (setq sl (acet-ss-to-list (ssget '((0 . "HATCH")))))
  (foreach n sl
    (command "hatchedit" n "b" "p" "y")))
(defun c:bh2 ()
  (princ "\nCh\U+1ECDn c\U+00E1c Hatch c\U+1EA7n t\U+1EA1o l\U+1EA1i Boundary : ")
  ((lambda (ss / n e) 
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(command "-hatchedit" e "B" "P" "")))
(ssget (list (cons 0 "HATCH")))))
 


<<

Filename: 311164_bh1_bh2.lsp
Tác giả: kubin-181
Bài viết gốc: 306275
Tên lệnh: coorn
các bác giúp e sửa lisp xuất tọa độ này với ^^

Lisp này e cũng sưu tầm đc trên 4rum mình, xài rất tốt, e hay dùng để tạo file số liệu cắm mốc, nhưng e mún chỉnh sửa thêm 1 tí ^^.

- trong lisp có nhìu lệnh, nhưng e chỉ hay dùng lệnh đầu tiên là "coorn", với lệnh lệnh này e mún nhờ các bác chỉnh 1 tí giúp e là mình có thể tự set chiều cao text đánh số các đỉnh line và pline, sau đó tự động tạo thêm các điểm point dạng chữ thập...

>>

Lisp này e cũng sưu tầm đc trên 4rum mình, xài rất tốt, e hay dùng để tạo file số liệu cắm mốc, nhưng e mún chỉnh sửa thêm 1 tí ^^.

- trong lisp có nhìu lệnh, nhưng e chỉ hay dùng lệnh đầu tiên là "coorn", với lệnh lệnh này e mún nhờ các bác chỉnh 1 tí giúp e là mình có thể tự set chiều cao text đánh số các đỉnh line và pline, sau đó tự động tạo thêm các điểm point dạng chữ thập chéo màu đỏ có kích thước tương ứng với chiều cao text đã nhập tại các điểm đó, ngoài xuất file tọa độ ra excel or text e mún xuat them 1 bảng tọa độ đơn giản ra trong cad lun. để tiện đối chiếu 

-Mong được các bác nhiệt tình giúp đỡ

(defun c:COORN (/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus Npt)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
  (setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
  (if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Óêàçàòü Òî÷êà Áëîêè Ïîëèëèíèÿ Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nÂûáåðèòå ðåæèì  <"
(cadr (assoc ptcol:mode '(("Pick" "Óêàçàòü")("pOints" "Óêàçàòü")("Blocks" "Áëîêè")("poLyline" "Ïîëèëèíèÿ")))) ">: ")
        (strcat "\nSpecify mode  <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nÓêàæèòå òî÷êó èëè Enter çàâåðøåíèÿ > " "\nPick point or Enter to continue > ")))
  (if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nÂûáåðèòå òî÷êè è íàæìèòå Enter ")(princ "\nSelect points and press Enter "))
   (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nÂûáåðèòå áëîêè è íàæìèòå Enter ")(princ "\nSelect blocks and press Enter "))
     (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nÂûáåðèòå ïîëèëèíèè è íàæìèòå Enter  ")(princ "\nSelect polyline and press Enter "))
     (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")
(setq Npt (getint (if IsRus "\nÍà÷àëüíûé íîìåð òî÷êè <Íå ìàðêèðîâàòü> : " "\nStart number of points <Don't mark> : " )))
(initget "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nÑîõðàíèòü êîîðäèíàòû â  <Ôàéë> : "
"\nSave coordinates to  <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))(setq oFlag Npt)(if (numberp Npt)
(foreach ln ptlst
  (text-draw                 ;_Îòðèñîâêà òåêñòà
    (itoa Npt)               ;_Íîìåð òî÷êè
    (polar ln (/ pi 4) 1.)   ;_Êîîðäèíàòû íà 1 åä ïî óãëîì 45 ãðàäóñîâ
    (setvar "TEXTSIZE" 2)      ;_ Òåêóùåé âûñîòîé òåêñòà
    0                        ;_Óãîë ïîâîðîòà
    nil
    )
  (setq Npt (1+ Npt))))
(setq Npt oFlag)    
(setq ptLst (mapcar '(lambda(x)(mapcar 'rtos x)) ptlst))
(cond ((and (= "Text" sFlag)(setq filPath
       (getfiled (if IsRus "Ñîõðàíåíèå êîîðäèíàò â òåêñòîâûé ôàéë" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
       (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (if (numberp Npt)(strcat (itoa Npt) ",") "")(car ln)","(cadr ln)
         (if(= 3(length ln))(strcat ","(nth 2 ln)))) cFile)(if (numberp Npt)(setq Npt (1+ Npt))))(close cFile)(initget "Yes No")
       (setq oFlag(getkword (if IsRus "\nÎòêðûòü ôàéë?  <No> : " "\nOpen text file?  <No> : " )))
       (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
     ((= "Excel" sFlag)(if (numberp Npt)(progn
      (setq ptlst (mapcar '(lambda(x)(cons (1- (setq Npt (1+ Npt))) x)) ptlst))
      (xls ptlst '("N" "X" "Y" "Z") nil "COORN"))
      (xls ptLst nil nil "COOR"))); end condition #2
     (t nil)))) (princ)); end of c:COOR

<<

Filename: 306275_coorn.lsp
Tác giả: nhoclangbat
Bài viết gốc: 311345
Tên lệnh: kk
Chèn điểm lên đường thẳng.

phải ý bạn là mún break 1 điểm bất kỳ trên đường thẳng tạo ra 2 đường thẳng nối liền nhau ko ^^, dùng lệnh break cũng đc nhưng bị cái là nó bắt chọn 2 điểm nếu bạn ko pik chính xác 2 lần trên 1 điểm nó sẽ có khoảng hở , nhoc đang tập tành viết lsp, có cái lsp nhỏ cũng dùng break thui nhưng tránh cho bạn pick nhầm 2 điểm, bạn dùng thử ^^

(defun c:kk (/ old e1 pt1...
>>

phải ý bạn là mún break 1 điểm bất kỳ trên đường thẳng tạo ra 2 đường thẳng nối liền nhau ko ^^, dùng lệnh break cũng đc nhưng bị cái là nó bắt chọn 2 điểm nếu bạn ko pik chính xác 2 lần trên 1 điểm nó sẽ có khoảng hở , nhoc đang tập tành viết lsp, có cái lsp nhỏ cũng dùng break thui nhưng tránh cho bạn pick nhầm 2 điểm, bạn dùng thử ^^

(defun c:kk (/ old e1 pt1 pt2)
(setq old (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq e1 (entsel "\nChon doi tuong:"))
(setq pt1 (getpoint "\nchon diem ngat:"))
(setq pt2 pt1)
(command ".break" e1 "F"  pt1 pt2)
(princ)
(setvar "cmdecho" 1)
)

- chế độ bắt điểm do bạn quyết định nha ^^


<<

Filename: 311345_kk.lsp
Tác giả: hochoaivandot
Bài viết gốc: 311375
Tên lệnh: ttt
(Xin lisp) Sắp xếp text theo thứ tự ABC

Tôi thấy tò mò với yêu cầu nên viết cho bạn.

Nhưng bạn yêu cầu mà cố chấp không chịu gởi file lên để mọi người test thì thấy hình như bạn hơi bảo thủ.

Bởi vì bạn đang đi nhờ mọi người, và bạn không không biết viết lisp sẽ có rất nhiều tình huống mà người viết không nghĩ đến.

Việc đưa file cad lên sẽ giúp người được bạn nhờ rất nhiều.

Hi vọng...

>>

Tôi thấy tò mò với yêu cầu nên viết cho bạn.

Nhưng bạn yêu cầu mà cố chấp không chịu gởi file lên để mọi người test thì thấy hình như bạn hơi bảo thủ.

Bởi vì bạn đang đi nhờ mọi người, và bạn không không biết viết lisp sẽ có rất nhiều tình huống mà người viết không nghĩ đến.

Việc đưa file cad lên sẽ giúp người được bạn nhờ rất nhiều.

Hi vọng mình không làm phật lòng bạn... :D

 

(defun LM:ss->ent ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(defun dxf (e code) (cdr (assoc code (entget e))))
(defun SortLstFromLst ( a b c )
(defun f ( c d )
(apply (function mapcar)
(cons (function list)
(mapcar (function (lambda ( a ) (cdr (assoc a d)))) c)
)
)
)
(f c (apply (function mapcar) (cons (function list) (cons a B))))
)
(defun C:ttt()
(setq ss (ssget (list (cons 0 "TEXT"))))
(initget "C H")
(setq order (getkword (strcat "\nThu tu Cot/Hang")))
(if ss
(progn
(setq lst (LM:ss->ent ss))
(setq lst_cont (mapcar '(lambda (x) (dxf x 1))
lst
)
)
(setq sx (vl-sort lst_cont '<))
(setq lst_pt (mapcar '(lambda (x) (dxf x 10))
lst
))
(if (= order "C")
(setq lst_pt_sx (vl-sort lst_pt
(function (lambda (e1 e2)
(> (cadr e1) (cadr e2)) ) ) )
)
(setq lst_pt_sx (vl-sort lst_pt
(function (lambda (e1 e2)
(< (car e1) (car e2)) ) ) )
)
)
)
(princ "Khong chon duoc text")
)
(setq i 0)
(setq lst_e_sx (car(SortLstFromLst lst_pt (list lst) lst_pt_sx)))
(repeat (length lst)
(setq
e (nth i lst_e_sx)
eg (entget e)
old (assoc 1 eg)
nd (nth i sx)
i (1+ i)
eg (subst (cons 1 nd) old eg)
)
(entmod eg)
)
)


<<

Filename: 311375_ttt.lsp
Tác giả: thanhduan2407
Bài viết gốc: 311385
Tên lệnh: 00
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Em lại vào nhờ các bác tư vấn giúp em với ạ

Em có 1 Line dài và 1 tập hợp các Line ngắn nằm trên Line dài đó.

Mục đích của em là xoá các Line ngắn đó đi...

>>

Em lại vào nhờ các bác tư vấn giúp em với ạ

Em có 1 Line dài và 1 tập hợp các Line ngắn nằm trên Line dài đó.

Mục đích của em là xoá các Line ngắn đó đi mà chỉ để lại Line dài thôi.

Em đã viết Code thế này rồi nhưng có chỗ nào đó ko ổn, nó ko xoá hết mà chỉ xoá 1 số đối tượng thôi.

Mục đích của em để lọc giảm nhẹ bản vẽ em làm.

Mong các bác chỉ giáo giúp.

Đây là code ạ

(defun c:00 ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  )
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
(setq Lts_Line_OK (TD:Remove-Obj-duplicates Lts_Ename))
(princ)
)



(defun GetPnt (Ma x  /)
(acet-dxf Ma (entget x))
)



(defun GetLineDup (lst / lst1)
(foreach x lst
	(if (not (member x lst1))
		(setq lst1 (append lst1 (list x)))
	)
	(Progn
		(foreach y lst1
			(if (and (equal (angle (GetPnt 10 y) (GetPnt 10 x)) (angle (GetPnt 10 y) (GetPnt 11 y)) 0.0000001)
				 (equal (angle (GetPnt 10 y) (GetPnt 11 x)) (angle (GetPnt 10 y) (GetPnt 11 y)) 0.0000001)
			    )
			    (setq lst1 (vl-remove y lst1))
			)
		)
		(setq lst1 (append lst1 (list x)) )
	)
)
lst1
)


(defun LM:ListDifference ( l1 l2 )
  (vl-remove-if '(lambda ( x ) (member x l2)) l1)
)


(defun LM:RemoveOnce ( l1 l2 )
  (if l1
    (if (equal (car l1) l2)
      (LM:RemoveOnce (cdr l1) l2)
      (cons (car l1) (LM:RemoveOnce (cdr l1) l2))
    )
  )
)

(defun TD:Remove-Obj-duplicates (ss_list /  Lts1 Lts2 )
(vl-load-com)
(setq Lts1  (GetLineDup ss_list ))
(setq Lts2 (LM:ListDifference ss_list Lts1))
(setq Lts3 (LM:RemoveOnce Lts1 ss_list))
(foreach e Lts2
	(entdel e)
)
Lts3
)




http://www.cadviet.com/upfiles/3/36665_xoa_line_1.dwg


<<

Filename: 311385_00.lsp
Tác giả: Tue_NV
Bài viết gốc: 311401
Tên lệnh: 001
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)

(defun c:001 ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  )
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons...
>>

Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)

(defun c:001 ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  )
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (mapcar 'cdr (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2))))))
 
(setq i 0 j 1)
(while (< i (length Lts_KC_Ename_Sort))
  (while (< j (length Lts_KC_Ename_Sort))
    (if (entget (nth i Lts_KC_Ename_Sort))
      (if (entget (nth j Lts_KC_Ename_Sort))
            (if (Tue-geom-3pthanghang (GetPnt 10 (nth i Lts_KC_Ename_Sort)) (GetPnt 11 (nth i Lts_KC_Ename_Sort))
                           (GetPnt 10 (nth j Lts_KC_Ename_Sort)) (GetPnt 11 (nth j Lts_KC_Ename_Sort)))
                        (progn (entdel (nth j Lts_KC_Ename_Sort)) (vl-remove (nth j Lts_KC_Ename_Sort) Lts_KC_Ename_Sort))
            )
       )
      (setq j (length Lts_KC_Ename_Sort))
    )
            (setq j (1+ j))
   )
            (setq i (1+ i) j 1)
)
(princ)
)
(defun GetPnt (Ma x  /)
(acet-dxf Ma (entget x))
)
(defun Tue-geom-3pthanghang(p1 p2 p3 p4 / goc<pi)
  ;;;Ex: (Tue-geom-3pthanghang (getpoint "P1 :") (getpoint "P2 :") (getpoint "P3 :"))
  (defun goc<pi (pt1 pt2 / resgoc)
    (setq resgoc (angle pt1 pt2))
    (while (> resgoc pi) (setq resgoc (- resgoc pi)))
    resgoc
  )
  (if (and (equal (goc<pi p1 p2) (goc<pi p2 p3) 1E-10) (equal (goc<pi p1 p2) (goc<pi p2 p4) 1E-10))
            T nil
  )

<<

Filename: 311401_001.lsp

Trang 171/330

171