Average Lisp Function

I was wondering if any of you could help me.

I have upgraded my AutoCAD 2002 to 2004, I was given a lisp routine for a
snap to return the average point from any number of given points. (I got it
of an Andrew Bichard when he wrote for Cad Desk magazine)

The thing is, it doesn't work with AutoCAD 2004 at all.

I was wondering if anyone here had either got it to work, or found something
else that does the job as I used it all the time.

Andrew Bichard has not upgraded his ver yet, so has not looked at it.

 

Damn.

Just thought..........

Perhaps Mr. Bichard wouldn't want his name plastered over Usenet.

Damn.

Apologies

 

Try this:

(defun c:avpoint (/ p0 plist x xsum ysum zsum)
(while (setq p0 (getpoint "\nPoint: "))
(setq plist (cons p0 plist))
)
(setq xsum 0
ysum 0
zsum 0
np (length plist)
)
(foreach x plist
(progn
(setq xsum (+ xsum (car x)))
(setq ysum (+ ysum (cadr x)))
(setq zsum (+ zsum (caddr x)))
)
)
(setq avp (list (/ xsum np) (/ ysum np) (/ zsum np)))
)



HTH
Juergen

 

Thanks a lot Juergen, unfortunately I have not made myself clear enough
though. (Totally my fault)

I have found the old lisp file, and the txt file that explains it.

So here goes,


Average.lsp =

(IF (NOT (AND modes moder preset reset dxf warn))
(if (findfile "subrout1.lsp")
(LOAD "subrout1.lsp")
(LOAD (GETFILED "Subrout1.lsp not on path, Locate manually"
"subrout1.lsp"
"lsp"
2
)
"Subrout1.lsp not found"
)
)
)
(princ "\nLoading AVERAGE.lsp... 2.01")

;defun


