Liren Large Software Subsidy 13/13.iso/p/p086/3.img/ACADSUP.LIF/BLOCKIT.LSP

Lisp/Scheme | 1991-04-08 | 23.0 KB | 875 lines

;;;*********************************************************************
;;;   Blockit.lsp 1.01
;;;   Copyright (C) 1990 by Autodesk, Inc.
;;;
;;;   Block animation command for use with AutoCAD Release 10
;;;
;;;   Permission to use, copy, modify, and distribute this software and its
;;;   documentation for any purpose and without fee is hereby granted.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;   Designed and implemented by Jamie Clay in June of 1990
;;;   Reformatted file for compliance with coding standards.
;;;     JSY -- Sept. 1990
;;;
;;;   Note: Requires the presence of PTOOLS.LSP
;;;
;;;*********************************************************************
;;; NUMBERS
;;; f# - total number of frames
;;; s# - block motion start number
;;; r# - block motion steps
;;; c# - count number for block list
;;; m# - stored value for frame starting number
;;; strt# - start number for filmrolls
;;; count - animation process counter
;;; ent_sel -  index counter for anim_set
;;; ent_sel# - number of lists in anim_set
;;;
;;; STRINGS
;;; flm -  updated name for filmrolls
;;; kflm - saved name for filmrolls
;;; kname - user entered filmroll name
;;; pline - response string for path prompt
;;; scale - Block scale prompt response
;;;
;;; LISTS
;;; anim_set - master animation list
;;; items - blocks for insertion
;;; camlst - path points
;;; rot - block rotation information
;;; xs - block x scale information
;;; ys - block y scale information
;;; zs - block z scale information
;;;
;;; MISC
;;; flatland - flatland value when routine is started
;;; osmode - object snap value when routine is started
;;; blipmode - blip setting value when routine is started
;;; *olderror* - stored *error* function
;;; steps - while switch
;;; ans - switch for *close* function
;;; select - switch for animation setup while loop

(prompt "\nLoading...")
(vmon)
(defun c:blockit (/ outfile rot xs ys zs f# s# r# select flm kflm kname optp
                    items count appfile camlst camlst2 c# pline pline2 sshade
                    ans anim_set ucsfollow items steps seepath hide rem)

  ;; This function has been broken into three parts to allow it to run in
  ;; very tight memory situations.  The three functions are listed below.

  (b-it1)                             ; Set up, get name and frames.
  (b-it2)                             ; Start the selection while loop.
  (b-it3)                             ; Output and cleanup before exiting.

  (princ)
)

;;; Blockit part 1 of the defun c:blockit
;;; All variables are defined in c:blockit.