(defun average ( / pt-a pt-b pt-c count size old_error MODE-V)
(preset)
(modes
'("CMDECHO" "MENUECHO" "OSMODE")
);modes
(if debug (setvar "CMDECHO" 1)(setvar "CMDECHO" 0))
(if debug (setvar "MENUECHO" 0)(setvar "MENUECHO" 1))
(setvar "OSMODE" 33)
(setq size (/ (getvar "VIEWSIZE") 16))
(redraw)
(initget 1)
(setq pt-a (getpoint (strcat "\nShow first point to average [End,Int] :
"))
count 1)
(setq pt-b (mapcar '(lambda (x) (/ x count)) pt-a)
pt-c (trans pt-b 1 2))
(setvar "LASTPOINT" pt-b)
(if (type grvecs)
(grvecs (list 1 (trans '(-0.5 0 0) 0 2) (trans '(1 0 0) 0 2)
2 (trans '(0 -0.5 0) 0 2) (trans '(0 1 0) 0 2)
3 (trans '(0 0 -0.5) 0 2) (trans '(0 0 1) 0 2))
(list (list (eval size) 0.0 0.0 (nth 0 pt-c))
(list 0.0 (eval size) 0.0 (nth 1 pt-c))
(list 0.0 0.0 (eval size) (nth 2 pt-c))
(list 0.0 0.0 0.0 1.0))
)
(progn
(grdraw (polar pt-b (* pi 0.25) size)
(polar pt-b (* pi 1.25) size)
-1 1
)
(grdraw (polar pt-b (* pi 0.75) size)
(polar pt-b (* pi 1.75) size)
-1 1
)
);progn
);if
(prompt "\n1 point so far, ")
(while
(setq pt-b
(getpoint " Select another, or RETURN to end [End,Int] : ")
);setq
(setvar "LASTPOINT" pt-b)
(setq pt-a (mapcar '+ pt-a pt-b)
count (1+ count))
(redraw)
(setq pt-b (mapcar '(lambda (x) (/ x count)) pt-a)
pt-c (trans pt-b 1 2))
(if (type grvecs)
(grvecs (list 1 (trans '(-0.5 0 0) 0 2) (trans '(1 0 0) 0 2)
2 (trans '(0 -0.5 0) 0 2) (trans '(0 1 0) 0 2)
3 (trans '(0 0 -0.5) 0 2) (trans '(0 0 1) 0 2))
(list (list (eval size) 0.0 0.0 (nth 0 pt-c))
(list 0.0 (eval size) 0.0 (nth 1 pt-c))
(list 0.0 0.0 (eval size) (nth 2 pt-c))
(list 0.0 0.0 0.0 1.0))
)
(progn
(grdraw (polar pt-b (* pi 0.25) size)
(polar pt-b (* pi 1.25) size)
-1 1
)
(grdraw (polar pt-b (* pi 0.75) size)
(polar pt-b (* pi 1.75) size)
-1 1
)
);progn
);if
(prompt
(strcat
"\n"
(itoa count)
" points so far, "
);strcat
);prompt
);while
(redraw)
(reset)
(IF (> (BOOLE 1 (GETVAR "cmdactive") 3) 0)
(command "_none")
)
(setvar "LASTPOINT" (mapcar '(lambda (x) (/ x count)) pt-a))
);defun
(prompt "\nCopyright Andrew Bichard 1997")
(princ)
;;2.01 14 December 1997 revision number first added to routine
;; "_none" disabled when no command active

And the Average.txt file =

From AUG UK Newsletter November 1995

LISP Corner

Average is an additional AutoCAD snap mode. It prompts for a
series of points, and then returns a single point, averaged from
those entered. Select two points, and the mid point is returned.
Select one end of a line twice and the other once. A point one
third along is returned. Any point that can beexpressed as a
ratio can be found this way, even say, eleven thirteenths. In
addition you could select the corners of a triangle or rectangle
to find the centre of gravity.

Average.lsp

1 (defun average ( / total new-pt count)
2 (setq total (getpoint "\nShow first point to average: ")
3 count 1)
4 (prompt "\n1 point so far,")
5 (while
6 (setq new-pt (getpoint " select another, or RETURN to end: "))
7 (prompt
8 (strcat "\n" (itoa count) " points so far," )
9 )
10 (setq total (mapcar '+ total new-pt)
11 count (1+ count))
12 )
13 (mapcar '(lambda (x) (/ x count)) total)
14 )

Menu call
[Average](if (not average)(load "average"))(average)

The routine loops around the 'while' loop (lines 5 to 12) as long
as valid points are entered in response to the 'getpoint'
function. Each time around the loop, the X,Y and Z coordinates of
the entered point are added to the existing total by the 'mapcar
function on line 10, and the point count is incremented. When an
invalid point is entered (a carriage return), the routine breaks
out of the loop to line 13. This program line divides the total
X, Y and Z coordinates by the number of points entered, and
echoes the result to the calling AutoCAD command as a point.
Note how in line 1, total, new-pt and count are declared as local
variables so that they cannot interfere with any other loaded
routines.

The menu call checks first to see if 'average' is defined,
loading it if necessary. The routine is then called and runs.
Average.lsp can be placed in your support subdirectory and called
as shown by an additional line in your POP0 menu section.
Unfortunately, due to restriction in AutoCAD, it cannot be used
in response to another LISP routine.


Andrew Bichard
(changed by me to stop spam)

Copyright Andrew Bichard 1996
................
I hope this explains my problem better, I can't get this to work in AutoCAD
2004, (it was fine in R14 & A2K.

 

Are you able to post "Subrout1.lsp" to go with that? It'd be great if you could, thanks.

 

message Are you able to post "Subrout1.lsp" to go with that? It'd be great if you
could, thanks.

Subrout1.lsp =


(PRINC ".")

;|===========================================================
(MODES (A1)) MODE Store
Stores modes for use by (MODER (A1) with variable name MODE-V
as in (MODES '("BLIPMODE" "HIGHLIGHT"))
used in (preset)
add MODE-V to local variables
DO NOT USE FOR READ ONLY VARIABLES OR MODER WILL CRASH
==============================================================|;

(DEFUN modes (a1)
(IF (NOT mode-v)
(SETQ mode-v '())
)
(REPEAT (LENGTH a1)
(SETQ mode-v (APPEND mode-v (LIST (LIST (CAR a1) (GETVAR (CAR a1)))))
a1 (CDR a1)
)
)
)

(PRINC ".")

;|============================================================
(MODER) MODE Restore
Used in (reset) to reset variables set by (MODES (A1))
==============================================================|;

(DEFUN moder ()
(REPEAT (LENGTH mode-v)
(IF (CADAR mode-v)
(SETVAR (CAAR mode-v) (CADAR mode-v))
) ;_ if
(SETQ mode-v (CDR mode-v))
) ;_ repeat
) ;_ DEFUN
(PRINC ".")

;|======================================================
(PRESET) and (RESET)
RECORDS CURRENT SYSTEM VARIABLES and RESTORES
If debug set T, all routines enter debug mode with full echo
to screen If debug set nil, functions work normally
old_error to local variables in calling routine
==========================================================|;


(DEFUN preset ()
(IF (= (BOOLE 1 (GETVAR "cmdactive") 3) 0)
(COMMAND "_.undo" "_mark")
)
(IF debug
(SETQ *error* nil)
(PROGN
(SETQ old_error *error*)
(DEFUN *error* (s)
(moder)
(IF (OR (= s "Function cancelled")
(= (STRCASE (SUBSTR s 1 4)) "QUIT")
)
(PRINC)
(PRINC (STRCAT "\nError: " s))
)
(IF old_error
(SETQ *error* old_error)
)
(REDRAW)
(PRINC)
)
)
)
)

(PRINC ".")

(DEFUN reset ()
(moder)
(IF old_error
(SETQ *error* old_error)
) ;_ if
(IF debug
(TEXTSCR)
)
(PRINC)
) ;defun

(PRINC ".")

;****************************************************************
;* (dxf (code elist))
;* returns dxf code traditional version
;****************************************************************

(DEFUN dxf (code elist)
(CDR (ASSOC code elist))
)


(PRINC ".")
;****************************************************************
;* (dxf (code elist))
;* returns dxf code enhanced version
;****************************************************************

;|
;;;Useful function, Not currently used
;;;this was the definition of dxf that I used until recently.
;;;see read.me
;;; returns the first group value of an entity.
;;; like the wellknown (dxf) function but accepts all kinds of
;;; entity representations (ename, entget list, entsel list)
;;; NOTE: For getting 10 groups in LWPOLYLINE's not usable!
(defun GETVAL (code ele) ;"dxf value" of any ent...
(cond ((= (type ele) 'ENAME) ;ENAME
(cdr (assoc code (entget ele))))
((not ele) nil) ;empty value
((not (listp ele)) nil) ;invalid ele
((= (type (car ele)) 'ENAME) ;entsel-list
(cdr (assoc code (entget (car ele)))))
(T (cdr (assoc code ele))))) ;entget-list

|;




(PRINC ".")
;****************************************************************
;* (round (num sig))
;* rounds of num to sig figures
;****************************************************************

(DEFUN round (num sig) (ATOF (RTOS num 1 (1- sig))))


(PRINC ".")
;****************************************************************
;* (dtr (a))
;* converts degrees to radians
;****************************************************************

(DEFUN dtr (a) (* PI (/ a 180.0)))


(PRINC ".")

;****************************************************************
;* (not0 (lst))
;* used with dxflst to find non "0" value in list of layers
;* used in match and offlayer
;****************************************************************

(DEFUN not0 (lst / va)
(WHILE (EQUAL (CAR lst) "0") (SETQ lst (CDR lst)))
(IF lst
(SETQ va (CAR lst))
(SETQ va "0")
) ;_ if
) ;_ defun

(PRINC ".")

;****************************************************************
;* (DXFLST (code nent))
;* returns assoc code matches for all nested entities as list
;* used in match and offlayer
;****************************************************************


(DEFUN dxflst (code nent / va vb)
(SETQ va (LIST (dxf code (ENTGET (CAR nent))))
vb (CAR (REVERSE nent))
) ;_ setq
(WHILE (= (TYPE (CAR vb)) 'ename)
(SETQ va (APPEND va (LIST (dxf code (ENTGET (CAR vb)))))
vb (CDR vb)
) ;_ setq
) ;_ while
(SETQ va va) ;returns value of VA to calling routine
) ;_ defun

(PRINC ".")


;****************************************************************
;* (toasc (str))
;* Converts str to string using itoa or rtos.
;****************************************************************

(DEFUN toasc (str)
(COND ((= (TYPE str) 'real) (RTOS str 2 (GETVAR "LUPREC")))
((= (TYPE str) 'int) (ITOA str))
((= (TYPE str) 'str) str)
(T (TYPE str))
)
)

(PRINC ".")

;****************************************************************
;* (warn (strng))
;* displays message as prompt or alert
;* depending on ACAD release and DEBUG state
;****************************************************************

;|
(DEFUN warn (strng)
(IF (AND ALERT (NULL debug))
(ALERT strng)
(PROMPT (STRCAT "\n" strng))
)
)
|;

;;;Revised definition of warn that always echoes to text screen
(DEFUN warn (strng)
(IF (AND ALERT (NULL debug))
(PROGN (PRINC);(princ) is a work-around for an R14 bug
(ALERT strng)
)
)
(PROMPT (STRCAT "\n" strng))
)
(PRINC ".")

;****************************************************************
;* (ptom)
;* automatically changes focus to graphics screen
;* useful when debugging
;* offers to change to model space if paper space current
;****************************************************************


(DEFUN ptom ()
(GRAPHSCR)
(IF (AND GETKWORD
(= (GETVAR "CVPORT") 1)
(= (GETVAR "TILEMODE") 0)
)
(IF (confirm "Paper to Model"
"Do you want to change to Model Space?"
)
(COMMAND "._MSPACE")
) ;_ if
)
)
;;Remove ; to define PTOM as princ
;;this will disable PTOM function in all routines that use it

;(setq PTOM princ)

(PRINC ".")

;****************************************************************
;* (mtop)
;* automatically changes focus to graphics screen
;* useful when debugging
;* offers to change to paper space if model space current anf
TILEMODE=0
;****************************************************************


(DEFUN mtop ()
(GRAPHSCR)
(IF (AND GETKWORD
(/= (GETVAR "CVPORT") 1)
(= (GETVAR "TILEMODE") 0)
)
(IF (confirm "Model to Paper"
"Do you want to change to Paper Space?"
)
(COMMAND "._PSPACE")
) ;_ if
)
)
;;Remove ; to define MTOP as princ
;;this will disable MTOP function in all routines that use it

;(setq MTOP princ)

(PRINC ".")
;****************************************************************
;* (confirm (title string))
;* asks for confirmation
;* and returns T or nil
;****************************************************************

(DEFUN confirm (title strng1 / yes)
(COND ((< (SETQ supp_id (LOAD_DIALOG "supp.dcl")) 0)
(PRINC "\nsupp.dcl not found! ")
)
((NULL (NEW_DIALOG "confirm_dlg" supp_id))
(PRINC "\nError in supp.dcl. ")
)
(T
(SET_TILE "confirm_title" title)
(SET_TILE "confirm_text1" strng1)
(ACTION_TILE "cancel" "(done_dialog 0)")
(ACTION_TILE "accept" "(done_dialog 1)(setq YES T)")
(START_DIALOG)
)
)
(IF supp_id
(UNLOAD_DIALOG supp_id)
)
(EVAL yes)
)

(PRINC ".")


;****************************************************************
;* (mklay name colour linetype)
;* makes a layer if it does not already exist
;* uses (command "_.layer if R12 or earlier, otherwise entmake
;****************************************************************

(DEFUN mklay (name colour linetype)
(IF (NOT (TBLSEARCH "LAYER" name))
(IF (<= (ATOI (SUBSTR (GETVAR "acadver") 1 2)) 12)
(COMMAND "._layer" "_n" name "_c" colour "_lt" linetype "")
(ENTMAKE (LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(CONS 2 name)
'(70 . 0)
(CONS 62 colour)
(CONS 6 linetype)
)
)
)
)
)

(PRINC ".")
(PRINC)

;3.00 23/8/97 Extra flexibility added to dxf
;3.01 29/8/97 Undo mark added
;3.02 14/12/97 Undo mark made dependant on no active command
;3.03 28/2/98 mtop round and dtr added
;3.04 26/4/98 mklay added
;3.05 4/7/98 dxf redefined
;3.06 22/8/98 (princ) work-around for R14 bug added to (warn...

 

I see a copyright note! Are you allowed to public all the code??

Juergen