(defun b-it1 ()
  (if (= oset "Test")(setq oset nil))

  ;;Set up the system variables

  (setvar "cmdecho" 0)
  (command "undo" "group")
  (setq rf#        0
        attreq     (getvar "attreq")
        flatland   (getvar "flatland")
        ucsfollow  (getvar "ucsfollow")
        osmode     (getvar "osmode")
        blipmode   (getvar "blipmode")
        ent_sel    -1
        remove     (ssadd)
        *olderror* *error*
        *error*    *close*
  )
  (setvar "attreq" 0)
  (setvar "flatland" 0)
  (setvar "osmode" 0)
  (setvar "blipmode" 0)
  (setvar "highlight" 1)
  (setvar "ucsfollow" 0)
  (command "ucs" "world")

  (getdir)                            ; Find directory information


  ;;Get the file name

  (if (not dwg_name)
    (setq kflm (substr (justname (getvar "dwgname")) 1 4))
    (setq kflm (substr dwg_name 1 4))
  )

  (while (not kname)
    (setq kname (getname (strcat "\nFilmroll title <" kflm ">: ")))
    (if (not kname) (prompt "\nInvalid file name, please re-enter."))
  )

  (if (= kname "")
    (setq kname (justname (getvar "dwgname")))
    (setq kflm (substr kname 1 4))
  )

  (while (not f#)
    (initget 7)
    (setq f# (getint "\nNumber of frames: "))
    (if (< f# 3)
      (progn
        (setq f# nil)
        (prompt "\nPlease use a larger number.")
      )
    )
  )


  (if (or (not deed) (= deed "TEST")) (setq m# 1))
  (if (not m#) (setq m# 1))
  (initget 6)
  (setq strt# (getint (strcat "\nStarting number <"
                               (cname "" m#) ">: "))
  )
  (if strt# (setq m# strt#))
)

;;; Blockit part 2 of the defun c:blockit
;;; All variables are defined in c:blockit.

(defun b-it2 ()
  (setq select T)                     ; start the selection while loop
  (while select
    (setq items (blk_get))
    (if items
      (progn

        ;; get the entity motion information
        ;; if this is a 3 frame animation, skip this part.
        (if (/= f# 3)
          (motion_steps)
          (setq s# 1 c# 0)
        )                             ; end of if \= 3 f#

        ;; while (not pline)
        (b-it2a)
        ;; selection conditional and camlist setting
        (b-it2b)
        ;; Get path option, scale, and align options.
        (b-it2c)
        ;; Get block rotation and set the animation set.
        (b-it2d)


        (setq camlst  nil
              camlst2 nil
                  s#  nil
               items  nil
                 rot  nil
               select T
        )
      )                               ; end of the 'if items true progn'
      (progn
        (if (< (length anim_set) 1)
          (setq anim_set nil)
          (progn
            (initget "Yes No")
            (setq select (getkword
                "\nAre you finished with the selection process? <Y>: ")
            )
            (if (or (not select) (= select "Yes"))
              (setq select nil)
            )
          )
        )
      )
    )                                 ; end of if items
  )
)

;;; Blockit part 2, subpart a
;;; All variables are defined in c:blockit.

(defun b-it2a ()
  (while (not pline)
    (initget "Fixed Path List")
    (setq pline (getkword "\nBlock motion Path/Fixed/List <Path>: "))
    (if (= pline "Path") (setq pline nil))

    ; Get block insertion point
    (cond
      ((= pline "Fixed")
        (setq camlst (list (getpoint
          "\nBlock, fixed position>> Pick a point: "))
        )
      )
      ((= pline "List")
        (while (not camlst)
          (setq pathfile (getstring "\nBlock, point list>> File to use: ")
                camlst (ptsread pathfile)
          )
          (if (and (< txtpt# r#) camlst)
            (progn
              (prompt "\nInsufficient number of points.")
              (prompt "\nSorry, can not use this file.")
              (setq camlst nil)
            )
          )
        )
      )
      ((not pline)
        (while (not pline)
          (setq pline (entsel"\nBlock motion path>> Select a polyline: ")
                pline (polytest pline)
          )
        )
        (setq remove (ssadd (car pline) remove))
        (redraw (car pline) 3)
        (if r#
          (setq camlst (gather pline  r#))
          (setq camlst (gather pline f#))
        )
      )
      ;; If the block is fixed it will pass through this cond
    )
  )
)

;;; Blockit part 2, subpart b
;;; All variables are defined in c:blockit.

(defun b-it2b ()
  (initget "Path List")
  (if (/= pline "Fixed")
    (setq optp (getkword "\nOptional Path - Path/List <none>: "))
  )
  (cond
    ((= optp "Path")
       (while (not pline2)
         (setq pline2 (entsel "\nOptional path>> Select a polyline: "))
         (setq pline2 (polytest pline2))
         (if (eq (car pline) (car pline2))
           (progn
             (setq pline2 nil)
             (prompt "\nSorry, you can not use the motion path. Try again."
             )
           )
         )
       )
       (redraw (car pline2) 3)
       (setq remove (ssadd (car pline2) remove))
    )
    ((= optp "List")
      (while (not optfile)
        (setq optfile (getstring "\nOptional, point list>> File to use: ")
             camlst2 (ptsread optfile)
        )
        (if (not camlst2)
          (set optfile nil)
          (cond
            ((= optfile pathfile)
               (prompt
                 "\nSorry, you can't use the same file used for Camera path.")
               (setq optfile nil)
            )
            ((< txtpt# r#)
               (prompt "\nInsufficient number of points.")
               (prompt "\nSorry, you can not use this file.")
               (setq optfile nil)
            )
            ((equal camlst2 camlst)
               (prompt "\nBoth lists are identical.")
               (prompt "\nSorry, you can not use this file.")
               (setq optfile nil)
            )
          )
        )
      )
    )
    ;; If there isn't an optional path, nothing here will happen
  )
  (if pline2
    (if r#
      (setq camlst2 (gather pline2 r#))
      (setq camlst2 (gather pline2 f#))
    )
  )
)

;;; Blockit part 2, subpart c
;;; All variables are defined in c:blockit.

(defun b-it2c ()
  ;;get scale information
  (setq xs nil
        ys nil
        zs nil
      xstr "[X] 1.0,1.0,S "
      ystr "[Y] 1.0,1.0,S "
      zstr "[Z] 1.0,1.0,S "
  )
  (while (/= scale "")
    (princ (strcat "\nScale settings: " xstr ystr zstr))
    (setq scale (getstring "\nScale >> X/Y/Z: ")
          scale (strcase scale)
    )
    (cond
      ((= scale "X") (setq xstr (doSTR  "X")))
      ((= scale "Y") (setq ystr (doSTR  "Y")))
      ((= scale "Z") (setq zstr (doSTR  "Z")))
    )
  )

  ;;Align block prompt
  (if (/= pline "Fixed")
    (progn
      (initget "Yes No")
      (setq rot (getkword "\nAlign block with path? <Y> "))
      (if (= rot "No")
        (setq rot nil)
        (setq rot "Yes")
      )
    )
  )
)

;;; Blockit part 2, subpart d
;;; All variables are defined in c:blockit.

(defun b-it2d ()
  ;;Block rotation?
  (if (/= rot "Yes")
    (setq rot (getreal "\nBlock rotation <none>: "))
  )

  (if (and rot (/= (type rot) 'STR))
    (progn
      (setq rst (getreal "\nStarting angle <0>: "))
      (if r#
        (setq rot (/ rot (1- r#)))
        (setq rot (/ rot (1- f#))
               r# f#
        )
      )
      (if (not rst)
        (setq rst 0)
      )
      (setq rot (list rot rst))
    )
    (if (not r#) (setq r# f#))
  )

  (setq scale  nil
        pline  nil
        pline2 nil
        ent_sel (1+ ent_sel)
        ent_sel# (1+ ent_sel)
        count 0
  )

  (if anim_set
    (setq anim_set (append anim_set (list
            (list items xs ys zs rot camlst camlst2 s# c# r# nil)))
    )
    (setq anim_set (list
             (list items xs ys zs rot camlst camlst2 s# c# r# nil))
    )
  )
)

;;; Blockit part 3 of the defun c:blockit
;;; All variables are defined in c:blockit.

(defun b-it3 ()
  (setq testf# f#
        testm# m#
  )

  (output) ; find output format

  (if (= deed "TEST")  ;; If we want to test, test away!
    (progn
      (setq hold_set anim_set
            testmode T
      )
      (while testmode
        (b_action)
        (princ "\n*press any key to reset animation*")
        (while (/= (nth 0 (grread)) 2)) ;pause for keybard input
        (setq del_ent (1- ent_sel#))
        (repeat ent_sel#
          (entdel (nth 10 (nth del_ent anim_set)))
          (setq del_ent (1- del_ent))
        )
        (output)
        (if (/= deed "TEST")
          (setq testmode nil)
        )
        ;; Restore the values needed for animation
        (setq count 0
              f# testf#
              m# testm#
              anim_set hold_set
        )
      )
    )
  )

  (command "undo" "group")

  ;; This is where we remove paths for slide animations
  (if rem
    (command "erase" remove "")
  )

  (if deed      ;; this is where we process the animation
    (b_action)
  )


  ;; All done, shut her down

  (if outfile
    (progn
      (close outfile)
      (princ (strcat "\nAnimation list "(strcase fdir) (strcase fname)))
      (if appfile
         (princ " updated.")
         (princ " created.")
       )
      (setq outfile nil)
    )
  )
  (if rem
    (progn
      (setq repo 0)
      (repeat (sslength remove)
        (entdel (ssname remove repo))
        (setq repo (1+ repo))
      )
    )
  )
  (command "ucsicon" "all" "on")
  (command "undo" "end")
  (setvar "attreq" attreq)
  (setvar "cmdecho" 1)
  (setvar "highlight" 1)
  (setvar "ucsfollow" ucsfollow)
  (setvar "blipmode" blipmode)
  (setq *error* *olderror*)
)

;;; Supporting defuns

;;; B_ACTION

(defun b_action ()

  (command "ucsicon" "all" "off")
  (setvar "highlight" 0)

  ;; Process the animation

  (repeat f#
    (repeat ent_sel#
      (blk_action (nth ent_sel anim_set))
      (setq ent_sel (1- ent_sel))
    )
    (setq flm (cname kflm m#))

    (if seepath (view seepath))

    ;; hide or shade the image as requested
    (if hide
      (command "hide")
      (if sshade
        (command "shade")
      )
    )

    (if (or (= deed "MSLIDE") (= deed "SAVE"))
      (supfile flm kname)
    )
    ; test mode switch
    (if (= deed "TEST")
      (princ (strcat "\nTest mode >> " flm ))
      (progn
        (princ (strcat "\nMaking " fdir flm sfx))
        ; see if a drawing with the same name exists
        (if (and (findfile (strcat fdir flm ".dwg"))(= deed "SAVE"))
          (command deed (strcat fdir flm) "Y")
          (command deed  (strcat fdir flm))
        )
      )
    )

    (setq m# (1+ m#)
          ent_sel (1- ent_sel#)
          count (1+ count)
    )
  )
)

;;;  BLK_ACTION - The block party machine

(defun blk_action (blkset /  doit rot xale yale zale doit)
  (setq blks (nth 0 blkset)           ; block list
        xale (nth 1 blkset)           ; X block scale info
        yale (nth 2 blkset)           ; Y block scale info
        zale (nth 3 blkset)           ; Z block scale info
        rot  (nth 4 blkset)           ; Block rotation amount
        camlst (nth 5 blkset)         ; Point list
        camlst2 (nth 6 blkset)        ; secondary point list
        st# (nth 7 blkset)            ; motion start
        count2 (nth 8 blkset)         ; motion steps count
        stps (nth 9 blkset)           ; motion steps
        lins (nth 10 blkset)          ; last insertion
   )

  ;; Timer
  (if (<= (1+ count) st#)
    (setq doit nil)
    (setq doit T)
  )
  (if (and (/= stps f#) (= count2 stps)) (setq doit nil))
  (if (= (1+ count) 1) (setq doit T))

  ;; If ok, do the deed
  (if doit
    (progn

      ;; Erase previous insertion
      (if lins (entdel lins))

      ;; Get block name
      (if (= (length blks) 1)
        (setq blk (nth 0 blks))
        (progn
          (setq bcount (nth 0 blks))
          (setq bcount (1+ bcount))
          (setq blk (nth bcount blks))
          (if (= (1+ bcount) (length blks))
            (setq bcount 0)
          )
          (setq blks (subst bcount (nth 0 blks) blks))
        )
      )

      ;; Get insertion point
      (if (= (length camlst) 1)
        (setq pt1 (nth 0 camlst))
        (setq pt1 (nth count2 camlst))
      )

      ;; Get X scale factor
      (if xale
        (if (= (length xale) 1)
          (setq x (nth 0 xale))
          (setq x (scaleit xale)
                xale scale
          )
        )
        (setq x 1)
      )
      (if (< (abs x) 1e-10)        ; Zero scale value "filter"
        (setq x 0.0000001)
      )

      ;; Get Y scale factor
      (if yale
        (if (= (length yale) 1)
          (setq y (nth 0 yale))
          (setq y (scaleit yale)
                yale scale
          )
        )
        (setq y 1)
      )
      (if (< (abs y) 1e-10)        ; Zero scale value "filter"
        (setq y 0.0000001)
      )

      ;; Get Z scale factor
      (if zale
        (if (= (length zale) 1)
          (setq z (nth 0 zale))
          (setq z (scaleit zale)
                zale scale
          )
        )
        (setq z 1)
      )
      (if (< (abs z) 1e-10)        ; Zero scale value "filter"
        (setq z 0.0000001)
      )

      ;; Get Rotation amount
      (if rot
        (if (= rot "Yes")
          (if (not camlst2)
            (progn
              ;Get path follow points (3 point UCS info)
              (if (not (setq pt2 (nth (1+ count2) camlst)))
                ; Get X point
                (setq pt2 (polar pt1
                          (angle (nth (1- count2) camlst) pt1) 1)
                )         ; Get X if we're at the end
              )
              (setq pt3 (polar pt1
                        (+ (angle pt1 pt2) 1.578) 1)
              )         ; Create Y point
              (command "ucs" "3" pt1 pt2 pt3 ) ; change the UCS
            )
          )
          (setq r (nth 1 rot)                  ; Read rotation amount
                r2 (+ (nth 0 rot) (nth 1 rot)) ; update the rotation
                rot (list (nth 0 rot) r2)      ; store for next use
          )
        )
        (setq r 0)      ; if nothing specified, go to 0 rotation
      )

      (if camlst2
        (progn
          (setq pt3 (nth count2 camlst2))
          (if (not (setq pt2 (nth (1+ count2) camlst)))
            (setq pt2 (polar pt1 (angle (nth (1- count2) camlst) pt1) 1))
          )
          (if (= rot "Yes")
            (command "ucs" "3" pt1 pt2 pt3 )
            (command "ucs" "3" pt1 (polar pt1 0 1) pt3)
          )
        )
      )

      ;; Do that block magic
      (if (= rot "Yes")
        (command "insert" blk "0,0" "XYZ" x y z "0" "ucs" "")
        (if camlst2
          (command "insert" blk "0,0" "XYZ" x y z r "ucs" "")
          (command "insert" blk pt1 "XYZ" x y z r)
        )
      )


      ;; Update the list info
      (setq anim_set (subst
          (list blks xale yale zale rot camlst camlst2 st# (1+ count2)
           stps (entlast)) blkset anim_set)
      )
    )
  )
)

;;; SCALEIT - Making that block work for scale

(defun scaleit (slist)
  (setq switch (nth 0 slist)          ; switch
        rate   (nth 1 slist)          ; change rate
        lrate  (nth 2 slist)          ; last change
  )
  (if (= count2 0)
    (setq sr lrate)
    (if (= switch 0)                  ; if sequential do this
      (setq sr (+ lrate rate))
      (if (= (gcd stps 2) 1)          ; if this stps is an odd number do this
        (if (>= (/ stps 2) count2)
          (setq sr (+ lrate rate))
          (setq sr (- lrate rate))
        )
        ;; if it's an even number do this
        (if (>= (1- (/ stps 2)) count2)
          (setq sr (+ lrate rate))
          ;; if it's an even number hold it for a frame
          (if (and (= (gcd stps 2) 2) (= count2 (1+ (/ stps 2))))
            (setq sr lrate)
            (setq sr (- lrate rate))
          )
        )
      )
    )
  )
  (setq scale (list switch rate sr))
  (setq sr sr)
)


;;; BLK_GET - Function for building block name list.

(defun blk_get (/ blknames blkname)
  (setq name_get T)
  (while name_get
    ;; ask for a file to process
    (prompt"\n\n[Block Name Setup]")
    (setq bltfile (getstring
                    "\nBlock list file (press RETURN to enter names): ")
    )
    (if (= bltfile "") (setq bltfile nil))
    (if bltfile                       ; If you get a list.
      (progn
        (setq blklist (open bltfile "r"))
        (if (not blklist)
          (setq blklist (open (strcat fdir bltfile) "r"))
        )
        (if (not blklist)
          (setq blklist (open (strcat fdir bltfile ".blt") "r"))
        )
      )
      (while name_get
        (prompt "\n*press RETURN when finished*")
        (setq blkname (getstring "\nBlock>> name: "))
        (if (= blkname "")
          (setq name_get nil)
          (progn
            (setq blktest (chkblock blkname))
            (if blktest
              (progn
                (setq blkname blktest)
                (if blknames
                  (setq blknames (append blknames (list blkname)))
                  (setq blknames (list blkname))
                )
              )
             (prompt (strcat "\nBlock "(strcase blkname)" not found."))
            )
          )
        )
      )
    )                                 ; end of while name_get

    (if (/= blkname "")
      (if bltfile
        (while (setq blkname (read-line blklist))
          (if (/= (substr blkname 1 1) "*")
            (progn
              (setq blktest (chkblock blkname))
              (if blktest
                (progn
                  (setq blkname blktest)
                  (if blknames
                    (setq blknames (append blknames (list blkname)))
                    (setq blknames (list blkname))
                  )
                )
                (progn
                 (prompt (strcat "\n"(strcase blkname)" block not found."))
                 (setq blknames nil)
                )
              )
            )
          )
        )
        (if (not blknames) (prompt "\nError: File not found"))
      )
    )                                 ; end of if blkname ""

    (if blknames
      (progn
        (setq name_get nil)
        (if (> (length blknames) 1)
          (setq blknames (append (list 0) blknames))
        )
      )
    )                                 ; end of if blknames

  )                                   ; end of the name_get while
  (setq blknames blknames)
)

;;; GETSCALE - Routine for getting block scale.

(defun getscale (x)
  (setq str 0 end 0 sctype nil)
  (while (= str 0)
    (initget 6)
    (setq str (getreal (strcat "\nScale>> Block " x " start <1>: ")))
    (if (not str) (setq str 1 ))
  )
  (while (= end 0)
    (initget 6)
    (setq end (getreal (strcat "\nScale>> Block " x "  end  <1>: ")))
    (if (not end) (setq end 1))
  )
  (if (/= str end)
    (progn
      (initget "S s P p")
      (setq sctype (getkword
                     "\nScale>> Sequential or Palendromic <S>: ")
      )
      (if (or (not sctype) (= sctype "S"))
        (setq sctype 0)
        (setq sctype 1)
      )
    )
  )

  ;; set the divide rate bases on the number of frames this block will move
  (if r#
    (setq sdiv  r# )
    (setq sdiv  f# )
  )

  ;; Set the scale rate based on Sequential or Palendromic order
  (if (= sctype 0)
    (setq rate (/ (- end str) sdiv))
    (setq rate (/ (- end str) (/ sdiv 2)))
  )

  ;; this is for the case when both scale values are the same.
  (if (not sctype) (setq sctype 0))

  (cond
    ((and (= str end) (/= str 1)) (list end)) ; if they are the same
    ((and (= str end) (= str 1)) nil)         ; if they are both one
    (T (list sctype rate str))                ; if they are different
  )
)

;;; BLOCK CHECK - Look to see if there is such a file.
(defun chkblock (x)
  (if (not (tblsearch "BLOCK" x))
    (if (not (findfile (strcat x ".dwg")))
      (if (findfile (strcat fdir x ".dwg"))
        (setq x (strcat fdir x))
        (setq x nil)
      )
    )
  )
  (setq x x)
)

;;;(doSTR) - function used to set scale values

(defun doSTR (sc1 / sstr)
  (setq scvar (read (strcat sc1 "S")) ; set scale var name
        scval (getscale sc1)          ; get scale info
  )
  (set scvar scval) ; set the value to the var
  (if scval                           ; change scale string
    (setq scstr (strcat "[" sc1 "] "(rtos str 2 2) ","
                         (rtos end 2 2) ","
                         (if (= sctype 0)
                           (setq sstr "S ")
                           (setq sstr "P ")
                          ))
    )
    (setq scstr (strcat "[" sc1 "] 1.0,1.0,S "))
  )
)

;;; Load support functions
(setq loaded T)
(if (not gather) (load "ptools"))

;;; End of the load.

(princ "\C:BLOCKIT v1.01- Loaded!")
(princ)