代码:
;;; -*- mode: autolisp -*-;;; plain autolisp project of all stdlib modules.;;; don't modify anything in here! this file is created dynamically;;; out of all modules, any changes will be lost!;;; files:;;; std%prj.lsp stdinit.lsp stdmodul.lsp stdstr.lsp stdlist.lsp stdlisp.lsp;;; stdinit2.lsp stdmath.lsp stdpoint.lsp stdtime.lsp stdinput.lsp;;; stdent.lsp;;; stdmisc.lsp stderror.lsp entmake.lsp dict.lsp stdlib.lsp;;; >>cut here ---------------------------------------------- <<cut here;;; $id: std%prj.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; dealing with projects;;; this code is needed for starting a project definition;;; included in a collection of all modules only!;;; copyright (c) 1992,93,94,98,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;;;;; permission to use, copy, modify and distribute this software and its;;; documentation for any purpose is hereby granted without fee, provided;;; 1) that the above copyright notice appear in all copies,;;; 2) that the copyright notice, this permission notice and the pointer;;; where to download the source code for free appear in the;;; supporting documentation of source code distributions,;;; 3) that the name of reini urban not be used in advertising or;;; publicity pertaining to distribution of the software and;;; 4) that modifications without changing the defined function and;;; symbol names may not be published, distributed nor copied;;; without specific, written prior permission.;;;;;; no warranty;;; reini urban makes no representations about the suitability of this;;; software for any purpose, without even the implied warranty of;;; merchantability or fitness for a particular purpose. it is provided;;; "as is" without express or implied warranty.;;; see the full disclaimer for all detailed warranty exclusions.;;; --------------------------------------------------------------------;;; stdlib.fas, stdlib.bi4, stdlib.vlx, stdall.lsp or seperate packages;;; this delays std-require, omit all further stdlib requires;;; because all files are loaded in one step.;;; the first dangerous top-level call must the called after having;;; loaded everything, not to hinder correct vl initialisation.(setq *std:%project* t);;; vlide convenience: unprotect all to avoid re-assignment warnings(if (and *stdlib-syms* std-%unprotect-allsyms ) (std-%unprotect-allsyms));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdinit.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:26 rurban>;;; copyright (c) 1994,98,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; initialization and error handling functions for the stdlib;;;;;; this module may be used in two major ways:;;; 1) if only some functions of the stdlib are needed,;;; this module must be loaded first to able to use std-require;;; 2) as simple module for stdlib, which loads all modules.;;; status:;;; fully tested.;;; from 0.4 on we seperate autolisp system specific functions;;; into special versions to be easier to understand at load-time,;;; and to improve compiler optimization (linkable functions).;;; we use special markers for external processing.;;; there are still some functions pending, in particular:;;; input functions for tablenames and ssget,;;; *stdlib-date* now in datlst format;;;;;; --------------------------------------------------------------------;;; $log: stdinit.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-10-02 22:37:38 rurban;;; added stdlib-beta-p, stdlib-release-p;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-09-19 16:06:24 rurban;;; fixed std-%vlax-get-acad-object to support multiple copies of acad;;; added std-%vlax-vla-object->ename;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-06-18 09:27:36 rurban;;; renamed *stdlib-date* to *stdlib-cdate*;;; changed *stdlib-date* format from cdate to datlst format;;; the old cdate format has some weird precision loss in vlisp 5,;;; so we change to datlst format. this might require some changes;;; on the user side. the < comparable number is now *stdlib-cdate*,;;; but this might be unreliable, until the cause of the problem is;;; found.;;; (fix *stdlib-cdate*) => 20000600 wrong!;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;; 2000-04-26 21:02:49 rurban;;; renumbered msg id's (static only);;; 2000-04-09 18:32:34 rurban;;; changed "*module-path* not set" verbosity;;;;;; revision 0.4009 2000/04/07 17:29:20 rurban;;; v0.4009, see changes;;; 2000-04-07 16:21:49 rurban;;; fixed std-vla-p: added vl-load-com,;;; r15-vlx without activex rts => nil;;; 2000-03-14 22:15:10 rurban;;; changed std-vla-p: check for (std-%vlax-get-acad-object);;;;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdinit-symbols* '(stdlib-version stringp consp std-vl-p std-functionp std-symbol-value std-verbose-print std-vlide-p std-doslib-p std-vla-p std-acad-connection-p std-vl-available-p std-vill-p std-vlisp-p std-vlisp-beta1-p std-acomp-p std-vlrts-p std-sys-dosbased-p std-sys-dos-p std-sys-mswin-p std-sys-unix-p std-sys-mac-p std-sys-os2-p std-sys-longfname-p std-ver-r12-p std-ver-r13-p std-ver-r14-p std-ver-r2000-p std-ver-win-p std-ver-int-p std-ver-fcad-p std-ver-icad-p std-ver-tcad-p std-ver-language std-acadver std-acadplatform std-ver-acadsubversion std-ver-num std-ver-name std-probe-file std-bitsetp std-symbolp std-symbol-name std-symbol-value std-princ-to-string std-prin1-to-string std-position std-remove std-remove-if std-remove-if-not std-member-if std-member-if-not std-sort std-fast-sort std-%vlax-get-acad-object std-%vlax-ename->vla-object std-%vlax-vla-object->ename std-every std-some std-msg ) ) ));;; postprocessing markers: (since v0.3015);;; the markers are similar to the lisp reader-macros #+ and #- but;;; they have to be embedded into inline comments, and need an end marker;;;;;;;;;;;;;;; #+ <feature> : if feature is defined;;; #- <feature> : if feature is not defined;;; <feature> : vl | acomp | alisp | vlisp | vill | vla | small |;;; standalone | dynamic | fcad | icad | tcad;;; vl : if vill, vlisp, vla or standalone;;; dynamic : always false postprocessed;;;;;; no nesting allowed yet, but i work on it.;;; version format: major.minor[1]built[3] such as 0.1001;;; builts are incremented every single published update.;;; minors at minor functionality change or bugfixes;;; majors at larger functionality changes, no bugfixes(setq *stdlib-version* 0.5006)(defun stdlib-version () *stdlib-version*);;; added 2000-10-02 22:36:31 rurban(defun stdlib-release-p() t)(defun stdlib-beta-p () (not (stdlib-release-p)));;; date of version in readable cdate format.;;; comparable with <;;; this variable gets updated automatically with stdinit-upd.pl;;; recently a y2k bugfix (just perl, not lisp!);;; fixme:;;; there's a numeric problem with vlisp 5 (a2000) somewhere;;; which truncates some decimal places: fix and rtos;;; (fix *stdlib-cdate*) => 20000600 wrong!;;; only workaround: change to date or datlst format;;; (std-cdate->date-string (std-datlst->cdate *stdlib-date*))(setq *stdlib-cdate* 20010106.0141)(setq *stdlib-date* '(2001 1 6 1 41 0));;; (setq *stdlib-date* (std-cdate->datlst *stdlib-cdate*))(setq *std:%old-verbose* *verbose* *std:%old-load-verbose* *load-verbose*);;; for early versions we set verbosity automatically.;;; a user/developer can set this also.(if (< *stdlib-version* 0.5) (progn (setq *verbose* t *load-verbose* t ) (if*std:%project*; we save/restore this variable in; *std:%old-load-verbose*; note: vlisp uses it as well; internally.; tools->e.options->general; options->diagnostics; ->"print notification message; after load" (setq *load-verbose* nil) ) ));;; *module-path* should be set by the calling application,;;; but with projects we don't need it yet, top-level loads are delayed(if (and (null *module-path*) (not *std:%project*) *load-verbose* ) (princ (strcat "* Warning: *MODULE-PATH* not set!" "\n** STDLIB will not find its modules" ) ));;; this will be redefined in stdfile(setq *slash-char* "/")(setq *std
ri-error* *error*);;; just to be on the safe side;;; -------------------------------------------------------------------73;;; basic requirements for std-require, overridden in later modules.;;; yes, this is defined somewhere else too.;;; running under vital or visual lisp?;;; this must be dynamic to be able to decide if the function;;; was called from autocad (autilisp mode) or from the rts or the ide.;;; not to be used to decide if native extensions may be used or;;; workarounds. use (or (std-vlrts-p)(std-vlide-p)) instead.;;; usage of unquoted lambda is illegal in acomp.(defun std-vl-p() (not (listp (lambda ()t ) ) ));;; acomp has special(defun special (x) nil);;; acomp declarations(if (not (std-vl-p)); vl has pragma instead (defun pragma(x) nil ); vl declarations);;; avoid reload warnings in vl,;;; the not "std-" prefixed functions are protected.;;; moved behind the pragma definition, thanks to david kozina.(eval (list 'pragma (list 'quote (list(cons 'unprotect-assign ' (stringp consp)) ) ) ))(defun stringp (s) (= (type s) 'str));;; eq may cause problems under acomp;;; vl has a native predicate vl[x]-consp, but we don't use it(defun consp (lst) (not (atom lst)));;; (defun std-symbolp (x);;; (= (type x) 'sym));;; ads resp. autocad independant function version are supported;;; (with some needed workarounds), to be able to use the vital lisp;;; editor standalone (vill 1 and vill 2).;;; autolisp, vill 3 and vlisp can only be called from within autocad;;; so far (no arx stub yet), so we can ignore the special ads;;; independent functions.;;; acomp break (ctrl-c) enabler.;;; without calling this somewhere acomp will never break on <esc>;;; or <ctrl-c>;;; but this must be defined in an uncompiled lisp!;;; best in the mnl file or in acad.lsp before s::startup;;; (defun acomp-ctrl-c-interceptor () (princ));;; std-functionp returns t if the argument is an internal function;;; or a lambda list (lambda (args) body);;; or list representation of a function ((args) body);;; or a symbol of a named function, the return value of (function name)(defun std-functionp (f); fixed 0.3006 for vl compiled; '(lambda..) and; unquoted autolisp defun lists; (forbidden) (or (not (null (member (type f) '(usubr subr exsubr exrxsubr)))) ; just; boolean; ( function (lambda (..) ..)) =>; (quote #<usubr ..>) (and (listp f); (eq (car f) 'quote); eq fails! (eq (type (cadr f)) 'usubr); there are two quotes in vl.; this tests (function (lambda..)) (eq (car f) (car (function (lambda () t ) ) ) ) ) (and (listp f); '(lambda (..)..) (eq (car f) 'lambda) ); plain autolisp accepts lists too.; this may be too dangerous; as functional argument! (and (not (std-vl-p)) (not (std-acomp-p)) (consp f); ((..) ..) (listp (car f)) (consp (cdr f)) ); (function func-name) => sym (and (eq (type f) 'sym) (or(member(type (std-symbol-value f))'(usubr subr exsubr exrxsubr))(std-functionp (std-symbol-value f)) ) ) ));;; vl has native definitions;;; if not vill: almost the same;;; to be redefined at the end of this file if vl(setq std-symbol-value eval);;; considered too dirty, relying on too much;;; undocumented behaviour and uses invalid lisp syntax,;;; but valid autolisp and scheme syntax;;; princ on *verbose*;;; requires stdlisp(defun std-verbose-print (x) (if *verbose* (std-princ x) ))(defun std-%load-verbose-print (msg) (if *load-verbose* (mapcar (function princ) msg ) ));;; princ on *debug*;;; (defun std-debug-print (x);;; (if *debug* (std-princ x)));;; -------------------------------------------------------------------73;;; lisp version predicates(defun std-%defun-check(func) (if (or(not (eq (car func) 'defun))(/= (type (cadr func)) 'sym); function name(not (listp (caddr func))); argument list ) (progn (princ "\n; ***ERROR: wrong defun") (exit) ) t ));;; "conditional defun";;; define the function only if not already defined;;; hmm, this fools the vl linker(defun std-%cond-defun (func) (if (std-%defun-check func) (if(not (std-functionp (std-symbol-value (cadr func)))) (eval func) ) ));;; memoized versions;;; what is memoization?;;; for every argument store the result value in the function itself;;; or in a global variable.;;; so the function is "self-modifiying" or "learning".;;; vlisp/vill don't store the function as list so we have to;;; to store the actual function definition in a special symbol,;;; returned by (std-memoizated-funcname).;;; the term and usage of memoization is widely used in common lisp, but;;; mostly with hash-tables, not self-modifying functions.;;; for simple function with no arguments we don't use;;; self-modifying functions, we use global symbols instead.;;; these memoizing functions were used to create the expanded versions.;;; vl and acomp cannot optimize quoted defun's, that's why.;;; at first the simple ones without arguments;;; predicates without arguments;;; cache first return value, only works with predicates;;; 1 is true, 0 is false;;; looks awful as long as no backquote/comma mechanism is supported;;; =>;;; `(defun ,funcname ,args;;; (if (boundp ',memoized-var);;; (= ,memoized-var 1);;; (= 1 (setq ,memoized-var;;; (if ,body 1 0))));;; with linked-vl provide direct defun's;;; not cached! it may change dynamically.;;; under the ide we may not use (exit)!(defun std-vlide-p () (or (and (std-vill-p) (= "IDE" (substr (_vill-version) 1 3)) ) (and (std-vlisp-p) (= "IDE" (substr (_vlisp-version) 1 3)) ) (and (std-ver-r2000-p) (eq (type vlisp-make-project-fas) 'subr) ) ));;; doslib loaded(defun std-doslib-p () (member (type dos_ver) '(exsubr exrxsubr)));;; some more system specific stuff, but they need an acad connection!;;; with linked-vl provide direct defun's;;; another possibility. make a guess from (ver);;; this seems to be iso 639-1 conformant.;;; there's also a (getvar "locale") in r13 and a vla method in r14;;; see stdlocal (std-acad-locale)(defun std-%ver-language-from-ver (/ s) (std-%simple-require "STDSTR") (setq s (std-lastchars 4 (ver))) (cond ((= s "(en)") ':english ) ((= s "(de)") ':german ) ((= s "(fr)") ':french ) ((= s "(it)") ':italian ) ((= s "(sp)") ':spanish ) ((= s "(ja)") ':japanese ) ((= s "(ru)") ':russian ); dos (cp866) version only ((= s "(cz)") ':czech ) ));;; temp. workaround for versions which return english commands;;; but are marked as international = locked(defun std-%ver-weird-language () (std-%ver-language-from-ver); (if (= (std-lastchars 4 (ver)); "(ja)"); ':japanese; nil; ));;; with linked-vl provide direct defun's;;; vl specific feature: test stand-alone vl mode without acad.;;; should almost always return t,;;; only under vl stand-alone (vill 2) it is nil.;;; so far i assume no connection vill.exe ide 2.0 (which works with;;; r13c4 only);;;;;; the reported feature to load visuallisp alone with ebatchp.exe;;; or any future seperate loader is not detected if fileext.fas is;;; not loaded. i cannot repeat stand-alone vlisp for myself.;;; autocad is probably connected, only invisible.;;;;;; also with vill.exe ver 2 without fileext.fas it always returns t;;; which may be wrong, but fileext.fas should have been loaded so it's;;; academic.;;; with linked-vl provide direct defun's;;; provided to disallow loading fileext.fas to avoid the stupid;;; warnings printed.;;; (setq *disallow-fas2-extensions* t) to disallow loading;;; fas2 extensions, like fileext.fas, binio.fas, inifile.fas and;;; registry.fas;;; we'll use the ads stdlib<ver>.<ext> module instead.(defun std-%accept-fas2-extensions-p () (and (std-vl-p) (not *disallow-fas2-extensions*); defaults to nil, so it's ok (or (not (std-acad-connection-p)) (<= 12 (atoi (std-acadver)) 14) ) ));;; -------------------------------------------------------------------73;;; not-memoized versions needed here to help vl link the functions.(defun std-vla-p () (and (std-vl-p) (progn (and(std-ver-r2000-p)(vl-load-com) ) 1 ); 2000-04-07; it also depends on the runtime; system; (std-%vlax-get-acad-object) (std-functionp vla-move) ));;; with linked-vl provide direct defun's;;; (if (boundp ',memoized-var);;; (= ,memoized-var 1);;; (= 1 (setq ,memoized-var;;; (if ,body 1 0))))(defun std-acad-connection-p () (if (boundp '*acad-connected*); only for vill 2 (= 1 *acad-connected*) (= 1 (setq *acad-connected* (if (if (eq (type std-%acad-connection-p) 'subr ) (std-%acad-connection-p) (if(std-vill-p) (/= "IDE v.2.0" (substr (_vill-version) 1 9 ) ); fixed t ) )10 ) ) ) ))(defun std-vl-available-p () (if (boundp '*def-vl-available*) (= 1 *def-vl-available*) (= 1 (setq *def-vl-available* (if (or (std-vlide-p) (std-vlrts-p) )10 ) ) ) ))(defun std-vill-p () (if (boundp '*def-vill*) (= 1 *def-vill*) (= 1 (setq *def-vill* (if (and (std-vl-p) (boundp '_vill-version) )10 ) ) ) ))(defun std-vlisp-p () (if (boundp '*def-vlisp*) (= 1 *def-vlisp*) (= 1 (setq *def-vlisp* (if (and (std-vl-p) (std-functionp vl-file-size) )10 ) ) ) ))(defun std-vlisp-beta1-p () (if (boundp '*def-vlisp-beta1*) (= 1 *def-vlisp-beta1*) (= 1 (setq *def-vlisp-beta1* (if (and (std-vl-p) (std-functionp file-size) )10 ) ) ) ))(defun std-acomp-p () (if (boundp '*def-acomp*) (= 1 *def-acomp*) (= 1 (setq *def-acomp* (if (and (not (std-vl-p)) (eq (type special) 'usubr) )10 ) ) ) ))(defun std-vlrts-p () (= 1 *def-vlrts*))(defun std-sys-dosbased-p () (if (boundp '*sys-dosbased*) (= 1 *sys-dosbased*) (= 1 (setq *sys-dosbased* (if (getenv "COMSPEC")10 ) ) ) ))(defun std-sys-dos-p () (if (boundp '*sys-dos*) (= 1 *sys-dos*) (= 1 (setq *sys-dos* (if (and (getenv "COMSPEC") (not (std-sys-mswin-p)) ) 1 0 ) ) ) ))(defun std-sys-mswin-p () (if (boundp '*sys-mswin*) (= 1 *sys-mswin*) (= 1 (setq *sys-mswin* (if (std-ver-win-p)10 ) ) ) ))(defun std-sys-unix-p () (if (boundp '*sys-unix*) (= 1 *sys-unix*) (= 1 (setq *sys-unix* (if (and (not (std-sys-dos-p)) ; this might fail on; nt/win2000; we should better check for a; filesystem specific; or analyse the platform string (or; use uname) (getenv "USER") )10 ) ) ) ))(defun std-sys-mac-p () (if (boundp '*sys-mac*) (= 1 *sys-mac*) (= 1 (setq *sys-mac* (if (wcmatch (std-acadplatform) "*Mac*") 1 0 ) ) ) ))(defun std-sys-os2-p () (if (boundp '*sys-os2*) (= 1 *sys-os2*) (= 1 (setq *sys-os2* (if (wcmatch (std-acadplatform) "*OS2*") 1 0 ) ) ) ))(defun std-sys-longfname-p () (if (boundp '*sys-longfnames*) (= 1 *sys-longfnames*) (= 1 (setq *sys-longfnames* (if (or (std-ver-r14-p) (and (std-ver-r13-p) (> (getvar "LONGFNAME") 0) ) (std-sys-os2-p) (not (std-sys-dosbased-p)) )10 ) ) ) ))(defun std-ver-r12-p () (if (boundp '*sys-r12*) (= 1 *sys-r12*) (= 1 (setq *sys-r12* (if (= (atoi (std-acadver)) 12) 1 0 ) ) ) ))(defun std-ver-r13-p () (if (boundp '*sys-r13*) (= 1 *sys-r13*) (= 1 (setq *sys-r13* (if (>= (atoi (std-acadver)) 13) 1 0 ) ) ) ))(defun std-ver-r14-p () (if (boundp '*sys-r14*) (= 1 *sys-r14*) (= 1 (setq *sys-r14* (if (>= (atoi (std-acadver)) 14) 1 0 ) ) ) ))(defun std-ver-r2000-p () (if (boundp '*sys-r15*) (= 1 *sys-r15*) (= 1 (setq *sys-r15* (if; internal debug builds:; (or (< 0.60 (atof (substr; (std-acadver) 3)) 1.0) (> (atoi (std-acadver)) 14) ; ) 1 0 ) ) ) ))(defun std-ver-win-p () (if (boundp '*sys-mswin*) (= 1 *sys-mswin*) (= 1 (setq *sys-mswin* (if (wcmatch (std-acadplatform) "*Win*")10 ) ) ) ))(defun std-ver-int-p () (if (boundp '*sys-locked*) (= 1 *sys-locked*) (= 1 (setq *sys-locked* (if; new "h" postfix to be checked(wcmatch (std-acadver) "*Int*,*Lock*,*h") 1 0 ) ) ) ))(defun std-ver-fcad-p () (if (boundp '*sys-fcad*) (= 1 *sys-fcad*) (= 1 (setq *sys-fcad* (if (getvar "FCVERSION")10 ) ) ) ))(defun std-ver-icad-p () (if (boundp '*sys-icad*) (= 1 *sys-icad*) (= 1 (setq *sys-icad* (if; this works only for icad 98, icad; 2000 not tested yet(= (substr (std-acadver) 1 3) "14i") 1 0 ) ) ) ))(defun std-ver-tcad-p () (if (boundp '*sys-tcad*) (= 1 *sys-tcad*) (= 1 (setq *sys-tcad* (if (= (std-ver-name) "TCAD")10 ) ) ) ))(defun std-ver-language(/ cmd) (if *sys-language* *sys-language* (setq *sys-language* (cond ((not (boundp 'getcname)) (if (std-ver-int-p)(std-%ver-language-from-ver)':english ) ) ((= (setq cmd (getcname "_CIRCLE")) "CIRCLE" ) (if (std-ver-int-p)(std-%ver-weird-language)':english ) ) ((= cmd "KREIS") ':german ) ((= cmd "CERCLE") ':french ) ((= cmd "CERCHIO") ':italian ) ((= cmd "CIRCULO") ':spanish ) ((= cmd "KRU\216NICE") ':czech ) ((= cmd "\312\320\323\303") ':russian ); to be added more below, like; ((= cmd "xy\200z") ':newlanguage) ((std-ver-fcad-p) (setq cmd (getvar "LANGUAGE")) ; => 1-5 (cond((= cmd 1) ':german)((= cmd 2) ':english); what is 3?((= cmd 4) ':hungarian)((= cmd 5) ':polish) ) ) (t nil ) ) ) ))(defun std-acadver () (if *acadver* *acadver* (setq *acadver* (cond ((getvar "FCVERSION")) ((getvar "ACADVER")) ) ) ));;; fcad returns "win32";;; r14 eg. "microsoft windows nt version 4.0 (x86)"(defun std-acadplatform() (cond (*acadplatform*) ((setq *acadplatform* (getvar "PLATFORM"))) ));;; returns the fractional part as float, like 0.1;;; "10 c2" => 0.2;;; "10_c10" => 0.1;;; "11_c2" => 0.2;;; "13_c1" - "13_c4" => 0.1 - 0.4;;; "13_c4a" => 0.41;;; "14.0" => 0.0;;; "14.01" => 0.01;;; icad 98: 13.9;;; icad a-e: 13.91 - 13.95;;; fcad 3: 14.3;;; fcad 4: 14.4(defun std-ver-acadsubversion (/ s) (std-%simple-require "STDSTR") (cond ((=(substr(setq s (std-acadver))16)"13_c4a" ); 13_c4a or 13_c4ah 0.41 ) ((wcmatch s "##[ _]c#*"); r10,11,13; fixed (atof (strcat "0." (substr s (+ 1 (std-strpos "c" s))))) ) ((wcmatch s "##c*#*"); r10-12 (not sure) (atof (strcat "0." (substr s (+ 1 (std-strpos "c" s))))) ) ((wcmatch s "##.#*"); r14, fixed (atof (strcat "0." (substr s (+ 1 (std-strpos "." s))))) ) ((wcmatch s "#.#*"); <=r9?? (atof (strcat "0." (substr s (+ 1 (std-strpos "." s))))) ) ((= "14i") -0.1 ) ((std-ver-fcad-p) (/ (atof (getvar "FCVERSION")) 10) ) (t 0 ) ));;; comparable unique float for acad or clones main_release.sub_version;;; r10c10: 10.10;;; r12: 12.0;;; r13: 13.0 c1: 13.1 c2: 13.2 c4: 13.4 c4a: 13.41;;; r14: 14.0, 14.01;;; a2000: 15.0;;; icad 98: 13.9;;; icad a-e: 13.91 - 13.95;;; fcad 3: 14.3;;; fcad 4: 14.4(defun std-ver-num () (cond (*acadver-num*) ((std-ver-fcad-p) (+ 14 (std-ver-acadsubversion)) ) (t (+ (atoi (std-acadver)) (std-ver-acadsubversion)) ) ));;; (std-ver-name) => "acad" | "icad" | "fcad" | "tcad"(defun std-ver-name (/ s) (cond (*acadvername*) ((setq *acadvername* (cond ((not (std-acad-connection-p)) "VILL" ) ((= (setq s (substr (ver) 1 5)) "AutoL" ) "ACAD" ) ((= s "Visua") "ACAD" ) ((std-ver-fcad-p) "FCAD" ) ((std-ver-icad-p) "ICAD" ); turbocad? ) ) ) ));;; -------------------------------------------------------------------73;;; initialization, error handling;;; moved to stderror.lsp;;; -------------------------------------------------------------------73;;; loading stuff;;; supported compiled file extension or nil.;;; depricated!;;; this is not the whole story since we could also check if a vill;;; or vlisp runtime module is present and (vload) it then.;;; see stdlisp(setq *comp-ext* (cond ((std-acomp-p) ".BI4" ) ((not (std-%accept-fas2-extensions-p)) nil ) ((std-vl-p) ".FAS" ); consider also ".vlx" (t nil ) ));;; needs basename only, like (std-%simple-load "stdinit")(defun std-%simple-load(fname / lst path) (std-%load-verbose-print (list "\nLoading " fname " ...")) (setq lst *module-path*); first search it in the module; path, findfile needs acad (while (and lst (not path) ) (if*comp-ext* (setq path (findfile (strcat (car lst) fname *comp-ext*))) ) (or path; break if found (setq path (findfile (strcat (car lst) fname ".LSP"))) ) (setq lst (cdr lst)) ); either found it in *module-path*,; or if not; search in the acad library path (setqpath (cond (path) (fname) ) ) (if (= "error" (load path "error")) (mapcar 'princ (list " Error loading " fname "!") ) t ));;; readable file? return the filename;;; with linked-vl provide direct defun's(defun std-probe-file (fname / f) (if (and(stringp fname)(setq f (open fname "r")) ); fixed (progn (close f) fname ) ));;; extended for arx and ads modules(defun std-%simple-load-external (fname / lst path) (std-%load-verbose-print (list "\nLoading " fname " ...")) (setq lst *module-path*); first search it in the module path (while (and lst (not path) ) (setq path (if (std-acad-connection-p) (cond ((findfile (strcat (car lst) fname (if *comp-ext**comp-ext*".LSP" ) ) ) ) ((findfile (strcat (car lst) fname ".LSP"))) ((findfile (strcat (car lst) fname ".ARX"))) ((findfile (strcat (car lst) fname ".EXE"))) ((findfile (strcat (car lst) fname ".EXP"))) ) (cond ((std-probe-file (strcat (car lst) fname (if *comp-ext**comp-ext*".LSP" ) ) ) ) ((std-probe-file (strcat (car lst) fname ".LSP"))) ) ) lst (cdr lst) ) ) (if path; found it in *module-path* (load path "error"); or search in the acad library path; try lisp, arx and ads (if(= "error" (load fname "error")) (if (std-acad-connection-p); fixed 0.2013(if (or (not (std-functionp arxload)) (= (arxload fname "error") "error") ) (if (or(not (std-functionp xload))(= (xload fname "error") "error") ) "error" ))"error" ) ) ));;; moved from stdmath. we don't need the whole maths just for this;;; basic function.;;; t if all bitvalues in flag are set or nil(defun std-bitsetp (val flag) (= (logand val flag) val));;; bugfix for vlax-get-acad-object resp. vlax-getacadobject;;; vlax-getacadobject will fail with multiple acad.exe copies otherwise.(defun std-%vlax-get-acad-object () (cond (*iacadapplication*); cache (t (setq *iacadapplication* (vlax-get (std-%vlax-ename->vla-object(namedobjdict) ) "Application" ) ) ) ));;; -------------------------------------------------------------------73;;; extension mappings;;; only acomp, vital lisp and visual lisp;;; external extensions are handled by extra files:;;; binio.fas, registry.fas, inifile.fas;;; and extra version numbering.(cond ((std-acomp-p); see stdacomp.lsp ) ((std-vill-p); vital lisp (defun std-symbolp (x); already defined above (vlx-symbolp x) ) (defun std-symbol-name (x) (vlx-symbol-name x) ) (defun std-symbol-value (x) (vlx-symbol-value x) ) (defun std-princ-to-string (x) (vlx-princ-to-string x) ) (defun std-prin1-to-string (x) (vlx-prin1-to-string x) ) (defun std-remove (x lst) (vlx-remove x lst) ) (defun std-remove-if(f lst) (vlx-remove-if f lst) ) (defun std-remove-if-not (f lst) (vlx-remove-if-not f lst) ) (defun std-member-if(f lst) (vlx-member-if f lst) ) (defun std-member-if-not (f lst) (vlx-member-if-not f lst) ) (defun std-sort (x f) (vlx-sort x f) ) (defun std-fast-sort(x f) (vlx-sort x f) ) (if (std-functionp vlx-position); introduced with vill 3 (defun std-position (x lst) (vlx-position x lst) ) ); old:; (defun; std-%vlax-get-acad-object (); (vlax-getacadobject)); fix: vlax-getacadobject will fail; with multiple acad.exe copies; otherwise.; see cached version above instead.; (defun; std-%vlax-get-acad-object (); (vlax-get (vlax-entname->vlaobj; (namedobjdict)) "application")); 7-apr-00 for backwards; compatibility with vill (defun std-%vlax-ename->vla-object (ele) (vlax-entname->vlaobj ele) ) (defun std-%vlax-vla-object->ename (ele) (vlax-vlaobj->entname ele) ) (if (std-functionp vlx-every); introduced when? (progn (defun std-every(pred lst) (vlx-every pred lst) ) (defun std-some (pred lst) (vlx-some pred lst) ) ) ) ) ((std-vlisp-p); visual lisp (defun std-symbolp (x); already defined above (vl-symbolp x) ) (defun std-symbol-name (x) (vl-symbol-name x) ) (defun std-symbol-value (x) (vl-symbol-value x) ) (defun std-princ-to-string (x) (vl-princ-to-string x) ) (defun std-prin1-to-string (x) (vl-prin1-to-string x) ) (defun std-position (x lst) (vl-position x lst) ) (defun std-remove (x lst) (vl-remove x lst) ) (defun std-remove-if(f lst) (vl-remove-if f lst) ) (defun std-remove-if-not (f lst) (vl-remove-if-not f lst) ) (defun std-member-if(f lst) (vl-member-if f lst) ) (defun std-member-if-not (f lst) (vl-member-if-not f lst) ) (defun std-sort (x f) (vl-sort x f) ) (defun std-fast-sort(x f) (vl-sort x f) ); those three funcs were renamed; from vill to vlisp; so we provide unified names; r14 note:; vlax-get-acad-object will fail; with multiple acad.exe copies.; we either need acadunsup.arx 1.0; or this hack by albert szilvasy; (defun; std-%vlax-get-acad-object (); (vlax-get; (vlax-ename->vla-object; (namedobjdict)) "application")); to fix (vlax-get-acad-object); 7-apr-00 (defun std-%vlax-ename->vla-object (ele) (vlax-ename->vla-object ele) ) (defun std-%vlax-vla-object->ename (ele) (vlax-vla-object->ename ele) ) (defun std-every (pred lst) (vl-every pred lst) ) (defun std-some (pred lst) (vl-some pred lst) ) ) (t; no vill nor vlisp, use workarounds; instead; already needed earlier; (setq std-symbol-value eval); symbol name as string (defun std-symbol-name (symb / x) (if (not (boundp symb)) (progn (set symb t) (setq x (std-%bound-symbol-name symb)) (set symb nil) x ) (std-%bound-symbol-name symb) ) ); must be bound, means must be; non-nil!; autolisp has a wrong; implementation of bound,; something like (defun boundp; (x)(not (null x))); normally bound symbols may have; the value nil.; in autolisp not! aargh (defun std-%bound-symbol-name (symb) (std-%simple-require "STDLIST"); needed: workaround for atomlist,; <= r11 (nth (std-position symb (atoms-family 0)) (atoms-family 1)) ) (setq function quote) (defun std-symbolp (x); already defined above (eq (type x) 'sym) ) ));;; translate to localized message(defun std-msg (x) (if (std-module-defined-p "STDLOCAL") (progn (if (listp x)(mapcar (function std-%translate-string) x)(std-%translate-string x) ) ) x ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdinit-symbols*))(setq *stdinit-symbols* nil);;; module dependencies:;;; stdinit needs modules to work:;;; if all required stdlib modules are contained in one project,;;; we don't have to load it explicitly.;;; stdlib.fas already contains it!(if (not *std:%project*); set by std%prj.lsp which is only (progn; part of the project (if(not (std-functionp std-%simple-require)) (std-%simple-load "STDMODUL") (std-provide "STDINIT") ) ));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdmodul.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:35 rurban>;;; copyright (c) 1998 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; modules;;;;;; load a file if it is not already loaded.;;; delay loading if *std:%project* is not-nil, to avoid unneccessary;;; and unpredictable top-level load calls.;;; the project using the stdlib needs to manage the globals;;; *std:%project* and *std:modules-delayed* then!;;;;;; status:;;; tested, the interface is stable.;;; we use a list of uppercase strings as modules.;;; intermediate global constants:;;; *std:unbind-symbols* -boolean- decides if to unbind variables too.;;; depricated:;;; *modules-as-strings* -boolean- if the modules are stored as strings;;; or symbols. symbols cannot be handled by the ads resbuf.;;; now: as if t;;; *modules-in-obarray* -boolean- is to test the two implementations.;;; i don't know yet if to keep the in-obarray version;;; or the simplier *modules* list version.;;; now: nil;;; features:;;; some feature code will probably be added. features are not exactly;;; modules. just features provided by the system or by a module.;;; this is another way to do run-time detection of some features;;; provided by the systemm as with #+;;; features can be set and checked.;;; typical features would be (vl, vlisp, vill, vla, acomp, registry,;;; inifile, binio, int32, strong-random, protected-eval, sageclos,;;; setf, array, struct, mvalues, ...);;; $log: stdmodul.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdmodul-symbols* ' (std-%simple-require std-%simple-provide std-require std-provide std-module-defined-p std-modules std-module-unbind ) ) ));;; may be set by the calling application and is overridden in;;; stdlib.lsp. we need just the path of the stdlib files. in stdlib.lsp;;; -the main module- at the very end of the file we define all other;;; paths.;;; change this to your requirements if you intend to load stdmodul;;; alone without stdlib;;; (if (not (boundp '*module-path*));;; ;; just my default;;; (setq *module-path* '("l:\\src\\stdlib\\")));;; simple modules;;; versions not using stdfile, blindly assuming pathnames;;; ending with slashes and extensions prefixed with a dot.;;; we need it to load stdmodul,stdstr,stdlisp,stdfile and stdinit2;;; then we can use the full versions, which are safer.;;;;;; needs basename only, like (std-%simple-load "stdinit");;; (defun std-%simple-load (fname / lst path);;; (std-%load-verbose-print (list "\nloading " fname " ..."));;; (setq lst *module-path*);;; ;; first search it in the module path, findfile needs acad;;; (while (and lst (not path));;; (if *comp-ext*;;; (setq path (apply (if (std-acad-connection-p);;; 'findfile;;; 'std-probe-file);;; (list (strcat (car lst) fname *comp-ext*)))));;; (or path; break if found;;; (setq path (apply (if (std-acad-connection-p);;; 'findfile;;; 'std-probe-file);;; (list (strcat (car lst) fname ".lsp")))));;; (setq lst (cdr lst)));;; ;; found it in *module-path*;;; ;; or search in the acad library path;;; (setq path (cond (path) (fname)));;; (if (and (std-functionp 'vl-load) (std-vlrts-p));;; (vl-load path);;; (load path 'error);;; );;; );;; (std-%cond-defun;;; ;;; extended for arx and ads modules;;; '(defun std-%simple-load-external (fname / lst path);;; (std-%load-verbose-print (list "\nloading " fname " ..."));;; (setq lst *module-path*);;; ;; first search it in the module path;;; (while (and lst (not path));;; (setq path;;;;;; (if (std-acad-connection-p);;; (cond;;; ((findfile (strcat (car lst) fname;;; (if *comp-ext* *comp-ext* ".lsp"))));;; ((findfile (strcat (car lst) fname ".lsp")));;; ((findfile (strcat (car lst) fname ".arx")));;; ((findfile (strcat (car lst) fname ".exe")));;; ((findfile (strcat (car lst) fname ".exp")));;; );;;;;; (cond;;; ((std-probe-file (strcat (car lst) fname;;; (if *comp-ext* *comp-ext* ".lsp"))));;; ((std-probe-file (strcat (car lst) fname ".lsp")));;; );;;;;; );;;;;; lst (cdr lst)));;; (if path;;; ;; found it in *module-path*;;; (if vl-load;;; (vl-load path);;; (load path 'error));;; ;; or search in the acad library path;;; ;; try lisp, arx and ads;;; (if vl-load;;; (vl-load fname);;; (if (eq 'error (load fname 'error));;;;;; (if (std-acad-connection-p); fixed 0.2013;;; (if (eq 'error (arxload fname 'error));;; (xload fname 'error);;; 'error;;; );;; );;;;;; 'error;;; );;; );;; );;; );;; )(setq *modules-as-strings* t)(setq *modules-in-obarray* nil);;; simple require, only strings, no module-path(defun std-%simple-require (s) (cond ((std-%simple-module-string-defined-p s) s ) (*std:%project* (setq *std:modules-delayed* (cons s *std:modules-delayed* ) ) (std-%load-verbose-print (list "\n..." "Module" " " s " delayed... ") ) t ) ((= "STD" (substr s 1 3)) (std-%simple-load s) ) (t (std-%simple-load-external s) ) ));;; simple provide: must take uppercase strings only(defun std-%simple-provide (s) (if *std:modules-delayed* (setq *std:modules-delayed* (std-remove s *std:modules-delayed*)) ) (if (std-%simple-module-string-defined-p s) s (progn (std-%load-verbose-print(list "\n" "Module" " " s " provided. ") ) (setq *modules* (cons s *modules*)) ) ));;; ---------------------------------------------------------------------;;; modules;;; not defined in the x3j13 ansi cl standard but in most lisps and;;; scheme libraries.;;; all std-% functions are implementation specific hacks;;; and may be replaced by other functions and functionality.;;; e.g. a global list *modules* of all loaded modules.;;; *modules-in-obarray* -boolean- is to test the two implementations.;;; i don't know yet if to keep the in-obarray version;;; or the simplier *modules* list version.;;; (std-requirestr|sym); loads a module if necessary;;; this is the actual full definition of std-require, the simple;;; version requires a string without path and extension.;;;;;; this version accepts symbols and strings or filenames.;;; works best with strings. (std-load) is defined in stdlisp(defun std-require (path / name) (setq name (std-%force-module-string-dot path)) (cond ((std-%module-string-defined-p name) ; "registry" needs special; treatment (if (and (= name "REGISTRY") (not registry-acad-product-key) ) (std-load "REGISTRY") ) (if *std:modules-delayed* (setq *std:modules-delayed* (std-remove name *std:modules-delayed*) ) ) name ) (*std:%project* (setq *std:modules-delayed* (cons name *std:modules-delayed* ) ) (std-%load-verbose-print (list "\n..." (std-msg "Module") " " name (std-msg " delayed... ") ) ) 'delayed ) ((stringp path) (if (std-load path) (progn (if *std:modules-delayed* (setq *std:modules-delayed* (std-remove name *std:modules-delayed* ) ) ) path ) ) ) (t (if (std-load name) (progn (if *std:modules-delayed* (setq *std:modules-delayed* (std-remove name *std:modules-delayed* ) ) ) name ) ) ) ));;; (std-providestr|sym); define a module;;; this version accepts symbols and strings, and may use;;; specially prefixed symbols in the atomtable.;;; works best with strings.(defun std-provide (name); we won't provide dots in the; module name (std-%simple-provide (std-%force-module-string-dot name)))(defun std-module-defined-p (name) (cond ((stringp name) (std-%module-string-defined-p name) ); fixed for strings ((std-symbolp name) (std-%module-string-defined-p (std-%force-module-string name) ) ) (t (std-error (list "Module name must be a string or symbol -- " name) ) ) ));;; assuming upcase strings(defun std-%simple-module-defined-p (name) (std-%simple-module-string-defined-p name));;; therefore we provide a special method for strings too.;;; used internally only. must be not destructive!;;; if (boundp (std-%module-string->symbol "x")) => nil;;; then all subsequent (boundp (std-%module-string->symbol "x"));;; must return nil also!;;; the other way is the simple global *modules* list(defun std-%module-string-defined-p (s); temp. workaround for the ads; version (if (= s "STDLIB-ADS") (or (numberp *stdlib-ads-version*); fix for versions before 0.400013 (numberp *stdlib-adsrx-version*) ); t or nil only (and (member (strcase s) *modules*) ) ));;; assume upcase strings(defun std-%simple-module-string-defined-p (s) (if (= s "STDLIB-ADS") (or (numberp *stdlib-ads-version*) (numberp *stdlib-adsrx-version*) ); t or nil only (and (member s *modules*) ) ));;; module string->symbol;;; we may use a magic (hopefully unique) name to avoid nameconflicts;;; in the atoms hashtable.(defun std-%module-string->symbol (s) (read s));;; cannot be used for module names with dots.;;; use std-%force-module-string-dot for these.(defun std-%force-module-string(name) (cond ((stringp name) (if (std-acad-connection-p) (strcase name) (std-strcase name) ) ) ((std-symbolp name) (std-symbol-name name) ); we use uppercase (t (std-error (list "Module name must be a string or symbol -- " name) ) ) ));;; removes the extension in filenames given to require;;; as in (std-require "fileext.fas");;; => "fileext"(defun std-%force-module-string-dot (name) ; (std-%simple-require; "stdstr") (std-%string-without-dots (std-%force-module-string name)));;; returns list of loaded modules as strings or symbols.;;; re strings vl rts troubles as outlined by serge pashkov:;;; (vl-eval-str "(std-modules)" will print and return nothing, but;;; (vl-eval-str "(princ (std-modules))" will work.;;;;;; (setq m (vl-eval-str "(std-modules)")) not.;;; (vl-eval-str "(setq m (std-modules))") and;;; (vl-eval-str "(vlisp-export-symbol 'm)") will not work with symbols!;;; instead use:;;; (vl-eval-str "(setq m (mapcar 'vl-princ-to-string (std-modules)))");;; (vl-eval-str "(vlisp-export-symbol 'm)");;;;;; these constructs are only needed if you need vl symbols in autolisp;;; but normally you work just in one system, not in both.;;; list of all define modules;;; unbind all modules with (mapcar 'std-module-unbind (std-modules))(defun std-modules (/ s missing) (if (and*std:modules-delayed*(setq missing (std-set-difference *std:modules-delayed* *modules*)) ) (std-verbose-print (list "" missing "\n")) ) *modules*);;; undefine a module and unbind according symbols;;; *std:unbind-symbols* -boolean- decides if to unbind variables too.;;; default: nil (not yet)(defun std-module-unbind (name / s global func) (setq*modules* (std-remove (cond ((stringp name) name ) ((std-symbolp name) (std-%force-module-string name) ) ) *modules* ) ) (if *std:unbind-symbols* (progn; possibly unbind all symbols with; the module prefix, such as (setq func (strcat (std-%force-module-string name) "-")) (setq global (strcat "*" (std-%force-module-string name))) (foreach s (atoms-family 1)(if (or (std-strcmp func s) (and(std-strcmp global s)(= "*" (std-lastchar s)) ) ) (set (read s) nil)) ) ) ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdmodul-symbols*))(setq *stdmodul-symbols* nil);;; this is no seperate module, just an extension for stdinit(std-%simple-provide "STDINIT");;; if all required stdlib modules are contained in one project,;;; we don't have to load it explicitly.;;; stdlib.fas already contains it!(if (not *std:%project*) (progn (std-%simple-require "STDSTR"); std-modules: std-str-1,; std-module-unbind: std-lastchar; std-%force-module-string-dot:; std-%string-without-dots (std-%simple-require "STDLISP"); std-require: std-load-external ));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdstr.lsp 0.5006 2000/12/31 10:59:00 rurban rel $-*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:50 rurban>;;; copyright (c) 1998,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; string functions for the stdlib;;; this can be loaded standalone.;;; status:;;; not fully tested but they should be okay.;;; some names have been renamed lately to long versions, and some;;; zero-based functions added, for downwards compatibilities sake.;;;;;; the naming scheme is twofold. there are short strxxx;;; versions and long string-xxx versions. the short names match;;; clib names, the long common lisp.;;;;;; $log: stdstr.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-10-02 15:28:49 rurban;;; std-string-wc-replace: added "i", "x",;;; added not-nested functional string splice at "e";;; 2000-10-02 14:23:34 rurban;;; std-string-wc-replace:;;; 2000-10-01 14:01:27 rurban;;; added std-string-wc-replace;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;; 2000-03-16 10:46:35 rurban;;; changed std-%string-8bit->octal to put the double-quote around it.;;; so it's a fully portable string-unexpand now, reverse to princ;;; needed for the stdlocal message tables.;;; not destructive anymore;;; 2000-04-07 19:20:22 rurban;;; boyer-moore method for std-strpos, vlisp method added;;; dclstring<->strlist docs added to stdlib.hlp;;; 2000-04-10 13:32:20 rurban;;; fixed std-strpos for sys vlisp;;;;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdstr-symbols* ' (std-string-not-empty-p std-ischar std-isdigit std-iscontrol std-isupper std-islower std-tolower std-toupper std-string= std-string/= std-string< std-string<= std-string> std-string>= std-string-equal std-string-not-equal std-string-lessp std-string-not-lessp std-string-greaterp std-string-not-greaterp std-strcase std-string->list std-list->wstring std-list->string std-string-elt std-firstchar std-lastchar std-lastchars std-str-1 std-str-n std-strpos std-stripos std-string-position std-strcmp std-stricmp std-string-mismatch std-strcount std-wcimatch std-strmember std-strimember std-strlist-match std-strlist-imatch std-string-upcase std-string-downcase std-string-capitalize std-strtok std-strsplit std-strjoin std-string->strlist std-csstring->strlist std-strlist->string std-strlist->csstring std-strlist->dclstring std-dclstring->strlist std-string-left-trim std-string-right-trim std-string-trim std-trim std-string-remove-comments std-string-right-pad-char std-string-left-pad-char std-rpad std-lpad std-strcenter std-strchg std-string-subst std-string-translate std-string-wc-replace std-entab std-entab8 std-detab std-detab8 std-rtos std-make-string ) ) ));;; predicates;;; already defined in stdinit;;; (defun stringp (s) (= (type s) 'str)) ; eq has errors with bi4 (acomp);;; is non-empty string?(defun std-string-not-empty-p (s) (and (stringp s) (/= s "") ));;; for the character predicates we use clib names;;; in cl named: alpha-char-p(defun std-ischar (char); so far we use only the windows; (ansi) charset. (or (std-isupper char) (std-islower char) ));;; in cl named: digit-char-p(defun std-isdigit (char) (if (eq (type char) 'int) (<= 48 char 57) (<= "0" char "9") ));;; the class of chars that are not correctly printed in dcl;;; edit_boxes or list_boxes.;;; checks for the class of non-graphic characters,;;; also named formatting characters or control characters.;;; in dcl control chars are not printed well.(defun std-iscontrol (char) (if (eq (type char) 'int) (< char 32) (< char " ") ));;; special 8 bit characters and;;; codepages and upper-lower ranges and translation tables;;; ---------------------------------------------------------------------;;; see stdlocal.;;; with iso cp's or unicode we have no problems.;;; upcase <=> downcase == +-32 or 0x20 on iso cp's and unicode,;;; but the range of upcase/downcase letters is different.;;; old dos charsets like dos437, dos850, ... are completely different;;; and unique.;;; we set and get our codepage with std-sys-codepage from stdlocal;;; this affects so far:;;; std-isupper (range);;; std-islower (range);;; std-toupper (low-level int translation);;; std-tolower (low-level int translation);;; note also that these names are clib based, not common lisp!;;; subject to redefinition in stdlocal;;; in cl named: upper-case-p(defun std-isupper (char) (if (eq (type char) 'int) (setq char (chr char)) ); this is only iso8859-1, also named; ansi or latin-1; this is standard in mswin and most; unix (or (<= "A" char "Z"); (<= "? char "?) (<= "\300" char "\336") ));;; cm;;; (defun std-islower (char);;; (and (std-ischar char) (not (std-isupper char))));;; subject to redefinition in stdlocal;;; in cl named: lower-case-p;;; fixed by masami chikahiro(defun std-islower (char) (if (eq (type char) 'int) (setq char (chr char)) ); this is only iso8859-1 (or (<= "a" char "z"); (<= "? char "?) (<= "\340" char "\377") ));;; cm;;; low-level modifier, takes only an integer number;;; in cl named: char-downcase(defun std-tolower (i) (if (or(<= 65 i 90)(<= 192 i 223) ) (+ i 32) i ));;; low-level modifier, takes only an integer number;;; in cl named: char-upcase(defun std-toupper (i) (if (or(<= 97 i 122)(<= 224 i 255) ) (- i 32) i ));;; -------------------------------------------------------------------73;;; comparison;;; "stronger" comparisons: case-sensitive(defun std-string= (s1 s2) (= s1 s2))(defun std-string/= (s1 s2) (/= s1 s2))(defun std-string< (s1 s2) (< s1 s2))(defun std-string<= (s1 s2) (<= s1 s2))(defun std-string> (s1 s2) (> s1 s2))(defun std-string>= (s1 s2) (>= s1 s2));;; "weaker" comparisons: case-insensitive(defun std-string-equal(s1 s2) (= (std-strcase s1) (std-strcase s2)))(defun std-string-not-equal (s1 s2) (/= (std-strcase s1) (std-strcase s2)))(defun std-string-lessp(s1 s2) (< (std-strcase s1) (std-strcase s2)))(defun std-string-not-lessp (s1 s2) (>= (std-strcase s1) (std-strcase s2)))(defun std-string-greaterp (s1 s2) (> (std-strcase s1) (std-strcase s2)))(defun std-string-not-greaterp (s1 s2) (<= (std-strcase s1) (std-strcase s2)));;; -------------------------------------------------------------------73;;; string conversion;;; autocad independent strcase;;; affected by redefinition of std-toupper in stdlocal(defun std-strcase (s) (cond ((std-list->string (mapcar (function std-toupper) (std-string->list s) ) ) ) (t "" ) ));;; safe redefinition:;;; (defun std-%force-module-string (name);;; (cond ((stringp name) (std-strcase name));;; ((std-symbolp name) (std-symbol-name name));;; (t (std-error (list "module name must be a string or symbol -- ";;; name)))));;; numbers need less memory space and housekeeping;;; "12" => (49 50)(defun std-string->list(s / lst) (if (stringp s) (while (/= s "") (setq lst(cons (ascii (substr s 1 1)) lst) s(substr s 2) ) ) ) (reverse lst));;; numbers need less memory space and housekeeping;;; unicode support;;; (49 50 9600) => "12?(defun std-list->wstring (lst / s) (if (listp lst); fixed (progn (setq s "") (while lst(setq s (strcat s (chr (car lst))) lst (cdr lst)) ) ) ) s);;; (if (eq (type vl-list->string) 'subr)(defun std-list->string(lst) (std-list->wstring lst));;; );;; -------------------------------------------------------------------73;;; accessors, searching, matching;;; ascii int of i'th char (zero-based)(defun std-string-elt (s i) (std-elt (std-string->list s) i));;; return the first char(defun std-firstchar (s) (substr s 1 1));;; return the last char(defun std-lastchar (s) (if (std-string-not-empty-p s) (substr s (strlen s) 1) "" ));;; return the last n chars(defun std-lastchars (n s) (cond ((>= n (strlen s)) s ) ((std-string-not-empty-p s) (substr s (1+ (- (strlen s) n)) n) ) (t "" ) ));;; "string minus one";;; return the string without the last char(defun std-str-1 (s) (if (std-string-not-empty-p s) (substr s 1 (1- (strlen s))) s ));;; "string minus n";;; return the string without the last n chars(defun std-str-n (n s) (cond ((>= n (strlen s)) "" ) ((std-string-not-empty-p s) (substr s 1 (- (strlen s) n)) ) ));;; returns first position of match in str or nil;;; case-sensitive, no regex, plain substring, first index = 1;;; boyer-moore method by serge pashkov, faster than old strpos below;;; lisp translation of modula-2 program from the book;;; "algorithms and data structure", n.wirth, prentice-hall, inc. 1986;;; see contrib/boyer-moore.lsp for benchmarks and samples(defun std-strpos (match s / m n i d p c mc mm1) (setqm (strlen match)n (strlen s) ) (if (<= 1 m n) (progn (setq mc(substr match m 1) mm1(1- m) ) (setq d nil i 0 ); build table of shifts d (while (<(setq i (1+ i))m )(setq d (cons (cons (substr match i 1) (- m i)) d)) ); search match within string (setq i m) (while (<= 1 i n)(setq i(if (or (/= (setq c (substr s i 1)) mc ) (/= (substr s (- i mm1) m) match) ) (+ i (if (setq p (assoc c d)) (cdr p) m ) ) (- mm1 i))); negative value for ending ); return position or nil (if (< i 0)(- i) ) ) ));;; return first position of match in str or nil;;; case-sensitive, no regex, plain substring;;; (std-strpos substr string);;; (std-strpos "" "abc") => 1;;; see boyer-moore by serge pashkov above;;; (improvable by using the knuth-morris-pratt method,;;; backing up optimally?)(defun std-%old-strpos (match s / i1 l1 l2 pos) (setql2 (strlen match)l1 (1+ (- (strlen s) l2))i1 1pos nil ) (if (> l2 0) (while (<= i1 l1) (if (= (substr s i1 l2) match)(setq pos i1 i1 (1+ l1))(setq i1 (1+ i1)) ) ) ) pos);;; case-insensitive std-strpos(defun std-stripos (match s) (std-strpos (strcase match) (strcase s)));;; remove the following for linked vlisp:;;; as the new vlisp function, searches for one integer char;;; zero-based!;;; (std-string-position (ascii "a") "abc") => 0;;; (std-string-position 50 "abc") => nil;;; could be implemented better.(defun std-string-position (i s / pos) (if (setq pos (std-strpos (chr i) s)) (1- pos) ));;; if the substring is the first part of the string line;;; (std-strcmp "debug" "debugging") => t(defun std-strcmp (sub line) (= (substr line 1 (strlen sub)) sub));;; case insensitive(defun std-stricmp (sub line) (std-strcmp (strcase sub) (strcase line)));;; remove the following for linked vl:;;; remove the following for linked vlisp:;;; length of the longest common prefix;;; (std-string-mismatch "std-fun" "std-var") => 4;;; (std-string-mismatch "std-var" "*std-var*") => 0(defun std-string-mismatch (s1 s2 / i l j) (setqj nili 1l (min (strlen s1) (strlen s2) ) ) (while (< i l) (if(= (substr s1 i 1) (substr s2 i 1)) (setq i (1+ i)) (setq j i i (1+ l) ); fixed ) ) (if j (1- j) 0 ));;; (std-strcount substr string) counts substring in string,;;; case-sensitive, no regex!(defun std-strcount (match s / i p lst) (setqi 0lst (strlen match) ) (while (setq p (std-strpos match s)) (setq s (substr s (+ p lst)) i (1+ i) ) ) i; fixed)(defun std-wcimatch (s match) (wcmatch (strcase s) (strcase match)));;;;;; linking is disturbed by double definition, but wcmatch needs;;; acad anyway;;; (if (not (std-acad-connection-p));;; ;; wcmatch needs acad too...;;; (defun std-wcimatch (s match);;; (wcmatch (std-strcase s) (std-strcase match)));;; );;;;;; match in stringlist lst?;;; (member) with (wcmatch) comparison;;; returns the list from the first found match on.;;; see also std-strlist-match which returns all found matches(defun std-strmember (match lst / okay) (if (setq okay (member match lst)); exact match okay; or (progn; try wcmatch (setq okay nil) (while (and lst (not okay) )(if (and (stringp (car lst)); string (wcmatch (car lst) match) ); and matches (setq okay lst); then okay)(setq lst (cdr lst)) ) okay ) ));;; (std-strmember) case insensitive(defun std-strimember (match lst / okay) (if (setq okay (member match lst)); exact match okay; or (progn; try wcmatch (while (and lst (not okay) )(if (and (stringp (car lst)); string (std-wcimatch (car lst) match) ); and matches (setq okay lst); then okay)(setq lst (cdr lst)) ) okay ) ));;; returns all matching elements in string list with wcmatch-comparison;;; like std-strmember but returns only all matching elements.(defun std-strlist-match (match lst / rslt s) (setq rslt nil) (foreach s lst (if(wcmatch s match) (setq rslt (cons s rslt)) ) ) (reverse rslt));;; case insensitive version(defun std-strlist-imatch (match lst / rslt s) (setqrslt nilmatch (std-strcase match) ) (foreach s lst (if(wcmatch (std-strcase s) match) (setq rslt (cons s rslt)) ) ) (reverse rslt));;; also:;;; (defun std-strlist-match (_match lst);;; (std-remove-if-not 'null;;; (mapcar (function (lambda (_s) (if (wcmatch _s _match) _s)));;; lst)));;; or;;; (defun std-strlist-match (s lst / out);;; (while (setq lst (std-strmember s lst));;; (setq out (cons (car lst) out);;; lst (cdr lst));;; );;; (reverse out);;; );;; -------------------------------------------------------------------73;;; conversion ("destructive");;; (std-string-upcase 'str) => str;;; affected by redefinition of std-toupper in stdlocal;;; strcase does not process foreign special 8-bit characters in;;; earlier releases.;;; we use std-strcase instead and provide destructive modification.;;; accepts and modifies symbols, "destructive"(defun std-string-upcase (_$s / _$tmp) (if (= (type _$s) 'sym) (setq _$tmp_$s _$s(std-symbol-value _$s) ) ) (setq _$s (std-strcase _$s)) (if _$tmp (set _$tmp _$s) _$s ));;; (std-string-downcase 'str);;; affected by redefinition of std-toupper in stdlocal;;; strcase does not process foreign special 8-bit characters in;;; earlier releases.;;; accepts and modifies symbols, "destructive"(defun std-string-downcase (_$s / _$tmp _$i) (if (= (type _$s) 'sym) (setq _$tmp_$s _$s(std-symbol-value _$s) ) ) (setq_$s (std-list->string (mapcar(function std-tolower)(std-string->list _$s) ) ) ) (if _$tmp (set _$tmp _$s) _$s ));;; (std-string-capitalize 'str);;; splits strings at defined word boundaries, upcases the first char;;; and lowers the rest.;;; accepts and modifies symbols, "destructive"(defun std-string-capitalize (_$s / _$tmp lst new _seps _ch _up); (std-erro; r "std-string-capitalize is; broken") (if (= (type _$s) 'sym) (setq _$tmp_$s _$s(std-symbol-value _$s) ) ) (setqlst (std-string->list _$s)new nil_up t; fixed_seps (std-string->list " \r\n\t!?\"'\\=+-,.;/\(\)") ) (setq_$s (std-list->string (mapcar(function (lambda (_ch) (cond ((member _ch _seps) (setq _up t) _ch ) (_up (setq _up nil) (std-toupper _ch) ) (t (std-tolower _ch) ) ) ))lst ) ) ) (if _$tmp (set _$tmp _$s) _$s ));;; split a string at word boundaries into lines;;; with maximal length len.;;; fixme: "," is converted to " "(defun std-%line-split (s len / words line lst) (setqwords (std-strtok (std-detab8 s) " \r\n\t,")line "" ) (while words (if(> (strlen line) len) (setq lst (cons (std-str-1 line) lst) line (strcat (car words) " ") ) (setq line (strcat line (car words) " ")) ) (setq words (cdr words)) ) (reverse (cons (std-str-1 line) lst)));;; portable stringification (string-unexpand);;; we provide a unique and transportable way to represent;;; special extended characters not in the ascii character set 0-127;;; internet transport may be 7-bit only. mime-types may be ignored;;; or configured wrong. so we use octal, 3 nums prefixed with "\".;;; unicode and multibyte character strings are represented differently;;; so there should be no problem. (\u+xxxx and \m+nxxxx);;; to be used for expansion with princ (not prin1);;;;;; note on printing and converting:;;; the result of the conversion is not the same as the original string!;;; only the printed result with escape expansion (princ or prompt);;; may be taken as input for strings which internally use the local;;; character table.;;;;;; (setq s (std-%string-8bit->octal "潼哏")) => "\"\\344\\374\\337\\347\"";;; =>;;; (progn (princ s) (prin1)) prints "\344\374\337\347";;; which may be pasted as string or used in external;;; message files portably read in with read-line.;;; 2000-03-15: put double-quotes around "\\..."(defun std-%string-8bit->octal (s) (std-%simple-require "STDMATH") (apply 'strcat (mapcar (function(lambda(i) (if (> i 127); 92 or \134 is thanksfully the same; on pc-dos (ascii) and; latin-1 (ansi) (strcat (chr 92) (std-num->oct i)) (chr i) )) ) (append'(34)(std-string->list s)'(34) ) ) ));;; accepts and modifies symbols, "destructive";;; (defun std-%string-8bit->octal (_$s / _$s1 _$lst _$i _$tmp);;; (if (= (type _$s) 'sym) (setq _$tmp _$s _$s (std-symbol-value _$s)));;; (std-%simple-require "stdmath");;; (setq _$s1 "";;; _$lst (std-string->list _$s));;; (while _$lst;;; (setq _$i (car _$lst);;; _$s1 (strcat _$s1;;; (if (> _$i 127);;; ;; 92 or \134 is thanksfully the same on pc-dos;;; ;; (ascii) and latin-1 (ansi);;; (strcat (chr 92) (std-num->oct _$i));;; (chr _$i)));;; _$lst (cdr _$lst)));;; (if _$tmp (set _$tmp _$s1) _$s1);;; );;;;;; -------------------------------------------------------------------73;;; autolisp workarounds for vlx extensions;;; -------------------------------------------------------------------73;;; tokenizers;;; these might be renamed to the long versions:;;; std-string-tokenize, std-string-split and std-string-join;;; converts string with delimiters into string list;;; ignore repeated delims such as white space.;;; the order of chars in delim is not important.;;; might be renamed to std-string-tokenize;;; also named lex-string in some common lisps.;;; (std-strtok " 2 3 " " ") => ("2" "3");;; (std-strtok "f 1,3" ", ") => ("f" "1" "3");;; same as std-string->strlist(defun std-strtok (s delims / len s1 i c lst) (setqdelims (std-string->list delims)len (strlen s)s1 ""i (1+ len) ) (while (> (setq i (1- i)) 0 ) (setq c (substr s i 1)) (if(member (ascii c) delims) (if (/= s1 ""); no null tokens(setq lst (cons s1 lst) s1 "") ) (setq s1 (strcat c s1)) ) ) (if (/= s1 "") (cons s1 lst); no ("" "1" "2")! lst ));;; the order of chars in delim is not important.;;; keeping null tokens, not as with std-strtok.;;; might be renamed to std-string-split;;; by vladimir nesterowsky(defun std-strsplit (s delims / len s1 i c lst) (setqdelims (std-string->list delims) ; fixedlen (strlen s)s1 ""i (1+ len) ) (while (> (setq i (1- i)) 0 ) (setq c (substr s i 1)) (if(member (ascii c) delims) (if (/= i len); "1,2," -> ("1" "2") and not ("1"; "2" "")(setq lst (cons s1 lst) s1 "") ) (setq s1 (strcat c s1)) ) ) (cons s1 lst); ",1,2" -> ("" "1" "2"));;; joins strings from list together again.;;; takes all types and converts them to strings (safer).;;; opposite to std-strsplit.;;; might be renamed to std-string-join;;; (std-strjoin '("1" "2" "3") ",") => "1,2,3";;; (std-strjoin '(1 2 3) ",") => "1,2,3"(defun std-strjoin (lst _delim) (cond ((std-string-list-p lst) (substr (apply (function strcat); force strings (mapcar (function (lambda (s) (strcat _delim s) ) ) lst ) ) (1+ (strlen _delim)) ) ) (t; (if (not std-princ-to-string) ; vl; optimizer (std-%simple-require "STDLISP"); ) (substr (apply (function strcat); force strings (mapcar (function (lambda (s) (strcat _delim (std-princ-to-string s)) ) ) lst ) ) (1+ (strlen _delim)) ) ) ));;; converts string with "delimiters into string list";;; ignore repeated delims such as white space, ",,2,3,," -> '("2" "3");;; (std-string->strlist "f 1,3" ", ") -> ("f" "1" "3");;; same as std-strtok.;;; this name is questionable and may be removed from the release version(defun std-string->strlist (s delims) (std-strtok s delims));;; "comma list into string list";;; needs only one argument, the string, to be mappable.;;; "init,init.log" -> '("init" "init.log");;; ",,2,3,," -> '("" "" "2" "3" "" "")(defun std-csstring->strlist (s) (std-strtok s ",\t "));;; (defun std-csstring->strlist (s / p lst);;; (setq lst nil);;; (while (setq p (std-strpos "," s));;; (setq lst (cons (substr s 1 (1- p)) lst);;; s (substr s (1+ p));;; );;; );;; (setq lst (cons s lst));;; (reverse lst);;; );;; this is similar to std-strjoin, but more type restrictive(defun std-strlist->string (strlst _delim) (substr (apply (function strcat); force strings (mapcar (function(lambda(s) (strcat _delim s)) ) strlst ) ) (1+ (strlen _delim)) ));;; "stringlist to comma seperated string";;; needs only one argument, the list, to be mappable(defun std-strlist->csstring (lst) (std-strlist->string lst ","));;; "stringlist to space seperated string" as for dcl list tiles;;; needs only one argument, the list, to be mappable(defun std-strlist->dclstring (lst) (std-strlist->string lst " "));;; "space seperated string to stringlist" as for dcl list tiles;;; needs only one argument, the string, to be mappable(defun std-dclstring->strlist (s) (std-strtok s "\t "));;; -------------------------------------------------------------------73;;; formatting:;;; destructive versions must not use typical symbol names to avoid;;; binding conflicts: std-strcenter and std-string-remove-comments;;; most of it is defined in vlisp also.;;; remove leading characters in baglist(defun std-string-left-trim (bag s) (setq bag (std-string->list bag)) (while (and (/= s "") (member (ascii (substr s 1 1)) bag) ) (setq s (substr s 2)) ) s);;; remove terminating characters in baglist(defun std-string-right-trim (bag s / lst) (setq bag (std-string->list bag)) (while (and (/= s "") (member (ascii (std-lastchar s)) bag) ) (setq s (std-str-1 s)) ) s)(defun std-string-trim (bag s) (std-string-left-trim bag (std-string-right-trim bag s)));;; remove leading and following whitespace(defun std-trim(s) (std-string-trim " \t\n\r" s));;; returns or modifies a string without inline and end of;;; line comments ";";;; inside strings don't remove it!;;; preserve "(test \"test\")";;; accepts and modifies symbols, "destructive"(defun std-string-remove-comments (_$s / i j _$tmp _evenp) (if (= (type _$s) 'sym) (setq _$tmp_$s _$s(std-symbol-value _$s) ) ) (defun _evenp(n) (zerop (rem n 2)) ) (if (and(setq i (std-strpos "\;\|" _$s))(setq j (std-strpos "\|\;" (substr _$s i)))(and (_evenp (std-strcount "\"" (substr _$s 1 i))) ; \" (_evenp (std-strcount "\"" (substr _$s j)))) ) (setq _$s (strcat (substr _$s 1 (1- i)) (substr _$s (+ 1 i j)))) ) (if (and(setq i (std-string-position 59 _$s)) ; ";"(/= "\|" (substr _$s (+ 2 i) 1)) ; "" v0.3020(and (_evenp (std-strcount "\"" (substr _$s 1 i))) (or (zerop i) (_evenp (std-strcount "\"" (substr _$s i))) )) ) (setq _$s (substr _$s 1 i)) ) (if _$tmp (set _$tmp _$s) _$s ));;; fill string on the right side with char up to length n;;; longer strings are ignored, not cut(defun std-string-right-pad-char (s n char) (while (< (strlen s) n) (setq s (strcat s char)) ); (substr s 1 n) s);;; fill string on the left side with char up to length n;;; longer strings are ignored, not cut(defun std-string-left-pad-char(s n char) (while (< (strlen s) n) (setq s (strcat char s)) ); (substr s 1 n) s);;; right padding, cuts string or fills string rightwise with spaces.;;; name from intellicad(defun std-rpad(s n) (while (< (strlen s) n) (setq s (strcat s " ")) ) (substr s 1 n));;; left padding, cuts string or fills string leftwise with spaces;;; name from intellicad(defun std-lpad(s n) (while (< (strlen s) n) (setq s (strcat " " s)) ) (substr s 1 n));;; center string s to length len;;; accepts and modifies symbols, "destructive"(defun std-strcenter (_$s len / i _$tmp) (if (= (type _$s) 'sym) (setq _$tmp_$s _$s(std-symbol-value _$s) ) ) (setq_$s (if(> (setq i (- len (strlen _$s))) 0) (strcat (std-rpad " " (/ (- len (strlen _$s)) 2)) _$s) _$s ) ) (if _$tmp (set _$tmp _$s) _$s ));;; -------------------------------------------------------------------73;;; miscellaneous: replace;;; change every occurance of old in string s to new, iterative version.;;; no regular expressions, just a simple case-sensitive substring;;; replacement. see also std-string-subst;;; check for degenerate case when old="" => add only first new(defun std-strchg (s old new / i ls lold) (if (= old "") (strcat new s) (progn (setq lold (strlen old); length of substr to search ls (1+ (- (strlen s) lold)) ; max. position to search to i 1 ) (while (<= i ls)(if (= (substr s i lold) old); found (setqs (strcat (if (> i 1) (substr s 1 (1- i)) "" ) new (if (<= i ls) (substr s (+ i lold)) "" ) )i (+ i (strlen new)) ); next position to search (setq i (1+ i))) ) s ) ));;; using subst-alike argument ordering, changes only the first;;; occurance of old to new (not as subst).;;; this is to match vl-string-subst which works this way.;;; degenerate case when old="" works okay(defun std-string-subst(new old s / i ls lold) (setqlold (strlen old); length of substr to searchls (1+ (- (strlen s) lold)); max. position to search toi 1 ) (while (<= i ls) (if(= (substr s i lold) old); found (setq s (strcat (if (> i 1)(substr s 1 (1- i))"" ) new (if (<= i ls)(substr s (+ i lold))"" ) ) i (1+ ls) ); quit loop (setq i (1+ i)) ) ) s);;; replace all occurances of some characters in a string.;;; same as vl-string-translate;;; (std-string-translate "abcdefgh" "abcdefgh" "my house is yellow");;; => "my house is yellow"(defun std-string-translate (old new _s / _o _n) (mapcar (function (lambda (_o _n)(setq _s (std-strchg _s (chr _o) (chr _n))) ) ) (std-string->list old) (std-string->list new) ) _s);;; beta - "string wildcard replace";;; in string, replace occurences matching regexp with replacement,;;; count times. if count is nil, replace all.;;;;;; very slow and limited, using the weird wcmatch syntax, compared;;; to regex. we should better write a more perl-style replacer.;;; this syntax is familiar to wcmatch users, similar to shell globbing.;;;;;; special replacements characters:;;; $< pre-match $& match $> post-match;;; %< delete to left % delete %> delete to right;;; ^ set cursor (not yet);;; no grouping by (), so we have no positional matches: $1, $2, ...;;;;;; option:;;; e eval functions in replacement;;; i case insensitive (not yet);;; cnum count num, replace the first num matches;;; x maximal matches rather than minimal. longest found substring.;;;;;; examples:;;; (std-string-wc-replace "l:/src/stdlib/stdstr.lsp";;; "src*/" "new$&" nil) => "l:/newsrc/stdlib/stdstr.lsp";;; (std-string-wc-replace "l:/src/stdlib/stdstr.lsp";;; "/src*/" "%>\\$&\\%<" nil) => "l:\\src\\stdlib/stdstr.lsp";;; (std-string-wc-replace "l:/src/stdlib/stdstr.lsp";;; "l*`." '(std-strcase $&) "ec10") => "l:/src/stdlib/stdstr.lsp"(defun std-string-wc-replace (s regexpreplacement option /i l len newcount $& $< $>expand-p eval-p case-p max-pnotend-p ) (if (and(stringp option)(setq case-p (std-strpos "i" option)) ) (setq regexp (std-strcase regexp)) ) (if (if case-p(wcmatch (std-strcase s) (strcat "*" regexp "*"))(wcmatch s (strcat "*" regexp "*")) ) (progn; options (if (stringp replacement)(setq expand-p (or (= "$" (std-firstchar replacement)) (wcmatch replacement "*[~``]$[&``']*") )) ); no `$& (if (stringp option)(progn (setq eval-p (std-strpos "e" option)) (if (setq i (std-strpos "c" option)) (setq count (atoi (substr option (1+ i)))) ); (if (setq case-p (std-strpos "i"; option)); (setq regexp (std-strcase; regexp))) (setq max-p (std-strpos "x" option))) ) (if (or (null count) (zerop count) )(setq count 32767) ); expand the substring from left; until we find a match; i: cursor position, l: cursor; length (setq i1 len(strlen s) ); (if max-p ; end predicate; l is the length of the matched; substring; (defun notend-p () (>= l 1)); (defun notend-p () (< l len))) (while (and (< i len) (> count 0) ); on "x" minimize from right to; left, find the longest match; without x expand from left to; right, find the shortest match(setq l(if max-p (1+ (- len i)) 1))(while (and (not (if case-p(wcmatch (std-strcase (substr s i l)) regexp)(wcmatch (substr s i l) regexp) ) ) (if max-p (>= l 1) (< l len) ) ) (setql (if max-p (1- l) (1+ l) ) ))(if (and (if max-p(>= l 1)(< l len) ) (> count 0) ); found (progn; bind pseudovariables (setq $< (substr s 1 (1- i)) ; pre-match $& (substr s i l); match $> (substr s (+ i l)) ); post-match (ifeval-p; expand pseudovariables in function (if (stringp replacement)(if (and (= "(" (std-firstchar replacement)) (not (std-strpos "(" (substr replacement 2))) ; ) (= ")" (std-lastchar replacement)) ) (setq new (eval (read replacement))) ; fixme: only; not-nested "splice"; "..(..()).." will fail (setq new (std-%string-splice-wc replacement)))(setq new (eval replacement)) ); no "e": expand the string below (setq new replacement) ); "%.." delete-at-front: eat; pre-match or match? (while (= "%" (std-firstchar new)) (cond((= ">" (substr new 2 1)) ; "%>..." eat match (setq $& (substr $& 2) new (substr new 3) ))((= "<" (substr new 2 1)) ; "%<..." eat pre-match (setq $< (std-str-1 $<) new (substr new 3) ))(t (setq $< (std-str-1 $<) ; "%..." eat pre-match new (substr new 2) )) ) ); "..%" delete-at-end: (while (and (= "%" (std-lastchar new)) (/= "`" (std-lastchar (std-str-1 new))) ); unquoted (setq $>(substr $> 2); "...%" eat post-match new(std-str-1 new) ) ); "..%[<>]" delete-at-end: (while (or (wcmatch new "*[~``]%[<>]") (wcmatch new "%[<>]") ) (cond((= "%<" (std-lastchars 2 new)) ; "...%<" eat match (setq $& (std-str-1 $&) new (std-str-n 2 new) ))((= "%>" (std-lastchars 2 new)); "...%>" eat post-match (setq $> (substr $> 2) new (std-str-n 2 new) )) ) ); "..%.." a delete inside; replacement is not expanded (ifexpand-p; expand pseudovariables in string; wcmatch supports no grouping (),; so we have no $1, $2, ...; fixme: quote $ with `$ (setq new(std-strchg new "$&" $&); fixme: quoted specials! new(std-strchg new "$<" $<) ; pre-match new(std-strchg new "$>" $>) ; post-match ) ); (std-debug-print (list "$& \"" $&; "\" => \"" new "\"\n")) (setq s(strcat $< new $>) i(1+ (strlen (strcat $< new))) ; new cursor count(1- count) len(strlen s) ) ); else not found (setq i (1+ i))) ) s ) s ));;; eval each function in the string and strcat the results;;; $< $& and $> are bound;;; (setq $& "match" s "pre(strcase (substr $& 1 1))(substr $& 2)post");;; (setq $& "match" s "pre(strcase $&)(substr $& 2)post");;; (std-%string-splice-wc s) =>;;; warning: no nested functions yet!(defun std-%string-splice-wc (s / i new) ; (std-warn; "std-string-wc-replace: no function; splice yet.") (setq new "") (while (setq i (std-strpos "(" s)) (setq new (strcat new (substr s 1 (1- i)) ; pre (eval (read (substr s i))) ); func s (substr s (1+ (std-strpos ")" s))) ) ); error handling?; the rest (setq new (strcat new s)) new);;; convert free spaces in a string to tabs, modulo n, see std-entab8;;; "x x1" -> "x<tab>x1";;; 1 9;;; not destructive, fixed by serge pashkov(defun std-entab (s n / c i len p sn _$tmp ie); (if (= (type s) 'sym) (setq; _$tmp s s (std-symbol-value s))) (setqsn ""p nili 1ie 0len (strlen s) ); p: first space; ie - effective position - takes; into account possible \t character (while (<= i len) (if(= (setq c (substr s i 1)) " ") (progn(if (not p) (setq p i))(if (= (setq ie (rem (1+ ie) n)) 0 ); fixed (setqsn (strcat sn (if (< p i) "\t" c ) ); fixedp nil )) ) (setq sn (if (and p (/= c "\t") ) (strcat sn (substr s p (1+ (- i p)))) (strcat sn c) ) ie (if (= c "\t") 0 (1+ ie) ) p nil ) ) (setq i (1+ i)) ); (if _$tmp (set _$tmp sn) sn) sn);;; useful default, insert tabs at every 8th place(defun std-entab8 (s) (std-entab s 8));;; std-detab convert tabs to spaces, modulo n;;; "x<tab>x1" -> "x x1";;; 1 8;;; not destructive, fixed by serge pashkov(defun std-detab (_$s n / i _$tmp); (if (= (type _$s) 'sym) (setq _$tmp; _$s _$s (std-symbol-value _$s))) (while (setq i (std-strpos "\t" _$s)) (setq _$s (strcat (substr _$s 1 (1- i)) (std-rpad""(- n (rem (1- i) n )) ); fixed (substr _$s (1+ i)) ) ) ); (if _$tmp (set _$tmp _$s) _$s) _$s);;; useful default, replaces tabs assuming modulo 8(defun std-detab8 (s) (std-detab s 8));;; removes extension from string;;; needed for (std-load-external "fileext.fas");;; this will not work with dots in directory names!;;; something like std-rposition should be used instead then.(defun std-%string-without-dots(s / i) (if (setq i (std-strpos "." s)) (substr s 1 (1- i)); fixed s ));;; "rtos to the max" without "ads connection to acad" (acad independent);;; rtos with maximal digit accuracy. try it with the largest number of;;; fractional digits. if the fix conversion does not allow this number,;;; try it with less digits accuracy.(defun std-rtos(r / n s) (if (std-acad-connection-p) (progn (std-var-push'(("DIMZIN" . 8 ) ) ) (setq s (rtos r 2 14)) (std-var-pop) s ) (progn (std-%simple-require "STDMATH") (setq n 14) (while (and (>= n 0) (not (setq s (std-%rtos-n r n))) )(setq n (1- n)) ) (setq s (if (std-strpos "." s)(std-string-right-trim "0" s)s ) ) (if (= (std-lastchar s) ".")(strcat s "0")s ) ) ));;; rtos to n digits or nil if n is too high,;;; (if the fractional part is too large)(defun std-%rtos-n (r n / x sign) (cond ((and (> r 2147483647) (std-acad-connection-p) ) (rtos r 2 n) ); fractional part too big?; expt is completely broken in; larger numbers, so we have; to use std-expt and load; stdmath... ((eq 'real (type (setq x (fix (* (std-expt 10 n) (- r (fix r)))))) ) nil ); to break loop in std-rtos; integer still too big so that itoa; will fail.; we have problems with overlarge; reals which fail above; but would not fail with lower n ((> (abs r) 2147483647); print number by number to avoid; exponential printing (setq signr r(abs r) ) (setq x (if (zerop (- r (fix r))) "" (substr (std-rtos (- r (fix r))) 1) ) ); mimic itoa... (setq r (fix r)) (while (> r 0) (setq x (strcat (itoa (fix (rem r 10))) x) r (/ r 10) ) (if (and (eq (type r) 'real) (< r 2147483647) ) (setq r (fix r)) ) ) (if (minusp sign) (strcat "-" x) x ) ) (t (strcat (itoa (fix r)) "." (std-string-left-pad-char (itoa x) n "0") ) ) ));;; creates a string of n chars with default value def;;; (std-make-string 10 " ")=> " ";;; (std-make-string 2 ":")=> "::";;; def is coerced to a string.;;; support dynamic defaults from functions like:;;; (std-make-string 100 (lambda () (std-random 10)));;; => 100 random digits;;; don't create n times def then, only the string of length n(defun std-make-string (n _def / s); like std-make-list (setq s "") (substr (cond ((std-functionp _def); (if (not std-princ-to-string) (std-%simple-require "STDLISP") ; ) (while (< (strlen s) n) (setq s (strcat s (std-princ-to-string (apply _def nil ) ) ) ) ) ) ((stringp _def) (while (< (strlen s) n) (setq s (strcat s _def)) ) ) (t; (if (not std-princ-to-string) (std-%simple-require "STDLISP") ; ) (while (< (strlen s) n) (setq s (strcat s (std-princ-to-string _def))) ) ) ) 1 n ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdstr-symbols*))(setq *stdstr-symbols* nil);;; module dependencies
std-%simple-provide "STDSTR");;; provide it;;; removed all ad hoc dependencies;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdlist.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:33:04 rurban>;;; copyright (c) 1991,1998,1999 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; list functions for the stdlib;;; status:;;; tested and stable.;;; added std-setnth, std-rplace is depricated and will be removed.;;; std-%every-n and std-%some-n don't work yet.;;; points moved to seperate stdpoint module.;;; sets and esp. std-intersection are incorrect with duplicates.;;; recursive functions are almost completely replaced by iterative ones;;; not to crash on large lists. (stability);;; std-position takes no strings => std-string-position;;; std-centroid moved to stdpoint and renamed to geom-centroid2d;;; added every and some functionality;;;;;; there's no function to search for a list in a list.;;; you might want to try;;; http://xarch.tu-graz.ac.at/autocad/lisp/whmatch.lsp;;; $log: stdlist.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-10-02 14:23:34 rurban;;; improved std-randomize (fisher-yates algorithm);;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;; 2000-04-14 16:56:00 rurban;;; added (std-setnth new i lst);;;;;; ===================================================================73;;; avoid reload warnings in vl(if std-%unprotect-assign (std-%unprotect-assign (setq *stdlist-symbols*; (eval (list 'pragma; (list 'quote; (list (cons; 'unprotect-assign '(first second third fourth fifth sixth seventh eighth ninth tenth rest std-dotted-pair-p std-not-proper-list-p std-list-length std-string-list-p std-number-list-p std-position-if std-position-if-not std-rposition std-rassoc std-nthcdr std-firstn std-subseq std-butlast std-elt std-select std-setnth std-rplace std-delpos std-adjoin std-remove-duplicates std-split-list std-flatten std-rotate-right std-rotate-left std-push std-pushnew std-pushmax std-pop std-mapatom std-every std-every-n std-some std-some-n std-intersection std-set-difference std-union std-ordered-union std-set-exclusive-or std-subsetp std-set-equal-p std-int-list std-make-list std-iseq std-rseq std-nxtcyc std-count std-count-if std-count-if-not std-stable-sort std-merge std-copy-tree std-randomize std-random-elt std-random-pt ) ) ));;; )));;; first - first element of the list(defun first (x) (car x));;; rest - the rest of the list(defun rest (x) (cdr x));;; other readable accessors, the element or nil, better than nth(defun second (lst) (cadr lst))(defun third (lst) (caddr lst))(defun fourth (lst) (cadddr lst))(defun fifth (lst) (car (cddddr lst)))(defun sixth (lst) (cadr (cddddr lst)))(defun seventh (lst) (caddr (cddddr lst)))(defun eighth (lst) (cadddr (cddddr lst)))(defun ninth (lst) (car (cddddr (cddddr lst))))(defun tenth (lst) (car (cdr (cddddr (cddddr lst)))));;; (std-%cond-defun;;; '(defun consp (lst) (not (atom lst)));;; );;; or;;; (defun consp (lst) (and lst (listp lst)))(defun std-dotted-pair-p (lst) (and (consp lst) (not (listp (cdr lst))) ));;; this definitely has to converted to iteration!;;; but (std-dotted-pair-p (last lst)) will fail!;;; iterative version;;; checks if the last cons cell is dotted or not.;;; improvement over the highly-recursive version above, loops to the;;; last cons (last is forbidden!) and checks this.;;; not-proper-lists will fail ("bad list" error) with:;;; member, length, last, foreach, apply, mapcar, reverse, ...;;;;;; (std-not-proper-list-p '(0 1 2)) => nil;;; (std-not-proper-list-p '(0 0 0 . 1)) => t;;; but (std-not-proper-list-p '(0 . '(0 0 1))) => nil;;; because it is read as '(0 0 0 1);;; (std-not-proper-list-p 0) => nil(defun std-not-proper-list-p (lst) (if (consp lst) (progn (while (and lst (listp (cdr lst)) )(setq lst (cdr lst)) ) (std-dotted-pair-p lst) ) ));;; (std-list-length 1) => nil;;; (std-list-length nil) => 0;;; (std-list-length '(0 1 2 0 1)) => 5;;; (std-list-length '(0 1 2 0 . 1)) => 4;;; (std-list-length '(0 1 2 (0 . 1))) => 4;;; (std-list-length '(0 1 2 0 . (1))) => 5(defun std-list-length (lst / l) (cond ((null lst) 0 ) ((atom lst) nil ) (t (setq l 1) (while lst (if (atom (cdr lst)) (setq lst nil l l ) (setq lst (cdr lst) l (1+ l) ) ) ) ) ))(defun std-string-list-p (lst) (and (consp lst); a cons? (not (std-not-proper-list-p lst)) (<= (length lst) *max-args-limit*) (apply (function and) (mapcar(function stringp)lst ) ) ))(defun std-number-list-p (lst) (and (consp lst); a cons? (not (std-not-proper-list-p lst)) (<= (length lst) *max-args-limit*) (apply (function and) (mapcar(function numberp)lst ) ) ));;; std-position - returns the index of the first element in the list,;;; base 0, or nil if not found;;; (std-position x '(a b c)) => nil;;; (std-position b '(a b c d)) => 1;;; ansi cl supports strings too but vl not. if we want to support;;; strings, then the workaround is not just a simple;;; (setq std-position vl-position) anymore;;; ? (std-position (ascii "t") "test") => 3 ; zero based!;;; or (std-position "t" "test") => 3 ; zero based!;;; vlx-position was introduced with vill 3.0;;; see also: std-string-position which searches for an intchar;;; and is zero-based.(if (not std-position) (defun std-position (x lst / ret); (cond ((stringp lst); (std-string-position (if; (stringp x) (ascii x) x) lst)); (t (if(not (zerop (setq ret (length (member x lst))))) (- (length lst) ret) ); )) ));;; -------------------------------------------------------------------73;;; autolisp workarounds for vlx extensions(if (listp (lambda () t ) ) (progn; (std-member-if pred lst); pred requires exactly 1 arg, by; serge pashkov; (std-member-if 'numberp '(b a 2; 3)) -> (2 3) (defun std-member-if (pred lst) (while (and lst (not (apply pred (list (car lst)) ) ) )(setq lst (cdr lst)) ) lst ); highly recursive, may fail on; large lists!; (std-member-if-not pred lst); pred requires exactly 1 arg, by; serge pashkov; (std-member-if-not 'numberp '(b; a 2 3)) -> (b a 2 3) (defun std-member-if-not (pred lst) (while (and lst (apply pred (list (car lst)) ) )(setq lst (cdr lst)) ) lst ); highly recursive, may fail on; large lists!; std-remove - removes all items; from a list, also all duplicate; elements; (std-remove 0 '(0 1 2 3 0)) ->; (1 2 3) (defun std-remove (ele lst); by serge volkov, tony also claims; (if (> (length lst); *max-args-limit*) ;; authorship for this; (std-error (std-msg "maximal; number of arguments exceeded")); fcad fails with (subst x y nil) (if lst(apply (function append) (subst nil (list ele) (mapcar (function list) lst ) )) ) ); ); (std-remove-if pred lst) -; conditional remove; pred requires exactly 1 arg (defun std-remove-if (_pred lst); (if (> (length lst); *max-args-limit*); (std-error (std-msg "maximal; number of arguments exceeded")) (apply(function append)(mapcar (function (lambda (e) (if (not (apply _pred (list e) ) )(list e) ) ) ) lst) ) ); ); std-remove-if-not - keeps all; elements to which the predicate; returns not-nil, say: "keep if"; pred requires exactly 1 arg (defun std-remove-if-not (_pred lst) ; by vladimir nesterowsky; (if (> (length lst); *max-args-limit*); (std-error (std-msg "maximal; number of arguments exceeded")) (apply(function append)(mapcar (function (lambda (e) (if (apply _pred (list e) )(list e) ) ) ) lst) ) ); ) ));;; eof vl list workarounds;;; -------------------------------------------------------------------73;;; (std-position-if 'numberp '(0 1 2 3)) => 0(defun std-position-if (pred lst / ret) (if (not (zerop (setq ret (length (std-member-if pred lst))))) (- (length lst) ret) ));;; (std-position-if-not 'stringp '("0" "1" 2 "3")) => 2(defun std-position-if-not (pred lst / ret) (if (not(zerop (setq ret (length (std-member-if-not pred lst)))) ) (- (length lst) ret) ));;; std-rposition returns the index of the last found element or nil;;; (std-rposition 2 '(2 1 2 3)) => 2(defun std-rposition (x lst / ret) (if (setq ret (member x (reverse lst))) (1- (length ret)) ))(defun std-rassoc (key alst / i) (if (setq i (std-positionkey(mapcar (function cdr) alst) ) ) (nth i alst) ));;; "list behind (including) the nth element";;; (std-nthcdr 1 '(0 1 2 3) => '(1 2 3);;; o(i)(defun std-nthcdr (i lst) (repeat i (setq lst (cdr lst)) ) lst; fixed);;; "list of first n elements", iterative version;;; with safety check:;;; (std-firstn 1 '(0 1 2)) => '(0);;; (std-firstn 0 '(0 1 2)) => nil;;; (std-firstn 4 '(0 1 2)) => '(0 1 2);;; o(n+i) if i<n, o(2n) if i>=n(defun std-firstn (i lst / out) (setq out nil); possible vl lsa compiler bug (repeat (min i (length lst) ) (setq out (cons (car lst) out) lst (cdr lst) ) ) (reverse out));;; without safety check, only usable internally;;; (std-%firstn 4 '(0 1 2)) => '(0 1 2 nil);;; o(i) even if i>n(defun std-%firstn (i lst / out) (setq out nil); possible vl lsa compiler bug (repeat i (setq out (cons (car lst) out) lst (cdr lst) ) ) (reverse out));;; slower version:;;; o(4n+i);;; std-subseq - subsequence including start excluding end;;; (std-subseq '(0 1 2 3) 1 3) => '(1 2)(defun std-subseq (lst start endp) (if (<= 0 start endp (length lst)); fixed (std-firstn (- endp start) (std-nthcdr start lst)) (std-error (list "STD-SUBSEQ: " (std-msg "index out of range") " - " start " " endp ) ) ));;; (std-butlast lst) - list without (last lst);;; iterative version(defun std-butlast (lst) (reverse (cdr (reverse lst))));;; recursive version;;; safe nth version with reverse order of arguments;;; throws an index out of range error.;;; nth throws just a bad argument type error;;; (from lisp);;; (std-elt '(0 1) 0) => 0;;; (std-elt lst -1) => error;;; (std-elt lst (length lst)) => error(defun std-elt (lst i) (if (< -1 i (length lst)); fixed (nth i lst) (std-error (list "STD-ELT: " (std-msg "index out of range") " - " i) ) ));;; std-select is nth expanded for multiple indices. (from xlisp-stat);;; (std-select lst '(0 2 4)) or (std-select lst 0)(defun std-select (lst i / x) (cond ((numberp i) (std-elt lst i) ) ((consp i) (while i; looping over i is faster than; mapping over lst (setq x (cons (std-elt lst (car i)) x) i (cdr i) ) ) (reverse x) ) ));;; std-setnth - replace by position, 0 based;;; if the index is invalid return the unchanged list.;;; (sorry, this changed v0.3003)(defun std-setnth (new i lst) (std-%setnth (list new) i lst));;; depricated, same as std-setnth, only reversed argument ordering;;; std-rplace - replace by position, 0 based. will be removed soon.;;; this was a bad name. the argument ordering was also;;; questionable: possible is also (std-rplace new i lst) as in subst;;; (std-setnth new i lst) or (std-nth<- new i lst);;; (std-rplace '(0 1 2) 0 'new) => (new 1 2) but;;; (std-rplace '(0 1 2) 3 'new) => (0 1 2)(defun std-rplace (lst i new) (std-%setnth (list new) i lst));;; std-delpos - list without i-th element;;; (std-delpos 2 '(0 1 2)) => (0 1);;; (std-delpos 4 '(0 1 2)) => (0 1 2);;; expanded for multiple indices:;;; (std-delpos '(2 1) '(0 1 2 3)) => (0 3)(defun std-delpos (i lst / new n j) (if (listp i) (progn (setq i(std-fast-sort i '<) new'() j0 ) (foreach n i(setq new (cons (- n j) new) j (1+ j)) ) (foreach i (reverse new)(setq lst (std-%setnth nil i lst)) ) lst ) (std-%setnth nil i lst) ));;; fast helper for delpos and rplace by serge pashkov.;;; the new argument must be a list!;;; improved by daniele piazza, who thanks fausto azzoni. ~45% faster.;;; avoid firstn and nthcdr, loop only once through the list.;;; tests shows that actual gain is near 3 times at n << n,;;; 2 times at (n-n) << n and no gain when n ~ n/2 to the old;;; versions below.;;; "very weak recursive", worst for elements in the middle.;;; stack-overflow at about 2^stack-size (~log n) which is;;; practically infinite: (std-expt 2 994) => 1.67423e+299(defun std-%setnth (new i lst / fst len) (cond ((minusp i) lst ) ((> i (setq len (length lst))) lst ) ((> i (/ len 2)) (reverse (std-%setnth new (1- (- len i)) (reverse lst))) ) (t (append (progn (setq fst nil); ; possible vl lsa compiler bug (repeat (rem i 4) (setq fst (cons (car lst) fst) lst (cdr lst) ) ) (repeat (/ i 4) (setq fst (cons (cadddr lst) (cons (caddr lst) (cons (cadr lst) (cons (car lst) fst ) ) ) ) lst (cddddr lst) ) ) (reverse fst) ) (if (listp new) new (list new) ); v0.4001 (cdr lst) ) ) ));;; std-adjoin - cons if not in list;;; (std-adjoin 0 '(1 2)) => (0 1 2)(defun std-adjoin (x lst) (if (member x lst) lst (cons x lst) ));;; by serge pashkov;;; the below mentioned lsa compiler bug couldn't be isolated yet.(defun std-remove-duplicates (lst / ele new) (setq new nil); possible vl lsa compiler bug (??) (foreach ele lst (if(not (member ele new)) (setq new (cons ele new)) ) ) (reverse new));;; removed: v0.3015;;; std-append-join appends only new elements from new to old,;;; like append but only elements which are not already in old.;;; use std-ordered-union instead.;;; (std-append-join '(0 1 2) '(2 3)) => (0 1 2 3);;; (defun std-append-join (_old new);;; (append _old (std-remove-if;;; (quote ;);;;;;; (lambda (x);;; (member x _old)));;; new)));;; std-split-list splits list into sublists of maximal length n;;; n must be > 0!;;; iterative version by serge pashkov, safer than recursive version;;; (std-split-list 2 '(1 2 3 4 5 6)) => ((1 2) (3 4) (5 6))(defun std-split-list (n lst / ret out cnt) (setq ret nil); possible vl lsa compiler bug; adjust cnt to set incomplete; number of elements (if any) for the; last segment (setqcnt (- n (rem (length lst) n))lst (reverse lst) ) (while lst (setq ret (cons (car lst) ret) lst (cdr lst) ) (if(zerop (rem (setq cnt (1+ cnt)) n )) (setq out(cons ret out) retnil ) ) ) (if ret (cons ret out) out ));;; recursive version by serge volkov;;; flattens a tree to a plain list, by serve pashkov;;; iterative version, also processes not-proper-lists.;;; (std-flatten '((1 2 3 (3 4)))) => (1 2 3 3 4)(defun std-flatten (lst / pend new curr) (cond ((null lst) nil ) ((atom lst) lst ) (t (setq pendlst newnil ) (while pend (if (atom pend); for processing '(1 2 . 3) (setq curr pend pend nil ) (setq curr (car pend) pend (cdr pend) ) ) (while (consp curr) (if (cdr curr) (setq pend (cons (cdr curr) pend)) ) (setq curr (car curr)) ); now curr is atom (setq new (cons curr new)) ) (reverse new) ) ));;; old, wrong and highly recursive, may fail on large lists!;;; std-rotate-right rotates a list rightwise;;; put the last element to the front, 2x slower;;; (std-rotate-right '(0 1 2 3)) => '(3 0 1 2)(defun std-rotate-right(lst) (cons (last lst) (std-butlast lst)));;; std-rotate-left rotates a list leftwise;;; put the first element to the end, 2x faster;;; (std-rotate-left '(0 1 2 3)) => '(1 2 3 0)(defun std-rotate-left (lst) (append (cdr lst) (list (car lst)) ));;; the following local symbols may look obfuscated. it is to prevent;;; binding of symbols with the same name.;;; all symbols in functions which call eval and which requires symbol;;; values not defined locally should use special prefixes (here "_$");;; not to harm earlier defined symbols. (prevent "shadowing");;; to: lst or 'lst;;; returns new stack;;; (std-push 1 '(2 3)) -> (1 2 3)(defun std-push(_$what _$lst / _$tmp) (if (= (type _$lst) 'sym) (setq _$tmp_$lst _$lst(std-symbol-value _$lst) ) ) (setq _$lst (cons _$what _$lst)) (if _$tmp (set _$tmp _$lst) _$lst ));;; stack argument may be quoted: lst or 'lst;;; returns new stack.;;; (std-pushnew 1 '(2 3)) => (1 2 3);;; (std-pushnew 1 '(1 2 3)) => (1 2 3)(defun std-pushnew (_$what _$lst / _$tmp) (if (= (type _$lst) 'sym) (setq _$tmp_$lst _$lst(std-symbol-value _$lst) ) ) (setq _$lst (std-adjoin _$what _$lst)) (if _$tmp (set _$tmp _$lst) _$lst ));;; with maximal stack size;;; to: lst or 'lst;;; returns new stack;;; (std-pushmax 1 '(2 3 4 5) 4) -> (1 2 3 4)(defun std-pushmax (_$what _$lst nmax / _$tmp) (if (= (type _$lst) 'sym) (setq _$tmp_$lst _$lst(std-symbol-value _$lst) ) ) (if (>= (length _$lst) nmax) (setq _$lst (reverse (cdr (reverse _$lst)))) ) (setq _$lst (cons _$what _$lst)) (if _$tmp (set _$tmp _$lst) _$lst ));;; to: lst or 'lst;;; returns what if sym or new stack;;; (setq lst '(1 2 3));;; (std-pop lst) -> (2 3), lst = (1 2 3);;; (std-pop 'lst) -> 1, lst = (2 3)(defun std-pop (_$lst / _$what _$tmp) (if (= (type _$lst) 'sym) (setq _$tmp_$lst _$lst(std-symbol-value _$lst) ) ) (setq_$what (car _$lst)_$lst (cdr _$lst) ) (if _$tmp (progn (set _$tmp _$lst) _$what ) _$lst ));;; -------------------------------------------------------------------73;;; std-mapatom maps a function to every symbol in a tree,;;; keeping the tree structure intact.;;; iterative version by serge pashkov.(defun std-mapatom (func lst / new pend curr pendlst newlst) (cond ((atom lst) (apply func (list lst) ) ) (t; loop until last element, for '(1 2; . 3) too (while (consp lst) (setq pend (cons (car lst) pend) lst (cdr lst) ) ) (setq new (if lst (apply func (list lst) ) ) pendlst nil newlst nil ) (while pend (while pend (setq curr (car pend) pend (cdr pend) ) (if (atom curr) (setq new (cons (apply func (list curr) ) new ) ) (progn (setq pendlst (cons pend pendlst) newlst (cons new newlst) pend nil ) (while (consp curr) (setq pend (cons (car curr) pend) curr (cdr curr) ) ) (setq new (if curr (apply func (list curr) ) ) ) ) ) ) (while (andpendlst(null pend) ) (setq new (cons new (car newlst)) newlst (cdr newlst) pend (car pendlst) pendlst (cdr pendlst) ) ) ) new ) ));;; the old readable recursive version:;;; highly recursive, may fail on large lists!;;; by vladimir nesterovsky <vnestr@netvision.net.il>;;; -------------------------------------------------------------------73;;; added with v0.4001, 7/21/99;;; some and every for autolisp backwards compatibility.;;; vl takes multiple arguments, so divide them into an one-arg version;;; and a n-args version for alisp.;;; these are the optimized versions, the simple one is just;;; (apply 'and|or (mapcar 'pred lst));;; t if pred is non-nil for every element;;; or nil if some elements are nil when applied to pred;;; (apply 'and (mapcar 'pred lst));;;;;; one-arg optimized alisp version;;; don't process the whole list,;;; break at the first nil(defun std-every (pred lst / res) (setqres (apply pred (list (car lst)) )lst (cdr lst) ) (while (and res lst ) (setq res (applypred(list (car lst)) ) lst (cdr lst) ) ) res);;; t if pred is non-nil for some elements;;; or nil if every element is nil when applied to pred;;; (apply 'or (mapcar 'pred lst));;;;;; one-arg optimized alisp version;;; don't process the whole list,;;; return t at the first non-nil;;; (std-some 'numberp '(0 x 1 3)) => t;;; (std-some 'zerop '(1 2 3)) => nil(defun std-some(pred lst / res) (setqres (not (apply pred (list (car lst)) ) )lst (cdr lst) ) (while (and res lst ) (setq res (not (apply pred (list (car lst)) ) ) lst (cdr lst) ) ) (not res));;; lisp or;;; return the value of the first non-nil value.(defun std-%or (lst) (while (not (car lst)) (setq lst (cdr lst)) ) (car lst));;; for predicates taking more args(defun std-some-n (pred lists) (cond ((std-vlisp-p) (apply (function vl-some) (cons pred lists) ) ) ((std-vill-p) (apply (function vlx-some) (cons pred lists) ) ) (t (std-%some-n pred lists) ) ));;; for predicates taking more args(defun std-every-n (pred lists) (cond ((std-vlisp-p) (apply (function vl-every) (cons pred lists) ) ) ((std-vill-p) (apply (function vlx-every) (cons pred lists) ) ) (t (std-%every-n pred lists) ) ));;; n-args optimized alisp version(defun std-%every-n (pred lists / res) (std-warn "std-%every-n fails sometimes. ") (setqres (applypred(mapcar (function car) lists) )lists (mapcar(function cdr)lists ) ) (while (and res (car lists) ) (setq res(apply pred (mapcar (function car) lists )) lists(mapcar (function cdr) lists) ) ) res);;; n-args optimized alisp version(defun std-%some-n (pred lists / res) (std-warn "std-%some-n fails sometimes. ") (setqres (not (apply pred (mapcar (function car) lists ) ) )lists (mapcar(function cdr)lists ) ) (while (and res (car lists) ) (setq res(not (apply pred (mapcar (function car) lists ) )) lists(mapcar (function cdr) lists) ) ) (not res));;; -------------------------------------------------------------------73;;; sets (operations on unordered lists);;; our sets are unordered, most operations are not stable, but duplicates;;; are ignored or removed.;;; the operations are very simple, not optimized for any data.;;; std-intersection returns all elements that are in x and y.;;; iterative, stable version by serge pashkov.;;; duplicates are handled incorrectly yet.;;; (std-intersection '(0 1 2 3 4 5) '(2 0 6 7)) => (0 2);;; problem: (std-intersection '(0 0 0 1) '(0 0 1)) => (0 0 0 1);;; but it should be (0 0 1) instead(defun std-intersection(x y / new) (setq new nil); possible vl lsa compiler bug (foreach ele x (if(member ele y) (setq new (cons ele new)) ) ) (reverse new));;; highly recursive, may fail on large lists!;;; std-set-difference returns all elements of x without elements;;; also in y, iterative, stable version by serge pashkov;;; (std-set-difference '(0 1 2 3 4 5) '(2 0 6 7)) => (1 3 4 5);;; big lists as second argument are faster:;;; (setq big (std-int-list 1000) small (std-int-list 10));;; (std-time '(std-set-difference small big));;; => (std-set-difference small big) : 0 ms;;; (std-time '(std-set-difference big small));;; (std-set-difference big small) : 50 ms(defun std-set-difference (x y / new) (setq new nil); to avoid possible vl lsa compiler; bug (?) (foreach ele x (if(not (member ele y)) (setq new (cons ele new)) ) ) (reverse new));;; highly recursive, may fail on large lists!;;; std-union returns a list of all elements in both lists;;; iterative version by serge pashkov;;; (std-union '(0 1 2 3 4 5) '(2 0 6 7)) => like (7 6 0 1 2 3 4 5);;; ignore duplicates in y are ignored, in x not.;;; simplified version without any ordering.;;; see std-ordered-union which keeps the orginal order intact.;;; big lists as first argument are faster:;;; (setq big (std-int-list 1000) small (std-int-list 10));;; (std-time '(std-union small big));;; => (std-union small big) : 1222 ms;;; (std-time '(std-union big small));;; (std-union big small) : 0 ms(defun std-union (x y) (foreach ele y (if(not (member ele x)) (setq x (cons ele x)) ) ) x);;; we use reversing only for appending missing elements;;; after the end of x. iterative version by serge pashkov(defun std-ordered-union (x y / new) (setq new (reverse x)) (foreach ele y (if(not (member ele new)) (setq new (cons ele new)) ) ) (reverse new));;; highly recursive, may fail on large lists!;;; elements that appear in exactly one of lst1 and lst2(defun std-set-exclusive-or (x y) (append (std-set-difference x y) (std-set-difference y x) ));;; std-subsetp returns t if every element of x is a member of y,;;; ignoring order and duplicates, iterative version by serge pashkov;;; (std-subsetp '(7 0) '(2 0 6 7)) -> t;;; (std-subsetp '(1 7) '(2 0 6 7)) -> nil;;; note: in cl the default comparison is with eql not with equal!;;; (std-subsetp '((1) (2)) '((1) (2))) => t;;; but in cl it would return nil(defun std-subsetp (x y) (while (and x (member (car x) y) ) (setq x (cdr x)) ) (null x));;; highly recursive, may fail on large lists!;;; have both sets the same elements? ignoring order and duplicates;;; (std-set-equal-p '(a b c) '(c b a)) => t;;; (std-set-equal-p '(a b c) '(c b a a)) => t(defun std-set-equal-p (x y) (and (std-subsetp x y) (std-subsetp y x) ));;; -------------------------------------------------------------------73;;; list creation;;; std-int-list creates '(0 1 2 ... <n-1>) of length n(defun std-int-list (n / lst) (setq lst nil); possible vl lsa compiler bug (repeat n (setq lst (cons (setq n (1- n)) lst ) ) ));;; creates a list of n elements with initial value def;;; (std-make-list 100 nil);;; support dynamic defaults from functions like:;;; (std-make-list 100 'std-%random);;; (std-make-list 100 '(lambda () (std-random 10)));;; (std-make-list 100 ( function (lambda () (std-random 10))));;; but not: (std-make-list 100 '(std-random 10));;; which would create a list of 100 lists(defun std-make-list (n def / lst) (setq lst nil); possible vl lsa compiler bug (if (std-functionp def); dynamic invocation (repeat n (setq lst(cons (applydefnil ) lst) ) ); dynamic list of n def's (repeat n (setq lst (cons def lst)) ) ));;; tip: to ensure a list of fixed length:;;; (std-%firstn 4 '(0 1 2)) => '(0 1 2 nil);;; integer sequence including start and end element;;; (std-iseq 0 1) => (0 1); idea from xlisp-stat(defun std-iseq(start endp / lst) (repeat (1+ (- endp start)) (setq lst (cons endp lst) endp (1- endp) ) ) lst);;; real sequence, list of n equally spaced real numbers between;;; start and end (both including); idea from xlisp-stat;;; (std-rseq 0 1 3) => (0.0 0.5 1.0)(defun std-rseq(start endp n / lst d) (cond ((= n 1) start ) ((< n 1) nil ) ((< endp start) nil ) (t (setq d (/ (float (- endp start)) (1- n)) lst nil ); possible vl lsa compiler bug (repeat n (setq lst (cons (+ start (* (setq n (1- n)) d ) ) lst ) ) ) ) ));;; "next cyclic number";;; (std-nxtcyc 0 3 '1+) => 1;;; (std-nxtcyc 1 3 '1+) => 2;;; (std-nxtcyc 2 3 '1+) => 3;;; (std-nxtcyc 3 3 '1+) => 0(defun std-nxtcyc (i n func) (cond ((>= (setq i (apply func (list i) ) ) n ) 0 ) ((< i 0) (1- n) ) (t i ) ));;; note: equal is too weak and eq is too strong.;;; = is the autolisp eql alike(defun std-count (ele lst / i) (setq i 0) (foreach x lst (if(= ele x) (setq i (1+ i)) ) ) i)(defun std-count-if (pred lst / i) (setq i 0) (foreach x lst (if(apply pred (list x)) (setq i (1+ i)) ) ) i)(defun std-count-if-not(pred lst / i) (setq i 0) (foreach x lst (if(not (apply pred (list x) )) (setq i (1+ i)) ) ) i);;; more elegant but more inefficient:;;; -------------------------------------------------------------------73;;; sorting:;;; vlx-sort introduced a new unwanted behaviour. (also in vl-sort);;; it removes duplicate elements, which does not conform to ansi cl;;; that's why we define 3 different sort functions for the user and;;; several algorithms to acomplish it.;;; std-sort is like ansi cl, should have about o(n logn) average;;; complexity of long lists;;; std-fast-sort uses vlx-sort or same as above,;;; it may delete duplicate entries!;;; std-stable-sort garantees order of elements;;; should be stable, but could be slower or use more stack than;;; std-sort.;;; the algorithms tested were quick-sort, stable-qsort,;;; merge-sort and insertion-sort and various (previously unstable);;; combinations. see the timings and all the algos in sorttst.lsp;;; non-recursive stable merge sort;;; overall the best method in autolisp. by serge pashkov;;; slightly improved 3% by using danieles trick. see std-%setnth;;; (setq l '((1 1) (2 1) (1 2) (3 1) (1 3) (3 2) (3 3) (4 1) (1 4)));;; (std-%merge-sort l ( function (lambda (x y)(< (car x) (car y)))));;; => ((1 1) (1 2) (1 3) (1 4) (2 1) (3 1) (3 2) (3 3) (4 1));;; it's supposed that used version of std-%insertion-sort is stable.(defun std-%merge-sort (lst _cmp / mlst rst len) ; split by short lists; sorted by insertion to decrease; overhead; length 4 is near optimum for; sorted and random lists. (setqrst (mapcar (function(lambda(e) (std-%insertion-sort e _cmp)) ) (std-split-list 4 lst) ) ); repeat while leave only 1 sequence (while (> (setq len (length rst)) 1 ); merge every 2 adjacent sorted; sequences (repeat (/ len 2) (setq mlst (cons (std-merge (car rst) (cadr rst) _cmp) mlst) rst (cddr rst) ) ); add last sorted sequence (if any) (setq rst (reverse(if rst (cons (car rst) mlst) mlst) ) mlst nil ) ) (car rst));;; old version;;; stable insertion sort, fast for already ordered and short lists;;; very slow for reversed or random lists o(n^2);;; by serge pashkov(defun std-%insertion-sort (lst cmp / m n o co) (setqo (reverse lst)m niln (list (car o)) ) (while (setq o (cdr o)) (setq co (car o)) (while (and n (apply cmp (list (car n) co) ) ) (setq m (cons (car n) m) n (cdr n) ) ) (setq n (cons co n)) (while m (setq n (cons (car m) n) m (cdr m) ) ) ) n);;; use merge-sort for everything(defun std-stable-sort (lst cmp) (std-%merge-sort lst cmp))(if (not (boundp 'std-sort)) (defun std-sort (lst cmp) (std-%merge-sort lst cmp) ))(if (not (boundp 'std-fast-sort)) (defun std-fast-sort (lst cmp) (std-%merge-sort lst cmp) ));;; iterative stable version, (see test/sorttst.lsp);;; by serge pashkov;;; this version is ~2 times faster on nearly sorted and nearly;;; backwards sorted lists, but 5-7% slower on truly random lists,;;; so we take this one. it has some testing overhead.;;; hmm, error! no time to check it for now.(defun std-merge (l1 l2 cmp / lst cl1 cl2) (setqcl1 (car l1)cl2 (car l2)lst nil ); possible vl lsa compiler bug (while (and l1 l2 ) (if(apply cmp (list cl2 cl1)) (setq lst(cons cl2 lst) l2(cdr l2) cl2(car l2) ) (setq lst(cons cl1 lst) l1(cdr l1) cl1(car l1) ) ) ) (append (reverse lst) l1 l2 ));;; this version is 5-7% faster on truly random lists, so we;;; support it too.(defun std-%merge-random (l1 l2 cmp / lst cl1 cl2) (setqcl1 (car l1)cl2 (car l2)lst nil ); possible vl lsa compiler bug (while (and l1 l2 ) (if(apply cmp (list cl2 cl1)) (setq lst(cons cl2 lst) l2(cdr l2) cl2(car l2) ) (setq lst(cons cl1 lst) l1(cdr l1) cl1(car l1) ) ) ) (append (reverse lst) l1 l2 ));;; some more recursion homework: freshly cons each car and cdr part;;; this would only be useful if there are some destructive functions,;;; but so far there are none.;;; this function has no higher meaning, it is included just for fun.;;; well, some sort implementations were destructive in the past, but;;; i cannot remember which.;;; highly recursive, may fail on large lists!(defun std-copy-tree (tree) (cond ((atom tree) (car (cons tree nil)) ) (t (cons (std-copy-tree (car tree)) (std-copy-tree (cdr tree))) ) ));;; std-randomize arranges all list elements randomly.;;; fisher-yates algorithm. 10/2/00;;; this will be re-defined by std-%randomize from fileext 0.5 in;;; stdinit2, because this performs poorly.;;; (std-randomize '(0 1 2 3 4)) => (2 4 0 3 1)(defun std-randomize (lst / j i tmp) (setq i (1- (length lst))) (while (> i 0) (if(/= i (setq j (std-random (1+ i)))) (setq tmp(nth i lst) lst(std-setnth (nth j lst) i lst) ; new i lst i(1- i) lst(std-setnth tmp j lst) ) ) ));;; this doesn't create evenly distributed arrangements.;;; i should have known, serge pashkov already told me.;;; std-random-elt returns a random list element.;;; elt is in lisp the normal safe sequence accessor.(defun std-random-elt (l) (if (null (cdr l)) (car l) (nth (std-random (length l)) l) ));;; returns a point in the 3d-box (0 0 0) - (1 1 1)(defun std-random-pt () (list (std-random nil) (std-random nil) (std-random nil)));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdlist-symbols*))(setq *stdlist-symbols* nil);;; module dependenciesstd-%simple-provide "STDLIST");;; first provide it, but before you may;;; call it, be sure to have all;;; supporting modules(std-%simple-require "STDINIT");;; all dependent top-level calls removed;;; consp, std-functionp, function;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdlisp.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:56 rurban>;;; copyright (c) 1998 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; lisp specific functions for the stdlib;;; status:;;; still incomplete yet;;; certain size-critical functions (mainly std-princ) are not called;;; from other functions to reduce cross-dependencies.;;; some are not tested;;;;;; $log: stdlisp.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;; 2000-04-07 15:16:20 rurban;;; removed std-princ dependency from std-error;;; internal functions are prefixed with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdlisp-symbols* '(std-gensymstd-integerp std-realp std-filepstd-enamep std-picksetp std-princstd-princ-to std-tostr std-equalpstd-debug-print std-print-warn std-warnstd-error std-cerror std-assertstd-default std-default-type std-defconstantstd-defkeyword std-keywordp std-module-pathname std-require-path std-require-version std-load std-load-external ) ) ));;; used globals: not defined here. their defaults are nil.;;; *verbose*; prints verbose messages;;; *load-verbose* ; prints load messages;;; *debug* ; enables debugging;;; *break* ; enables break;;; *break-on-warnings* ; user-interactive dialog on std-warn;;; needs keypress to continue;;; *gensym-counter*; actual (std-gensym) index;;; (if bound or unbound)(if (not (numberp *gensym-counter*)) (setq *gensym-counter* 0));;; first col to include it in lspdoc.hlp;;; create a new unbound symbol.;;; changed behaviour: the counter is always incremented to;;; simplify macros;;; (setq x (std-gensym)) => g0;;; (eval x) => nil;;; (set (std-gensym) 1) => 1(sets g1 to 1);;; (eval x) => nil (x is g0)(defun std-gensym (/ x) (while (boundp (setq x (read (strcat "G" (itoa (1- (setq *gensym-counter*(1+ *gensym-counter*) ) ) ) ) ) ) ) ) x);;; -------------------------------------------------------------------73;;; workarounds for not vl funcs:;;; some of them were already defined in stdinit because they;;; are needed at load-time. we redefine them here to have them;;; all together.;;; already defined in stdinit;;; (std-%cond-defun;;; '(defun std-symbolp (x);;; (eq (type x) 'sym));;; );;; already defined in stdinit;;; (if (not (boundp 'std-symbol-value));;; if not vill: almost the same;;; (setq std-symbol-value eval);;; );;; (std-%cond-defun;;; if not vill: very very tricky! i replaced it with a more stable;;; version in stdinit. boundp and the implicit evaluation of lists;;; is not quite lisp conform.;;; from a cis forum, author unknown;;; '(defun std-symbol-name (name);;; (if (std-symbolp name);;; (;;; (list;;; (if (boundp name);;; (cons '/ (atoms-family 0));;; (cons '/ (cons name (atoms-family 0)));;; );;; (list setq name 0);;; (list car (list atoms-family 1));;; );;; );;; nil;;; );;; );;; );;;(std-%cond-defun; if not vill: very slow! '(defun std-prin1-to-string (x / f str tmp) (setq tmp (std-filename-mktemp nil) f (std-fopen tmp "w") ) (prin1 x f) (std-fclose f) (setq f (std-fopen tmp "r") str (read-line f) f (std-fclose f) ) str ))(std-%cond-defun; if not vill: very slow! '(defun std-princ-to-string (x / f str tmp) (if (stringp x); avoid costly conversion if already; string! x (progn (setq tmp (std-filename-mktemp nil) f (std-fopen tmp "w") ) (princ x f) (std-fclose f) (setq f (std-fopen tmp "r") str (read-line f) f (std-fclose f) ) str ) ) ));;; more type predicates(defun std-integerp (x); is it a integer number? (type int) (eq (type x) 'int))(defun std-realp (x); is it a real number? (eq (type x) 'real))(defun std-filep (x); is it a file object? (eq (type x) 'file))(defun std-enamep (ele) (eq (type ele) 'ename))(defun std-picksetp (ss) (eq (type ss) 'pickset));;; note: other defined type predicates are consp and stringp in;;; the stdlib and listp, atom in autolisp.;;; redefine std-princ to support global printing variables:;;; princ extended to take lists too;;; using *print-length*, *print-level* in the list argument only.;;; speed it up if none defined.(defun std-princ (x) (if (consp x) (if(and (not *print-length*) (not *print-level*)) (mapcar(function princ)x ) (mapcar(function (lambda (s) (std-%write s nil 0) ))x ) ) (princ x) ));;; std-princ extended to print to a file, console or string;;; if to files we need exactest information as possible, no omissions;;; on long lists or deep nesting, and exactest number representation!;;; not just (1 2 3 ...) or 1.345+e008(defun std-princ-to (x _to / *tmpstr*) (cond; with files we don't need dots! ((and (std-filep _to) (std-open-file-p _to) ); fixed (if (consp x); todo: convert numbers (mapcar (function (lambda (_s) (princ _s _to) ) ) x ) (princ x _to) ) ) ((std-symbolp _to); assume a string (setq *tmpstr* "") (if (consp x) (if (and (not *print-length*) (not *print-level*) ) (setq *tmpstr* (std-strjoin x "")) ; use self-evaluating t _to; pass symbols recursively (mapcar (function (lambda (_s) (std-%write _s 't 0) ) ) x ) ) ) (set _to *tmpstr*) ) ((not _to); nil for console (std-princ x) ) (t (std-error(list (std-msg "invalid output argument - ") _to) ) ) ));;; first level call for std-%write-to;;; (defun std-%write (x to);;; (std-%write-to x to 0);;; (princ));;; processor for std-princ and std-princ-to;;; honoring global print variable settings;;; may be extended for more objects;;; improvement: overlarge integers are printed as integers,;;; not as abbrevated reals,;;; (princ 10000000000) not 1.0e+10;;; (princ 10000000000) => 10000000000;;; take care with dotted lists!(defun std-%write (x to level) (if (and(numberp x)(> x *max-int*)(zerop (std-fraction x)) ); it seems to be a overlarge integer; so print it as one (setq x (std-rtos x)) ) (cond ((and (numberp *print-level*) (> level *print-level*) ) (std-%princ-to "#" to) ) ((consp x) (if (and (numberp *print-length*) (> (std-list-length x) *print-length*) ) (std-%write-list (append (std-firstn *print-length* x) '("...") ) to (1+ level) ) (std-%write-list x to (1+ level)) ) ) ((std-filep to) (princ x to) ) ((not to); nil for console (princ x) ) ((std-symbolp to); assume a string (setq *tmpstr* (strcat *tmpstr* (std-princ-to-string x))) ) (t (std-error (list (std-msg "invalid output argument - ") to)) ) ));;; treat lists special, dotted pairs!(defun std-%write-list (x to level / y) (if (and(numberp *print-level*)(> level *print-level*) ) (std-%princ-to "#" to) (progn (std-%princ-to "(" to) (std-%write (car x) to level) (setq x (cdr x)) (while (and (consp x) (listp (cdr x)) )(std-%princ-to " " to)(std-%write (car x) to level)(setq x (cdr x)) ) (if (and x (atom x) )(progn (std-%princ-to " . " to) (std-%princ-to x to)) ) (std-%princ-to ")" to) ) ) nil);;; faster version for x of type string(defun std-%princ-to (x to) (cond ((not to) (princ x) ) ((std-filep to) (princ x to) ) ((std-symbolp to); assume a string (setq *tmpstr* (strcat *tmpstr* (std-princ-to-string x))) ) ));;; convert expression to user readable format.;;; portable and quite accurate definition.;;; faster without vl, but slower with vl.;;; used for user prompts. some expressions are read incompatible.;;; nil is printed as "" and points as (0,0)(defun std-tostr (x / typ); accepts any expression (cond ((not x) "" ); "" = nil ((eq (setq typ (type x)) 'str ) x ); string ((eq typ 'int) (itoa x) ); number ((eq typ 'real) (std-rtos x) ); float with max.accuracy ((eq typ 'sym) (std-symbol-name x) ) ((std-dotted-pair-p x) (strcat "(" (std-tostr (car x)) " . " (std-tostr (cdr x)) ")" ) ); there's a dot somewhere ((std-not-proper-list-p x); for now print it only in the; recursive dotted notation; (1 2 . 3) => "(1 . (2 . 3))"; will be fixed later (strcat "(" (std-tostr (car x)) " . "; (if (consp (cdr x)) " " " . ") (std-tostr (cdr x)) ")" ) ); print numbers with commas, points:; (1, 2, 3); this is incompatible to read, so; it may be changed later. ((std-number-list-p x) (strcat "(" (if (> (length x) 1) (std-strlist->csstring (mapcar (function std-tostr) x ) ) (std-tostr (car x)); single entry within brackets ) ")" ) ); not empty list, print it with; spaces ((eq typ 'list) (strcat "(" (if (> (length x) 1); error with dotted pair lists (std-strlist->string (mapcar (function std-tostr) x ) " " ) (std-tostr (car x)); single entry within brackets ) ")" ) ); all other types (file, ename,; pickset, subr, ...) (t (std-princ-to-string x) ) ));;; special (weaker) case for;;; points (number-lists) with numerical tolerance (usually 1e-6),;;; sets (unordered same elements) and strings (case-insensitive);;; note: numeric lists are no sets!(defun std-equalp (x y) (cond ((std-number-list-p x) (equal x y *num-tol*) ) ((consp x) (std-set-equal-p x y) ) ((stringp x) (std-string-equal x y) ) ((std-realp x) (equal x y *num-tol*) ) (t (equal x y) ) ));;; -------------------------------------------------------------------73;;; simple error and debugging support:;;; also defined in stdinit;;; see the error handling in stderror.lsp;;; see user-interactive debugging in stddebug.lsp;;; (defun std-verbose-print (msg);;; (if *verbose* (std-princ msg)))(defun std-debug-print (msg) (if *debug* (std-%print-error-prefix (std-msg "; DEBUG") msg) ));;; prints warning and optionally waits for a keypress on;;; *break-on-warnings*;;; takes a string or lists of any type.;;; this is similar to std-warn but never calls std-break.(defun std-print-warn (msg) (if (and(std-acad-connection-p)*break-on-warnings* ); changed (alert (std-tostr msg)) (std-%print-error-prefix (std-msg "; * Warning") msg) ) (princ));;; print formatted msg on command line(defun std-%print-error-prefix (prefix msg / s) (if (not prefix) (setq prefix (std-msg "; *** ERROR")) ) (terpri) (princ prefix) (princ ": ") (if (listp msg) (foreach s msg (princ s) ) (princ msg) ); (std-princ msg) (princ));;; may break or just prints the msg, dependent on the global *break*(defun std-warn(msg) (if *break* (std-cerror msg) (std-print-warn msg) ));;; force not continuable (severe) error.;;; prints the error message and breaks, don't mix it up with *std-error*;;; this functions forces an error but is not the error handler.(defun std-error (msg) (std-%print-error-prefix nil msg) (princ " "); (if (std-vlide-p); see below; (std-%forced-exit) (exit); just exits the running lisp; ));;; only for vl ide;;; (exit) may closes the whole ide, that's why we need a usubr(defun std-%forced-exit() (exit));;; continuable error;;; so far the conditioning system in autolisp is not capable to;;; continue on errors, so it's more or less a call to break with a;;; different message. the real functionality is reserved for the;;; future, when jumps or restarts are supported.;;; fixed by serge pashkov not to depend on stddebug anymore.(defun std-cerror (msg / *break*) (std-%print-error-prefix (std-msg "; ** Continuable Error") msg ) (setq *break* t) (if (std-%simple-require "STDDEBUG") (std-break msg nil) ));;; throw error if 'test evaluates to nil;;; the test argument must be used with quotes!;;; (std-assert '(= x y) "x /= y")(defun std-assert (_$test _$msg / _$obreak) (if (not (eval _$test)) (progn (std-%print-error-prefix(std-msg "; *** Assertion Failure")(if _$msg _$msg (list(std-prin1-to-string _$test)" => nil" )) ); force break or just exit? (if (or *debug* *break* )(if (std-%simple-require "STDDEBUG") (std-break nil nil))(exit) ) ) ));;; -------------------------------------------------------------------73;;; initializing variables:;;; if nil set sym to def;;; the second argument is always evaluated (a function, no macro);;; so better use it only on simple functions or default variables.;;; similar to the cl defvar.;;; (std-default 'my:int 100)(defun std-default (symb value) (if (andvalue(not (std-symbol-value symb)) ) (set symb value) ));;; default with type checking.;;; if not of type def set sym to def.;;; better than std-default which only check s for nil. this checks for;;; a required type.;;; the second argument is always evaluated (it's a function not a macro);;; so better use it only on simple functions or default variables;;; (std-default-type 'my:int 100)(defun std-default-type(ele def / _$tmp) (if (= (type ele) 'sym) (setq _$tmpele ele(std-symbol-value _$tmp) ) ) (if (/= (type ele) (type def)) (setq ele def) ) (if _$tmp (set _$tmp ele) ele ));;; with vl it protects the constant from assigning.;;; it really should be macro to avoid the quote.;;; usage: (std-defconstant '*x* 0);;; (setq *x* 1);;; prints: *u* warning: assignment to protected symbol: *x* <- 1;;; without vl there's no warning.(defun std-defconstant (symb value) (std-%unprotect-assign (list symb)) (set symb value); (setq *constants* (std-adjoin symb; *constants*)) (std-%protect-assign (list symb)) (std-symbol-value symb); don't evaluate value twice!)(defun std-defkeyword (symb) (std-defconstant symb symb));;; if it is in the keyword package is not decidable, so we must use;;; tricks: self-evaluating symbol and ":" prefix.;;; usage: (std-keywordp :error) => t or (std-keywordp ':error) => t(defun std-keywordp (symb) (and (std-symbolp symb) (= ":" (std-firstchar (std-symbol-name symb))) (eq symb (std-symbol-value symb)) ));;; self-evaluating objects like numbers, strings;;; constant variables like keywords, defconstant'ed symbols (not yet!);;; quoted forms;;; don't rely in this so far. defconstant'ed symbols are not detected!(defun std-%constantp (x) (or (numberp x) (stringp x) (and (std-symbolp x) (eq x (std-symbol-value x)) ); (member x *constants*) ; symbols; may be shadowed so this may be; wrong. it depends on the; environment (and (consp x) (eq (car x) 'quote) ) ));;; -------------------------------------------------------------------73;;; vl specific stuff;;; prints warning on redefinition of symbol, in vl only.;;; used for defconstant;;; as side-effect they are blue in the ide.;;; removed stdstr dependency;;; (defun std-%protect-assign (syms);;; (if (std-vl-p);;; (eval (read;;; (strcat "(pragma '((protect-assign ";;; (apply (function strcat); v0.4001;;; (mapcar;;; (function (lambda (s);;; (strcat " " (std-princ-to-string s))));;; syms));;; ")))")))))(defun std-%protect-assign (syms) (if (std-vl-p) (eval (list'pragma(list 'quote (list (cons 'protect-assign syms))) ) ) ))(defun std-%unprotect-assign (syms) (if (std-vl-p) (eval (list 'pragma (list 'quote (list (cons 'unprotect-assign syms))) ) ) ));;; (defun std-%unprotect-assign (syms);;; (if (std-vl-p);;; (eval (read;;; (strcat "(pragma '((unprotect-assign ";;; (apply (function strcat); v0.4001;;; (mapcar;;; (function (lambda (s);;; (strcat " " (std-princ-to-string s))));;; syms));;; ")))")))));;; predicate if the symbol is protected;;; better don't use the extension std-%protectedp directly(defun std-%protect-assigned-p (symb) (if (and(std-vl-p)(>= *fileext-version* 0.54)(std-functionp std-%protectedp) ) (std-%protectedp symb) ));;; -------------------------------------------------------------------73;;; modules:;;; basic code is in stdinit;;; list of acceptable extensions, in the correct order for searching(defun std-%loadable-lisp-extensions () (if (/= (std-ver-name) "ACAD") '(".LSP") (append (if (std-vlisp-p)'(".VLX") ) (if (std-vl-p)'(".FAS")(if (std-acomp-p) '(".BI4")) ) '(".LSP") ) ))(defun std-%loadable-ads-extensions () (cond ((/= (std-ver-name) "ACAD") '(".DLL") ) ((std-acad-connection-p) (append (if (>= (std-ver-num) 13) '(".ARX"); arx or dll with clones (if (std-ver-win-p); ads '(".EXE") '(".EXP") ) ) ) ) ));;; return the loader function as well? (load, xload or arxload)(defun std-%loadable-extensions() (append (std-%loadable-lisp-extensions) (std-%loadable-ads-extensions) ))(defun std-module-pathname (name / ext extlst fname path) (setq fname (std-%force-module-string name)) (if (setq ext (std-filename-extension-or-nil fname)); forced extension (setq extlst (list ext)) (setq extlst (std-%loadable-extensions)) ); with explicit path skip path; search (if (std-filename-directory-or-nil fname) (findfile fname) (std-%load-try-paths fname (append; search orderlist (std-current-path))*module-path*(std-acad-library-paths) ) extlst ) ));;; used if the module name is different from the filename or;;; if the path is known, not to search all other paths.(defun std-require-path(name path) (setq name (std-%force-module-string-dot name)) (if (std-%module-string-defined-p name) (if(std-load-external path) name ) ));;; (std-require-version <module-name> <version-number>);;; used to search for the required version number which is;;; the value of the special symbol * <module-name> -version*;;; such as *binio-version* (currently: 2.2);;; returns the version number or nil.;;; also used to get the actual version number with;;; (std-require-version name -1)(defun std-require-version (module version / actver name); (std-%simple-req; uire "stdfile") (setq name (std-%force-module-string-dot module)) (if (and(std-%simple-module-string-defined-p name)(numberp (setq actver (std-symbol-value(read (strcat "*" name "-VERSION*" )) ) ))(>= actver version) ) actver (if(null (std-load-external (std-%force-module-string module))) nil (std-symbol-value (read (strcat "*" name "-VERSION*"))) ) ));;; search file in given pathnames;;; depricated. to be replaced by std-%findfile-exts, stdfile(defun std-%load-try-paths (fname pathlst extlst / path found) (while (and pathlst (not found) ) (setq path (std-force-path (car pathlst) fname)) (setq found(if (std-filename-extension-or-nil path) ; explicit; extension given? (std-probe-file path) (std-%load-try-extensions path extlst)) ) (setq pathlst (cdr pathlst)) ) found)(defun std-%load-try-extensions(path extlst / found) (while (and extlst (not found) ) (setq found (std-probe-file (strcat path (car extlst))) extlst (cdr extlst) ) ) found);;; accepts any pathname, using stdfile functions;;; possible extension: check for vl-rts and use vl-load then(defun std-load(fname / extlst path retval) (setq extlst (std-%loadable-lisp-extensions)); with explicit path skip; *module-path* (if (not (std-string-not-empty-p (std-filename-directory fname)) ) (setq path (std-%load-try-paths fname *module-path* extlst)) ); or in the acad library path (if path (setq fname path) ) (setq retval (load fname "error")) (if (= retval "error") (ifpath (load fname); found, but loading error, break; here! (std-print-warn(list (std-msg " Error loading ") fname "\n" (std-msg "Search paths: ") *module-path* "\n " (std-acad-library-paths) "\n") ) ) (std-%load-verbose-print (list (std-msg " Loaded ") fname " \n") ) ) (/= retval "error"));;; try to load it from the acad library path.;;; fname is the simple filebase, path the found path or nil;;; deprecated. better search the file, try to load then.;;; if it was found provide a different error messages than if it;;; was not found.(defun std-%load-external-acad (fname path / retval ext) (if path (progn (std-%load-verbose-print(list "\n" (std-msg "Loading ") path " ...") ) (setq ext (std-strcase (std-filename-extension path))) (setq retval (cond ((= ext ".ARX") (arxload path "error") ); felixcad,... xload dll's ((member ext '(".EXE"".EXP"".DLL" ) ) (xload path "error") ); ((and vl-load (std-vlrts-p)); (vl-load path)) ;fixed (t (load path "error") ) ) ) ) (progn (setq ext (std-strcase (std-filename-extension fname))) (setq retval (cond ((= ext ".ARX") (arxload fname "error") ) ((member ext '(".EXE"".EXP"".DLL" ) ) (xload fname "error") ) (t (load fname "error") ) ) ) (if (and (std-acad-connection-p) (= retval "error") )(if (or (not (std-functionp arxload)) (= (arxload fname "error") "error") ) (if (or(not (std-functionp xload))(= (xload fname "error") "error") ) nil (std-%load-verbose-print (list (std-msg " xload'ed ") fname " ") ) ) (std-%load-verbose-print (list (std-msg " arxload'ed ") fname " ") ))(std-%load-verbose-print (list (std-msg " Loaded ") fname " ")) ) retval ) ) (/= retval "error"));;; std-load-external tries to load external ads/adsrx/arx modules,;;; such as dll, exp, exe or arx, dependent on the platform.(defun std-load-external (fname / path extlst ext) (setqextlst (if (setq ext (std-filename-extension-or-nil fname)) (list ext) (std-%loadable-ads-extensions) ) ) (setq path (std-%load-try-paths fname *module-path* extlst)) (std-%load-external-acad fname path));;; we'll need a ads independent version for std-ver-fcad-p here;;; for the standalone mode.(defun std-%ver-ext-adssuffix () (cond ((std-ver-fcad-p) "fc" ) ((std-ver-icad-p) "ic" ) ((std-ver-tcad-p) "tc" ) (t (itoa (fix (std-ver-num))) ) ));;; load the version specific stdlib ads module.;;; for now support also all seperate "binio<xx>.<ext>",... versions as;;; well. this might change to the fixed name stdlib<xx>.<ext> only.;;; note that other apps may use a different filename and contain;;; additional funcs.;;; later we will need a strategy for r15 to go without any arx.(defun std-%require-external-ads (name / defname) (setq defname (strcat "STDLIB" (std-%ver-ext-adssuffix))) ; note: we; cannot safely upcase name on; case-sensitive filesystems (cond ((and (/= (std-strcase name) "STDLIB") (std-%simple-module-string-defined-p (std-strcase name)) ) ) ((member (std-strcase name) '("STDLIB" "STDLIB-ADS" "REGISTRY" "INIFILE" "BINIO" "FILEEXT" "STDLOCAL-ADS" ) ) (or (std-%simple-module-string-defined-p "STDLIB-ADS") (and (std-load-external defname) (if (not stdlib-ads-version) (std-%import-stdlib-arx name) 1 ) ) ) ) ((std-load-external (strcat name (std-%ver-ext-adssuffix))) (setq name (strcat name (std-%ver-ext-adssuffix))); if loaded before; or outside, import it. (if (not stdlib-ads-version) (std-%import-stdlib-arx name) 1 ) ); we really should avoid recursive; (load "stdlib15") invocations ((and (not std-ver-r2000-p); 11-feb-00 (std-load-external defname) ) (if (not stdlib-ads-version) (std-%import-stdlib-arx name) 1 ) ) ));;; unify vill/vlisp syntax(defun std-%vl-import-exsubr (lst) (cond ((std-vlisp-p) (vlisp-import-exsubrs lst) ) ((std-vill-p) (vill-import-exsubrs lst) ) ));;; if this was the stdlib-ads we know the names to import;;; note: if any adsrx app uses the stdlib ads funcs it must only;;; import the additional funcs;;; todo: use versioning for the list(defun std-%import-stdlib-arx (name / x fn var) (if (std-ver-r2000-p) (vl-arx-import name) (progn (foreach x '((stdlib-version 0 std-print-errno) (stdlib-ads-version 0.400018 std-print-errno) (fileext-version 0 std-%file-directory-p std-%file-readable-p std-%file-systime std-%file-modtime std-%file-size std-%directory-files std-%mkdir std-%rmdir std-%file-attrib std-%fullpath std-%dos-filename std-%current-path std-%get-drives-string std-%internal-time->cdate std-%get-internal-run-time std-%acad-connection-p std-%open-file-p std-%protectedp std-sys-version ) (random-ads-version 0 std-%sys-rand std-%random-state-p std-%make-random-state std-%randomize ) (stdlocal-ads-version 0 ; fixed 19-apr-00 std-%sys-codepage std-%sys-oemcp std-%sys-locale std-user-locale std-get-locale-info ) (binio-version 0 binio-fopen binio-fclose binio-fcloseall binio-fseek binio-ftell binio-rewind binio-fputc binio-fputint binio-fputlong binio-fputreal binio-fputs binio-fputstring binio-fgetc binio-fgetint binio-fgetlong binio-fgetreal binio-fgets binio-fgetstring binio-read-char binio-unread-char binio-peek-char binio-%double->2long binio-%2long->double ) (registry-version 0 registry-read registry-write registry-delete registry-descendents ) (inifile-version 0 inifile-get inifile-set) (stdwin-version 0 std-select-folder std-getfilew) (arxstuff-version 0.11 std-massprop) )(setq fn (car x) var (read (strcat "*" (std-princ-to-string fn) "*")))(std-%vl-import-exsubr (list name fn))(if (and (std-symbol-value fn) (applyfnnil ) (>= (apply fn nil ) (cadr x) ) ) (progn (std-%vl-import-exsubr (cons name (cddr x))) (std-%unprotect-assign (list var)) ; try to avoid; vlisp-import-symbol and adsrx; export (set var (apply fn nil ) ) (std-%protect-assign (list var)) ) (progn (std-%unprotect-assign (list var fn)) (set fn nil) (set var nil) )) ) ) ));;; todo: (vlisp-import-exsubr) for the external stdlib funcs;;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdlisp-symbols*))(setq *stdlisp-symbols* nil);;; module dependenciesstd-%simple-provide "STDLISP");;; first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.(std-%simple-require "STDINIT");;; various(if (not *std:%project*); after stdlisp in the project; loading order (std-%simple-require "STDFILE"); various)(std-%simple-require "STDSTR");;; various;;; (std-%simple-require "stdmisc") ; std-break: std-dclactive-p;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdfile.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:19 rurban>;;; copyright (c) 1998,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; file functions for the stdlib;;;;;; filenames (just strings: splitting, ...);;; directories (on existing files: checking, globbing);;; system;;; os specific (copy, delete, ...);;; text files;;; binary files;;; ini files;;; registry;;; user input (file dialogs, ...);;; also the top-level calls for all earlier modules.;;; status:;;; almost complete, but not fully tested yet.;;; the whole module is quite dynamic because it checks various;;; loaded external functions. only as last resort use the plain alisp;;; versions.;;; rbarlow reported a std-directory-files bug.;;; -------------------------------------------------------------------73;;; $log: stdfile.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-11-14 15:16:21 rurban;;; fixed std-file-directory-p warning on fileext.fas loading;;; 2000-11-10 16:07:34 rurban;;; fixed std-current-path to use std-%current-path;;; added *std-shell-timeout*;;; fixed std-%command-shell-wait to wait milliseconds and not loops;;; 2000-09-23 16:00:22 rurban;;; improved std-get-drive-list without arx;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-09-20 12:57:04 rurban;;; fixed std-file-copy for vlisp;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-26 18:19:49 rurban;;; renumbered msg id's;;;;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdfile-symbols* '(std-fpslash std-make-pathname std-filename-base std-filename-extension-or-nil std-filebase std-filename-directory std-filename-split std-filename-extension std-file-readable-p std-file-directory-p std-filename-directory-or-nil std-filename std-force-path std-def-extension std-force-extension std-longfnamep std-filename-upcase std-truename std-current-drive std-current-path std-same-files-p std-fopen std-fclose std-fcloseall std-open-file-p std-open-filename-p std-open-filename->file std-file->filename std-directory-files std-glob-files std-glob-dirs std-findfile std-findfile-paths std-findfile-exts std-acad-library-paths std-ft-backup std-ft-copy std-ft-append std-ft-equal std-ft-nth-line std-ft-lines std-ft-insert std-showfile-dialog std-showfile std-read-file-strings std-read-file-list std-file-exist-p std-file-writable-p std-filename-mktemp std-dos-filename std-file-backup std-file-newer-p std-get-drive-list std-file-modtime std-file-systime std-file-rename std-file-copy std-file-append std-file-delete std-file-attrib std-%directory-files std-file-size std-mkdir std-rmdir ) ) ))(std-%simple-require "STDINIT");;; for top-level predicates(std-%simple-require "STDLIST");;; various;;; globals:;;; possible slashchars, improved later in stdinit2: std-%top-level-1(setq *std:slash-chars* '(":" "/" "\\"));;; maximal time in milliseconds to wait for the shell to complete;;; a simple builtin i/o command. typically 'cd', 'pwd', 'dir', ...;;; this is highly system dependent. in doubt use a higher number.(setq *std:shell-timeout* 30);;; [ms](if (not special) (defun special (x) (std-%load-verbose-print (append'("declared special: ")x ) ) ));;; filesystem independent functions;;; std-fpslash;;; filepath-slash converts "\\" or "/" in path strings to whichever is;;; needed by operating system (unix or dos and os/2),;;; and forces trailing slash. only "\\" and "/" supported so far!;;; on the mac ending : "slashes" have a different meaning, hmm..;;; thanksfully acad never supported vms with its awful [] naming.;;; nt accepts "/" too, even in shells(defun std-fpslash (path) (if (= path "") "" (progn; (if (not (stringp *slash-char*)); (setq *slash-char* (if; (std-sys-dosbased-p) "\\" "/"))) (setq path (std-%slash-unify path)) (if (/= (std-lastchar path) *slash-char*)(setq path (strcat path *slash-char*))path ) ) ));;; hmm, what to do with the mac ":" path delimiter?;;; <joke>do mac folks do (autolisp) programming at all?</joke>(defun std-%slash-unify(s); (if (std-sys-mac-p); (std-strchg (std-strchg s "/"; ":") "\\" ":") (if (= *slash-char* "/") (std-strchg s "\\" *slash-char*) (std-strchg s "/" *slash-char*) ));;; );;; it's safer to use this than the simple strcat.;;; it corrects slashes on paths. the extension must have a leading dot.;;;;;; this may be expanded in the future to support more systems.;;; it may be used to convert between different filesystems,;;; dos 8.3 <==> ntfs <==> unix for example;;; or to convert upper<->lowercase;;; we will see if acad will support linux in the next years.;;; then this will be topic. mfc already runs on linux. windows;;; emulators also. but that depends on the development of the desktop;;; market.(defun std-make-pathname (pathnames / ext name); try to guess what's the; path, name and extension: (if (stringp pathnames) (setq pathnames (list pathnames)) ) (if (= "." (std-firstchar (last pathnames))) (setq ext (last pathnames) pathnames (std-butlast pathnames) ) (setq ext "") ) (if (member (std-lastchar (last pathnames)) *std:slash-chars*) (setq name "") (setq name (cond ((last pathnames)) (t "" ) ) pathnames (std-butlast pathnames) ) ) (strcat (std-strjoin (mapcar (function std-fpslash) pathnames ) "" ) name ext ));;; those 5 have sometimes problems to be loaded from fileext.fas;;; avoid reload warnings in vl;;; (if std-%unprotect-assign;;; (std-%unprotect-assign;;; '(;std-filename-base std-filename-extension-or-nil std-filebase;;; ;std-filename-directory std-filename-split;;; ;std-filename-extension;;; std-file-modtime std-file-systime;;; std-file-readable-p std-file-directory-p)));;; filename without path and extension;;; commonly called basename, hmm.. there's a problem with;;; the vl extension which returns the filebase and not the basename;;; name confusion!;;; "l:/src/test.lsp" => test(defun std-filename-base (fname) (cadr (std-filename-split fname)));;; file extension or nil. needed sometimes for cond;;; "l:/src/test.lsp" => ".lsp";;; "l:/src/test." => ".";;; "l:/src/test" => nil(defun std-filename-extension-or-nil (fname / s) (setq s (std-filename-extension fname)) (if (/= "" s) s ));;; filename without extension, ex: "l:\\src\\acad";;; for confusing stuff see std-filename-base;;; unifies path slashes;;; "l:/src/test.lsp" => "l:\\src\\test"(defun std-filebase (fname) (std-make-pathname (std-firstn 2 (std-filename-split fname)) ));;; only path of std-filename;;; unifies path slashes.;;; "l:/src/test.lsp" => "l:\\src\\"(defun std-filename-directory (fname) (car (std-filename-split fname)));;; improved by fileext, first load the normal ones then the extended;;; but be sure that then the normal ones are not reloaded.;;; splits fspec in path, filename and extension;;; unifies path slashes.;;; "c:\acad\lisp.doc" => ("c:\acad\" "lisp" ".doc");;; "i:xx" => ("i:" "xx" "");;; "l:/german"=> ("l:/" "german" "");;; but;;; "l:/german/"=> ("l:/german" "" "");;; "acad/../acad/lsp" => ("acad\\..\\acad\\" "lsp" "");;; "acad/../lisp.lsp" => ("acad\\..\\" "lisp" ".lsp");;; "acad/../.lsp" => ("acad\\..\\" "" ".lsp");;; "./acad/" => ("acad\\" "" "")(defun std-filename-split (fspec / fn lst ext name path) (if (= fspec (car *std:cached-fsplit*)) (cdr *std:cached-fsplit*) (progn; fixed v0.3020 for "./" (setq fn (std-strchg (std-%slash-unify fspec) (strcat "." *slash-char*) "" ) ) (setq lst (reverse (std-string->list fn))) (setq ext (member 46 lst)); the last dot (if (and ext (/= 46 (cadr ext)) ); fixed v0.3020 for ".."(setq ext (substr (std-list->string (reverse lst)) (length ext)) lst (reverse (std-string->list (substr fn 1 (- (strlen fn) (strlen ext) ) ) ) ))(setq ext "") ) (setq path (member (ascii *slash-char*) lst)) (if (not path)(setq path (member 58 lst)) ); (ascii ":") (setq name (std-list->string (reverse (std-firstn (- (length lst) (length path) ) lst ) ) ) ) (setq path (if path (std-list->string (reverse path)) "" ) ); (setq name (substr; (std-list->string lst) 1; (- (length lst); (strlen path)))); (list path (std-list->string; (reverse (std-string->list name))); ext) (cdr(setq *std:cached-fsplit* (cons fspec (list path name ext))) ) ) ));;; file extension, ex: ".doc" or "", may not return nil!;;; "l:/src/test.lsp" => ".lsp";;; "l:/src/test." => ".";;; "l:/src/test" => ""(defun std-filename-extension (fname) (caddr (std-filename-split fname)));;; readable file? return the filename(defun std-file-readable-p (fname / f); => fname or nil (if (and(stringp fname)(setq f (open fname "r")) ); avoid std-remove (progn (close f) fname ) ));;; is this a directory?;;; this is quite dirty and won't probably work on all filesystems.;;; on some clibs it failed with ntfs, but for now it should work;;; with fat and ntfs.;;; note: (findfile "<dir>/.") doesn't work,;;; (findfile "<dir>/nul") neither;;; returns t or nil;;; 2000-12-09 psw: it will fail with unc pathnames;;; (std-%file-directory-p "d:\\prog\\") => nil;;; (std-%file-directory-p "d:\\prog") => t;;; (std-%file-directory-p "d:/prog") => t;;; (std-%file-directory-p "d:/prog/") => t;;; 2000-12-31 05:55:35 rurban on ntfs5;;; (std-file-directory-p "\\\\reini\\install\\cad") => nil;;; (std-file-directory-p "//reini/install/cad/") => nil;;; (load "fileext.fas");;; (std-%file-directory-p "\\\\reini\\install\\cad") => t;;; (std-%file-directory-p "//reini/install/cad/") => t;;; (std-load-external "stdlib14.arx");;;(defun std-file-directory-p (path) (if (std-functionp std-%file-directory-p) ; fixed since adsrx 0.5005 (std-%file-directory-p path) (and (std-probe-file (strcat (std-fpslash path) "NUL")) ) ));;; directory name or nil. needed sometimes for cond(defun std-filename-directory-or-nil (fname / s) (setq s (std-filename-directory fname)) (if (/= "" s) s ));;; filename and extension without path, ex: "test.doc"(defun std-filename (fname / lst) (strcat (cadr (setq lst (std-filename-split fname))) (caddr lst) ));;; path must exist?(defun std-force-path (path fname) (strcat (cond ((std-file-directory-p path) (std-fpslash path) ) ((std-filename-directory-or-nil path)) (t (std-fpslash path) ) ) (std-filename fname) ));;; when extension is in fname return this,;;; else append extension(defun std-def-extension (fname defext / lst) (setq lst (std-filename-split fname)) (if (/= "." (std-firstchar defext)) (setq defext (strcat "." defext)) ) (strcat (car lst) (cadr lst) (if (= "" (caddr lst)) defext (caddr lst) ) ));;; append or replace extension(defun std-force-extension (fname ext) (if (/= "." (std-firstchar ext)) (setq ext (strcat "." ext)) ) (strcat (std-filebase fname) ext));;; is it a long filename?;;; at least longer than allowed by msdos 8.3;;; check also (std-sys-longfname-p);;; it must not be just a too long name, it may only be a;;; illegal dos name but legal filename in other filesystems.;;; embedded spaces e.g.(defun std-longfnamep (fname) (or (> (strlen (std-filename-base fname)) 8) (> (strlen (std-filename-extension fname)) 4) (std-strpos " " fname) ));;; (std-filename-upcase fname);;; upcase of filename, but ignore long filenames.;;; long filenames must be case-sensitive! fixes "/.." paths;;; this is for aesthetics only.;;; don't use it under unix as you probably know.;;; path slashes must be unified before?(defun std-filename-upcase (fname / paths path p) ; upcase all paths; seperately (if (/= "" (setq path (std-filename-directory fname))) (progn (setq paths (std-strsplit (std-fpslash path) *slash-char*)); resolve; in between relative ".."; ("dir1" "dir2" ".." "dir3") =>; ("dir1" "dir3") (while (and (setq p (std-position ".." paths)) (> p 0) )(setq paths (append (std-firstn (1- p) paths) (std-nthcdr (1+ p) paths) )) ) (setq path (std-strjoin (if (= ":" (std-lastchar (car paths))) ; driv; e only (cons (std-strcase (car paths)) (mapcar (function std-filename-upcase) (cdr paths) ) ) (mapcar (function std-filename-upcase) paths ) ) *slash-char* ) ) (setq fname (std-force-path path fname)) ) ) (cond ((not (stringp fname))) ((std-longfnamep fname); if at least the extension is <= 3; + dot, upcase the ext (if (<= (strlen (std-filename-extension fname)) 4) (strcat (std-filename-directory fname) (std-filename-base fname) (strcase (std-filename-extension fname)) ) fname ) ) ((std-acad-connection-p) (strcase fname) ) (t (std-strcase fname) ) ));;; path slashes must be unified before!;;; (std-%filename-fix-path "dir1/dir2/../dir3/") => "dir1/dir3";;; "./" => "", "/./" => "/";;; fixed by serge pashkov(defun std-%filename-fix-path (path / p paths) (setq path (std-strchg path (strcat "." *slash-char*) "")) (if (std-strpos (strcat *slash-char* "..") path) (progn (setq paths (std-strsplit (std-fpslash path) *slash-char*)); ("dir1"; "dir2" ".." "dir3") => ("dir1"; "dir3") (while (>(setq p (std-position ".." paths))0 )(setq paths (append (std-firstn (1- p) paths) (std-nthcdr (1+ p) paths) )) ) (setq path (std-strjoin paths *slash-char*)) ) path ));;; path slashes need not to be unified here(defun std-%filename-abspath-p (path) (or (= (substr path 2 1) ":") (member (substr path 1 1) *std:slash-chars*) ));;; returns full absolute filepath.;;; doesn't work yet, only on dos based systems.;;; (std-truename "acad/../acad/test.lsp") => "c:/acad/test.lsp"(defun std-truename (fname / lst path drive cur) (if (std-module-defined-p "STDLIB-ADS") (std-%fullpath fname) (progn (setq lst (std-filename-split fname) path (std-%filename-fix-path (car lst)) drive "" ); check for drive (dos, win only) (if (std-sys-dosbased-p)(if (= ":" (substr path 2 1)); drive given (setqdrive (substr path 1 2)path (substr path 3) ) (setq drive (std-current-drive))) ); check for absolute path (if (/= (substr path 1 1) *slash-char*)(setq path (std-%filename-fix-path (strcat (std-current-path) path ) )) ); add current path (if (/= ":" (substr path 2 1)); no drive added?(setq path (strcat drive path)) ) (std-force-path path fname) ) ));;; cache this? only on dos it was possible to change the workdir,;;; r13 dos and unix also.(defun std-current-drive () (if (and(std-ver-r14-p)*std:current-drive* ) *std:current-drive* (substr (std-current-path) 1 2) ));;; warning! this is poor code!;;; should be overridden by external code (fileext);;; returns current dos, os/2 or unix path: "d:\\path\\...\\" or;;; "/path/.../".;;; warning: on dos or os/2 results may be false unpredictably.;;; if sh (shell) fails with insufficient memory, increase its size;;; in acad.pgp. uses cached paths cached paths on r14 or later.;;; previous versions allowed the change of the workdir.(defun std-current-path(/ path f temp n) (cond ((std-functionp std-%current-path) (std-%current-path) ) ((and (std-ver-r14-p) *std:current-path* ) *std:current-path* ) (t (setq temp (std-filename-mktemp nil)) (close (open temp "w")) (setq path (car (std-%command-shell-wait(cond ( (std-sys-dosbased-p) "CD" ) ((std-sys-unix-p) "pwd" ) (t (std-cerror (std-msg "unknown operating system for STD-CURRENT-PATH" ) ) ))temp ) ) ) (if path (setq *std:current-drive* (substr path 1 2) *std:current-path* (std-fpslash path) ) (std-cerror (std-msg "SHell failed")) ) ) ));;; without directory access and absolute path resolving yet;;; "acad/test.lsp" <==> "../<actdir>/acad/test.lsp" -cross-relative;;; "acad/test.lsp" <==> "<drive>:/<path>/acad/test.lsp"-absolute(defun std-same-files-p(fname1 fname2) (cond ((=(setq fname1 (std-filename-upcase fname1))(setq fname2 (std-filename-upcase fname2)) ) ); one absolute and one relative:; resolve ((apply (function and) (mapcar (function std-%filename-abspath-p) (list fname1 fname2) ) ) (= (std-truename fname1) (std-truename fname2)) ); ??; ((equal (std-filename-split fname1); (std-filename-split; fname2))); to do: check actual filesystem; relative pathnames must be; compared (t nil ) ));;; -------------------------------------------------------------------73;;; directory (filesystem dependent) functions;;; open files are kept in the global list *fopen* and for;;; non-vl systems also in the alist *std:fopen<->fname* to be able to;;; the filename from the file object and vice versa.;;; (for std-file-backup on open files and similar problems);;; we must keep track of open files for error handling(defun std-fopen (fname ch / f) (if (/= "" fname) (setq f (open fname ch)) ) (if (member f *fopen*) nil (iff (setq *fopen* (cons f *fopen*)) ) ); for (std-%alisp-file->filename f); we also carry a global alist (if (andf(not (std-vl-p)) ) (std-push (cons f fname) '*std:fopen<->fname*) ) f);;; what to do on nil?;;; 1) raise an error or;;; 2) do nothing (good on the user side) or;;; 3) raise an continuable error only on *debug* (good for developers);;; either treat it as programming error, or;;; simplify loops like this:;;; (if (setq f (std-fopen fname "r"));;; (while (setq s (read-line f));;; ...;;; ));;; (std-fclose f); which means to accept nil;;; this way another progn indentation is avoided;;; we chose 2 and 3 and let already closed files pass also.(defun std-fclose (f) (if (andf(std-open-file-p f) ) (progn (close f); the following may be turned off; for performance reasons.; only useful if the number of; closed files will get too large. (if (not (std-vl-p))(setq *std:fopen<->fname* (std-remove (assoc f *std:fopen<->fname*) *std:fopen<->fname* )) ) (setq *fopen* (std-remove f *fopen*)) ) (if*debug* (if (not f)(std-cerror (list "(STD-FCLOSE nil)" *fopen*))(std-cerror (list(std-msg "STD-FCLOSE on already closed file - ")f*fopen* )) ) ) ));;; close all my open files in case of errors,;;; is placed in the error handler(defun std-fcloseall () (mapcar (function (lambda (f)(if (and (std-filep f) (std-open-file-p f) ) (close f)) ) ) *fopen* ) (setq*fopen*nil*std:fopen<->fname* nil ));;; is the file (filepointer) already open?;;; we have no predicate if the file was already closed.;;; (close) with a closed file will throw an error. this predicate;;; is needed for error handling cleanup, in unpredictable code areas;;; where we don't know if the file was not already closed.;;; => t or nil(defun std-open-file-p (f); (if (and (std-vl-p); (not (std-module-defined-p; "stdlib-ads")); (numberp *fileext-version*); (>= *fileext-version* 0.53); ); ;; this detects all opened; files (binio-open, open,; std-fopen).; ;; in visual lisp <r15 or vital; lisp via fileext.fas>; this fails now...; (std-%open-file-p f); simply this:; look up the file pointer in; *fopen* (and (member f *fopen*) ));;; );;; return t if the filename belongs to an open file.(defun std-open-filename-p (fname) (and (stringp fname) (std-open-filename->file fname) ));;; return nil or the file object which belongs to the filename,;;; by inspecting the *fopen* list plus *std:fopen<->fname* in non-vl;;; systems.(defun std-open-filename->file (_fname) (if (findfile _fname) (car (std-member-if (function (lambda (x) (and x (std-same-files-p x _fname) ) ) ) (mapcar (function std-file->filename) *fopen* ) ) ) ));;; the reverse: get filename for the open file object(defun std-file->filename (f) (if (std-vl-p) (std-%vl-file->filename f) (std-%alisp-file->filename f) ));;; the vl fileobject contains the filename in the printed object name;;; #<file "filename">(defun std-%vl-file->filename (f) (if (std-filep f) (std-str-1 (substr (std-princ-to-string f) 8)) ));;; alisp not #<file: #3f322446> so we use a global assoc list.(defun std-%alisp-file->filename (f) (cdr (assoc f *std:fopen<->fname*)));;; -------------------------------------------------------------------73;;; recursive cycles in r12dos! already defined in stdinit;;; (defun std-probe-file (fname / f);;; (if (std-acad-connection-p);;; (if (std-filename-directory-or-nil fname);;; (findfile fname);;; (findfile (std-force-path "./" fname));;; ));;; (if (and (stringp fname);;; (setq f (open fname "r"))); avoid std-remove;;; (progn (close f) fname)));;; return all matching and existing filenames.;;; search fspec in lst (dirs also), which defaults to "*.*";;; note: using wcmatch and not console globbing style;;; (defun std-glob (_fspec lst);;; (if (not lst) (setq lst (std-directory-files "*")));;; (if (std-acad-connection-p);;; (std-remove-if-not;;; (quote;;; ; );;; (lambda (fn);;; (and (or (= _fspec "");;; (wcmatch fn _fspec));;; (std-file-readable-p fn))));;; lst);;; (std-;;; (std-remove-if-not 'std-file-readable-p;;; (std-directory-files _fspec));;; lst);;; );;; );;; list of files matching fspecs and dirs.;;; glob-style wildcards allowed. returns filenames without path prefix.;;; a path should have either a "/" or "\\" as last char or explicitly;;; use "/*". unc names are allowed. (tested under nt);;; "c:/acad/*" => ("." ".." "acad.lsp" ...);;; "c:/acad/" => ("." ".." "acad.lsp" ...);;; but;;; "c:/acad" => ("acad")(defun std-directory-files (fspec / base) (std-%directory-files (std-filename-directory fspec) (cond ((/= "" (setq base (std-filename-base fspec) ) ) base ) (t nil ) ) 0 ));;; as std-directory-files, but no dirs, includes the given path prefix.;;; => ("c:/acad/support/acad.lsp" "c:/acad/support/acadr14.lsp"...);;; todo: glob-style wildcards, but we'll better change to wcmatch regex.(defun std-glob-files (fspec / _path) (setq _path (std-filename-directory fspec)) (mapcar (function (lambda (fn)(std-force-path _path fn) ) ) (std-%directory-files (cond((std-filename-directory-or-nil fspec))(t nil) ) (cond((/= "" (std-filename fspec)) (std-filename fspec))(t nil) ) 1 ) ));;; all dirs matching fspec, but no files.;;; no path prefixes, wildcards allowed;;; "c:/acad" => ("." ".." "support" "sample"...);;; todo: glob-style wildcards, but we'll better change to wcmatch regex.;;; we'll use std-findfile-paths then(defun std-glob-dirs (fspec) (std-%directory-files fspec nil -1));;; convert glob-style patterns to regular wcmatch patterns;;; since wcmatch already uses most of the gloib semantics it makes no;;; sense;;; * -> .*, . -> \., ? -> .,;;; *.* -> .*\..*;;; (defun std-%glob-regexp (pattern);;; (setq pattern (std-strchg pattern "." "\."));;; (setq pattern (std-strchg pattern "?" ".")) ; wcmatch has this;;; (setq pattern (std-strchg pattern "*" ".*")) ; wcmatch has this;;; );;; return the first found file in the user-defined module-path;;; or the standard acad library path. no wildcards!;;; cache the unified list and remove duplicates.;;; cache re-init problem when the user changes the search-path setting!;;; (setq *std:search-path* nil)(defun std-findfile (fname) (if *std:search-path* (std-findfile-paths fname *std:search-path*) (std-findfile-paths fname (setq *std:search-path* (std-ordered-union *module-path* (std-acad-library-paths) ) ) ) ));;; first found fspec in the given path list, no wildcards!(defun std-findfile-paths (_fname pathlst / found) (if (std-%filename-abspath-p _fname) (findfile _fname); absolute path given (progn; relative or no path (while (and (not found) pathlst ); use findfile instead of; std-probe-file?(setq found (std-probe-file (std-force-path (car pathlst) _fname)) pathlst (cdr pathlst)) ) found ) ));;; search file with all extensions in given pathnames, extensions first.;;; first try the first extension in all paths,;;; then for each other extension all paths. (opposite to;;; std-%findfile-exts);;; return first found filename.;;; no wildcards yet;;; (std-findfile-exts "acad" '("mns" "mnu") (std-acad-library-paths))(defun std-findfile-exts (path extlst pathlst / found) (while (and extlst (not found) ) (setq path (std-force-extension path (car extlst))) (setq found(if (std-filename-directory-or-nil path) (std-probe-file path); explicit directory given (std-findfile-paths path pathlst)) ) (setq extlst (cdr extlst)) ) found);;; search file with all extensions in given pathnames, paths first.;;; first try path, then in each path all extensions.;;; return first found filename.;;; no wildcards yet(defun std-%findfile-exts (path extlst pathlst / fname) ; fast version (while (and pathlst (not fname) ) (setq path (std-force-path (car pathlst) fname)) (setq fname(if (std-filename-extension-or-nil path) (std-probe-file path); explicit extension given (std-%findfile-try-exts path extlst)) ) (setq pathlst (cdr pathlst)) ) fname);;; try all extensions in the path (=filebase),;;; no extension allowed in path(defun std-%findfile-try-exts (path extlst / fname) (while (and extlst (not fname) ) (setq fname (std-probe-file (strcat path (car extlst))) extlst (cdr extlst) ) ) fname);;; cached version;;; cache re-init problem when the user changes the search-path setting!;;; (setq *std:acad-library-paths* nil)(defun std-acad-library-paths () (cond (*std:acad-library-paths*) ((setq *std:acad-library-paths* (std-remove-duplicates (mapcar(function (lambda (p) (std-fpslash (std-filename-upcase p) ) ))(std-adjoin (getvar "DWGPREFIX") (std-string->strlist (cond ( (std-ver-fcad-p) (getenv "FCADSUP") ) (t (getvar "ACADPREFIX") ) ) ";" )) ) ) ) ) ));;; old stuff for textfiles only:;;; backup for text files(defun std-ft-backup (fspec) (if (std-string-not-equal ".BAK" (std-filename-extension fspec)) (std-ft-copy fspec (std-force-extension fspec ".BAK")) ));;; copies textfile file1 to file2(defun std-ft-copy (file1 file2 / s *error*) (setq *error* *std-error*) (setqfile1 (std-fopen file1 "r")file2 (std-fopen file2 "w") ) (while (setq s (read-line file1)) (write-line s file2) ) (std-fclose file1) (std-fclose file2) (princ));;; append textfile file2 after file1. extends file1(defun std-ft-append (file1 file2 / s *error*) (setq *error* *std-error*) (setqfile2 (std-fopen file2 "r")file1 (std-fopen file1 "a") ) (while (setq s (read-line file2)) (write-line s file1) ) (std-fclose file1) (std-fclose file2) (princ));;; compares two textfiles. is there any useful usage?;;; fixed by serge pashkov(defun std-ft-equal (file1 file2 / s okay *error*) (setq *error* *std-error*) (setqfile1 (std-fopen file1 "r")file2 (std-fopen file2 "r")okay t ) (while (and okay (setq s (read-line file1)) ) (if(/= s (read-line file2)) (setq okay nil) ) ); the 1st file is exhosted. is the; 2nd too? set nil if not. (if (and(null s)(read-line file2) ) (setq okay nil) ) (std-fclose file1) (std-fclose file2) okay);;; returns the line-th line from the textfile;;; line: one-based int(defun std-ft-nth-line (fname line / s f i *error*) (setq *error* *std-error*) (setqf (std-fopen fname "r")i 0 ) (while (and f (< i line) (setq s (read-line f)) ) (setq i (1+ i)) ) (std-fclose f) s);;; returns a list of lines from the textfile;;; from, to: one-based int(defun std-ft-lines (fname from to / s f i lst *error*) (setq *error* *std-error*) (setqf (std-fopen fname "r")i 0 ) (while (and f (< i from) (setq s (read-line f)) ) (setq i (1+ i)) ) (if s (setq lst (list s)) ) (while (and f (< i to) (setq s (read-line f)) ) (setq lst (cons s lst) i (1+ i) ) ) (std-fclose f) (reverse lst));;; insert asc-lst in text file fname after line num (starting with 1);;; useful for manipulating menus if you know the line number.;;; fixed by serge pashkov(defun std-ft-insert (fname strlst num / i fr fw tmp-fname s *error*) (setq *error* *std-error*) (setqfr (std-fopen fname "r")fw (std-fopen (setq tmp-fname (std-filename-mktemp nil)) "w" )i 0 ) (while (< i num) (setq i (1+ i)) (if(setq s (read-line fr)) (write-line s fw) (setq i num) ) ); eof: break out (foreach s strlst; insert lst (write-line s fw) ) (while (setq s (read-line fr)); append rest (write-line s fw) ) (std-fclose fr) (std-fclose fw) (std-file-delete fname); fixed; rename tmpf to fname (std-file-rename tmp-fname fname));;; handles dots in module names. omits extension.;;; needed for (std-load-external "fileext.fas");;; this is safer than the previous definition.;;; assure that the value is between the given bounds(defun std-%minmax (low high val) (max low (min high val ) ));;; show contents of textfile in dialog with optimized size.;;; simple version, with action callback for "list".;;; action_tile callback function for the list with the;;; four arguments: $key $value $data $reason;;; (lambda (key val data how);;; (cond ((= how 4) (double-click-action key val data));;; (t (single-click-action key val data))))(defun std-showfile-dialog (fname title action / width height lines dcl id l) (if (not title) (setq title "") ); optimize the dialog size (setqlines (std-read-file-strings fname); 33 lines is enough to stay; below 600 pixelheight (std-%minmax 10 33 (setq l (length lines)))width (if (> l *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (std-%minmax 35 85 (apply (function max) (mapcar (function strlen) lines ) ) ) )dcl (std-%emit-showfile-dialog height width) ); fcad! (or (and (setq id (load_dialog dcl)) (if *dlg-pt*(new_dialog "showfile" id "" *dlg-pt*)(new_dialog "showfile" id) ) ) (std-error (std-msg "std-%showfile-dialog aborted")) ) (set_tile "title" title) (start_list "list") (foreach linelines (add_list line) ) (end_list); store the position to be able to; cascade the next dialogs,; possibly created by the action; callback on the list entries. (action_tile "accept" "(setq *dlg-pt* (done_dialog 1))") (action_tile "cancel" "(setq *dlg-pt* (done_dialog 0))") (if (std-functionp action) (progn; support the $data argument for the; action function callback; to avoid global data (but it is; not needed generally); with linked vl use $data,; otherwise do not care.; thanksfully we have dynamic; binding (client_data_tile "list" (std-strjoin lines "\n")) (action_tile"list"(strcat"("(std-prin1-to-string action)" $key $value $data $reason)") ) ) ) (start_dialog); because this dcl is created; dynamically we will delete; it from memory. we won't use; caching, it is fast enough.; the temp file itself is deleted on; the next call to; std-var-restore as every single; temp file during a session. (unload_dialog id))(defun std-%emit-showfile-dialog (height width) (if (not width) (setq width 80) ) (if (not height) (setq height 25) ) (std-%file-write-lines; this temp filename gets deleted on; (std-var-restore) (std-filename-mktemp "SHOW.DCL") (list "dcl_settings : default_dcl_settings { audit_level = 0; }" "list : list_box {" " key = \"list\";" " tabs = \"9 17 25 33 41 49 57 65 73 81\";" (strcat " width = " (itoa (+ 7 width) ) ";" ) (strcat " height = " (itoa (+ 2 height) ) ";" ) "}" "showfile : dialog {" " label = \"\"; key = \"title\";" " list;" " ok_cancel_err;" "}" ) ))(defun std-%file-write-lines (fname lines / f) (if (setq f (std-fopen fname "w")) (progn (foreach s lines(write-line s f) ) (std-fclose f) fname ) ))(defun std-%showfile-console (fname / _std:f s *error*) (setqfname (cond((std-probe-file fname))((std-acad-connection-p) (findfile fname)) ) ) (if (setq _std:f (std-fopen fname "r")) (progn (defun *error* (s)(std-fclose _std:f)(princ s) ) (while (setq s (read-line _std:f))(terpri)(princ s) ) (std-fclose _std:f) ) ));;; print in a dialog or on console(defun std-showfile (fname) (if (and(std-acad-connection-p)(not (zerop (getvar "CMDDIA"))) ) (std-showfile-dialog fname (strcat (std-msg "Contents of ") fname) nil ) (std-%showfile-console fname) ));;; returns content of file as list of strings,;;; ?? ignoring lines starting with ";";;; leaving empty lines(defun std-read-file-strings (n / f s lst *error*) (setq *error* *std-error*) (if (andn(setq f (std-fopen n "r")) ) (progn (while (setq s (read-line f))(if (/= (std-firstchar s) ";") (setq lst (cons s lst))) ) (std-fclose f) ) ) (reverse lst));;; treats file as list of lisp-like lines,;;; ignoring lines starting with ";";;; returns a list of lists.(defun std-read-file-list (n / f s lst *error*) (setq *error* *std-error*) (if (andn(setq f (std-fopen n "r")) ) (progn (while (setq s (read-line f))(if (and (/= s "") (/= (std-firstchar s) ";") ) (setq lst (cons (read (strcat "(" s ")")) lst))) ) (std-fclose f) ) ) (reverse lst));;; -------------------------------------------------------------------73;;; external definitions:;;; directory access funcs:;;; functions which may be improved by external extensionsdefun std-file-exist-p(fname); => t or nil (if (std-probe-file fname) t ));;; checks for file creation rights.;;; you may have the right to create this file but not to delete it.;;; destructive version! use with care! deletes the old file if it exists.;;; fixed by serge pashkov(defun std-file-writable-p (fname / f); => fname or nil (and (stringp fname) (std-file-exist-p fname) (setq f (std-fopen fname "w")) (progn (std-fclose f); the os may allow creation but not; deletion!; this is not detected, so there may; be 0 byte files around. (std-file-delete fname) fname ) ));;; consistent temp. filenames under all systems and different from the;;; vl extension filenames to be able to delete them automatically.;;; fname defaults to : "%temp/$std~001.ac$" instead of "%temp/$vl~~001";;;;;; std-filename-mktemp is most often called by std-princ-to-string on;;; not vl systems, in "autolisp compatibility mode".;;;;;; we use a global list *std:mktemp* of those to delete them on end;;; or when the number of created files exceed a certain filesystem;;; dependent treshold. we use 500. with ~1000 files on a fat %temp%;;; the system slows down inacceptable.(defun std-filename-mktemp (fname) (std-default '*std:mktemp-length* 0) (std-default '*std:mktemp-treshold* 500) (setqfname (if (not fname)(std-%filename-mktemp "$STD~.AC$")(std-%filename-mktemp (std-make-pathname (list (std-filename-directory fname) (cond( (not fname) "$STD~"); vlisp; alike(t (std-filename-upcase (std-filename-base fname) )) ) (cond( (std-filename-extension-or-nil fname))(t ".AC$") ) ) )) ) ); after about 500 files it becomes; inacceptably slow.; so we try delete all temp files as; with a (gc); recursive std-filename-mktemp; invocations must not hit this; limit. (if (> *std:mktemp-length* *std:mktemp-treshold*) (std-%delete-mktemp) ) (setq*std:mktemp* (cons fname *std:mktemp*)*std:mktemp-length* (1+ *std:mktemp-length*) ) fname);;; use std-sys-longfname-p(defun std-%filename-mktemp (fname / path ext base i fn maxlen) (setqmaxlen (if (std-sys-longfname-p) 23 6 ) ); fixed (setqpath (cond ((std-filename-directory-or-nil fname)) ((not (std-acad-connection-p))"" ) ((getenv "TEMP")) ((getenv "TMP")) (t"" ) )ext (cond ((std-filename-extension-or-nil fname)) (t".AC$" ) )base (cond ((not fname)"$STD~" ); vlisp alike (t(std-filename-upcase (std-filename-base fname)) ) )base (if (= (std-firstchar base) "$") (substr base 1 maxlen) (substr (strcat "$" base) 1 maxlen) )base (strcat (std-fpslash path) base)i 0 ) (while (std-file-exist-p (setq fn (strcat base (std-string-left-pad-char (itoa i) 3 "0" ) ext ) ) ) (setq i (1+ i)) ) fn);;; we try to delete all temp. filenames created with;;; std-filename-mktemp.;;; 1) we cannot blindly delete all files, no open files.;;; that's why *std:mktemp* may not be empty afterwards.;;; 2) if we would know the fileobject file-delete would be much faster!;;; but then we would need something like std-fopen-temp and;;; (file-delete file)(defun std-%delete-mktemp (/ f lst) (std-%file-bulk-delete *std:mktemp*) (setq*std:mktemp* (std-remove-if 'null (mapcar (function std-probe-file) *std:mktemp* ) ) ) (setq *std:mktemp-length* (length *std:mktemp*)));;; returns dos 8.3 file name, by serge pashkov;;; use ads std-%dos-filename instead;;; works only on dosbased systems, (std-sys-dosbased-p)=>t;;; how: we use shell command dir with reassigned output to temporary file;;; and subsequent parsing the output file.;;; because autocad prohibits os calls like "dir > out";;; we make temporary command file (bat file) containing;;; this command and call it via autocad "shell" command.;;; temporary files should be deleted after parsing.;;; assumed that we can sufficient rights for creating/writing.;;; uses std-sleep for delay;;; ???error processing???;;; maybe to be improved, quite dirty(defun std-dos-filename(fname / f batname outname fn s eof found fnlst dosfname *error*) (if (std-module-defined-p "STDLIB-ADS") (std-%dos-filename fname) (progn (setq *error* *std-error*) (if (std-longfnamep fname)(progn (setqoutname (std-filename-mktemp "$1.tmp")batname (std-filename-mktemp "$1.bat")dosfname nil ) (if (setq f (std-fopen batname "w")) (progn (write-line(strcat"DIR "(std-%stringquote-filename fname)" >"outname)f ) (std-fclose f) (std-%command-shell-wait batname outname); to be improved to; parse the result value... (if (setq f (std-fopen outname "r"))(progn; get fname w/o path (setq fn (std-filename fname)) ; parse output (setqfound nileof nil ) (while (not (orfoundeof ) ) (if(setq s (read-line f)) ; this long name? 45 -; start of long file name (if (std-stricmp fn (substr s 45)); found - parse 12; first chars(progn (setq fnlst (std-strtok (substr s 1 12) " ")) (if (= 1 (length fnlst)) (setq dosfname (car fnlst)) (setq dosfname (strcat (car fnlst) "." (cadr fnlst) ) ) ) (setq found t)) ) (setq eof t) ) ) (std-fclose f))(std-error (std-msg "DIR reassign failed")) ) ) (std-error (strcat (std-msg "Cannot open ") batname)) ) dosfname)(std-filename-upcase fname) ) ) ))(defun std-%open-warn-close (fname) (if (std-open-filename-p fname) (progn (std-fclose (std-open-filename->file fname)) ; 19-apr-00 (std-warn(list (std-msg "Closed open file ") "\"" fname "\"") ) t ) ));;; create a backup copy with the .bak extension and;;; the original file attributes (timestamp).;;; a simple (std-file-copy fname bak) is wrong.(defun std-file-backup (fname / bak) (cond ((= ".BAK" (std-strcase (std-filename-extension fname))); added 19-apr-; 00 (std-warn (list "(STD-FILE-BACKUP \"" fname "\")" (std-msg " failed") ". " (std-msg "Cannot backup a .BAK file") ) ) ) (t (if (std-file-readable-p fname) (progn (std-%open-warn-close fname) (std-file-delete (setq bak (std-force-extension fname ".BAK")) ) ) ) (std-file-rename fname bak) (if (std-probe-file fname) (progn (std-%open-warn-close fname) (std-file-rename fname bak) (if (std-probe-file fname) (std-warn (list "(STD-FILE-BACKUP \"" fname "\")" (std-msg " failed") ) ) ) ) ) (std-file-copy bak fname) ) ));;; surround the possibly illegal name with spaces for the command shell(defun std-%stringquote-filename (fname / f) ; convert slashes (setqf (std-make-pathname (list (std-filename-directory fname) (std-filename fname) ) ) ); quote fname for the shell if; there's a space (if (std-longfnamep f) (strcat "\"" f "\"") f ));;; for now we have terribly performance problems with deleting a lot of;;; files, such as cleanup after a lot of std-princ-to-string.;;; that's why we provide this bulk file deleter which does some;;; littel optimization on not vl systems (still not using doslib);;; accepts wildcards and uses less shell calls. used for;;; std-%delete-mktemp;;; ex. (std-%file-bulk-delete '("c:/tmp/$std~*.ac$"))(defun std-%file-bulk-delete (fnames) (cond ((std-vlisp-p) (mapcar (function vl-file-delete) fnames ) ) ((std-vill-p) (mapcar (function vlx-file-delete) fnames ) ) ((member (type std-file-delete) '(usubr subr exsubr exrxsubr) ) (mapcar (function std-file-delete) fnames ) ) ((std-sys-dosbased-p); stupid dos cmdline has a limit of; 256 chars?; if too much r13 crashes!; 12*20 = 240 (foreach x(std-split-list 12 fnames) (std-%command-shell-wait (strcat "for %s in (" (std-strjoin (mapcar (function std-%stringquote-filename) x ) " " ) ") do del %s" ) nil ) ) ) ((std-vlisp-beta1-p) (mapcar (function file-delete) fnames ) ) ((std-sys-unix-p) (std-%command-shell-wait (strcat "rm " (std-strjoin (mapcar (function std-%stringquote-filename) fnames ) " " ) ) nil ) ) (t (mapcar (function std-file-delete) fnames ) ); no wildcards! ));;; user version:;;; "is any of the dependents newer than the target?";;; t if any dependent is newer than the target or there's no target.;;; used to update a target dependent on any source file like in make.;;; the argument deps may be filename or a list of filenames.;;; so far it makes use of a fast internal file-modtime function which;;; returns the date as seconds since 1970.;;; file-modtime: the number of non-leap seconds since 00:00:00 utc,;;; january 1, 1970;;; e.g.: 852559628 <==> 6.1.97 15:13 <==> 1/6/97 15:13;;; <==> 19970106.1513(defun std-file-newer-p(_target deps / x) (cond ((not (std-file-modtime _target))) ((consp deps) (if (> (length deps) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) ) (<(std-file-modtime _target)(apply (function max) (mapcar (function (lambda (x)(cond ( (std-file-modtime x) ) (t (+ 1 (std-file-modtime _target) ) )) ) ) deps )) ) ) ((setq x (std-file-modtime deps)) (< (std-file-modtime _target) x) ) ));;; strict version: both files must exist!(defun std-%file-newer-p (new old) (> (std-file-modtime new) (std-file-modtime old)));;; seconds since 1.1.1970 utc as fixnum;;; note: this may be inexact and different to the fileext.fas version!(defun std-file-modtime(fname / date) (cond; incorrect results!; (std-%file-modtime; (std-%file-modtime fname)) ((and vl-file-systime (setq date (vl-file-systime fname)) ) (fix (std-%datlst->internal-time (std-select date '(0 1 3 4 5 6 7)) ) ) ) ((setq date (std-file-systime fname)) (fix (std-%datlst->internal-time (std-cdate->datlst date))) ) ));;; either call doslib, fileext or just return all possible(defun std-get-drive-list () (cond ((std-doslib-p) (dos_drives) ); mac and unix have no drives ((not (std-sys-dosbased-p)) nil ); added 9/23/00 (std-%get-drives-string (mapcar (function (lambda (a) (strcat (chr a) ":") ) ) (std-string->list (std-%get-drives-string) ) ) ); for the slow method below we cache; it. added 9/23/00 (*std-get-drive-list*) (t (setq *std-get-drive-list*; todo: check all root dirs (std-remove nil (mapcar(function (lambda (a / s) (setq s (strcat (chr (+ a 65)) ":")); to be tested on dos (if(std-probe-file (strcat s "\\NUL")) s nil ) ))(std-int-list 26) ) ) ) ) ));;; load the required external fas library (>=r13)(defun std-%load-fileext-fas () (or (progn (if (not (std-acad-connection-p))(std-%simple-require "STANDALONE") ) (if (or (not (std-acad-connection-p)) (< 12 (std-ver-num) 14.8) )(progn (std-%unprotect-assign '(std-rmdir std-mkdir std-file-directory-p) ) (std-require-version "FILEEXT.FAS" 0.1)) ) (if (and (numberp *fileext-version*) (>= *fileext-version* 0.2) ); recalc it to enable; std-%acad-connection-p(progn (setq *acad-connected* nil) (defun std-rmdir (s) (std-%rmdir s) ) (defun std-mkdir (s) (std-%mkdir s) ) (defun std-file-directory-p (path) (std-%file-directory-p path) ); (if (not; std-file-systime); (defun std-file-systime (path); (std-%file-systime path)));; broken (std-%protect-assign '(std-rmdir std-mkdir std-file-directory-p) ) 1) ) *fileext-version* ) (std-warn (std-msg "Module FILEEXT.FAS not found")) ));;; returns list of output lines.;;; (strcat "ren " (std-%stringquote-filename from);;; " " (std-%stringquote-filename to))))(defun std-%command-shell-wait (cmd outfile / n dir endt); to be fixed for; fcad (if (null outfile) (command "_SH" cmd) (progn (command "_SH" (strcat cmd " > " outfile)) ; by serge pashkov:; we should wait until the shell; closes the temp file. (30 ms) (setq dir nil endt (+ (getvar "DATE") (/ *std:shell-timeout* 8640000.0)) ) (while (and (null dir) (< (getvar "DATE") endt) )(if (std-file-readable-p outfile) (setq dir (std-read-file-strings outfile))) ) dir ) ))(defun std-%shell-file-copy (from to) (cond ((and (std-doslib-p) (std-functionp 'dos_copy) ) (dos_copy from to) t ) ((not (std-probe-file from)) nil ) ((std-sys-dosbased-p) (std-%command-shell-wait (strcat "COPY " (std-%stringquote-filename from) " " (std-%stringquote-filename to) ) nil ) t ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait (strcat "cp '" (std-%stringquote-filename from) "' '" (std-%stringquote-filename to) "'" ) nil ) t ) (t (command "_FILES" 5 from to 0) t ) ));;; file function mappings;;; maybe todo:;;; check for the (loaded?) bonus/express tools which also have some;;; file funcs. the express tools are probably not needed, because vl;;; has the needed basics anyway, and doslib14 shipped with the r14;;; bonus tools as well.(cond ((std-vill-p); vital lisp extensions (defun std-file-rename (from to) (vlx-file-rename from to) ) (defun std-file-copy(from to) (cond ((vlx-file-copy from to)) ((std-%shell-file-copy from to)) ) ); note reverse order (defun std-file-append (to from) (vlx-file-copy from to t) ) (defun std-file-delete (fn) (vlx-file-delete fn) ) (defun std-%filename-mktemp (fn) (std-%slash-unify (vlx-filename-mktemp fn)) ) (defun std-%directory-files (dir fn flag) (vlx-directory-files dir fn flag) ) (defun std-file-size(fname) (vlx-file-size fname) ); (defun std-file-systime (fname); (std-datlst->cdate; (std-select (vlx-file-systime; fname); '(0 1 3 4 5 6 7)))) ) ((std-vlisp-p); visual lisp extensions (defun std-file-rename (from to) (vl-file-rename from to) ); fixed (defun std-file-copy(from to) (cond; vl- fails with space or dots in; filename!; "l:\\src\\stdlib\\test\\vlisp rts; v.5.0a0-19b, 14.0.ret"; but delete, copy-append, rename; works okay ((vl-file-copy from to)) ((std-%shell-file-copy from to)) ) ); note reverse order (defun std-file-append (to from) (vl-file-copy from to t) ) (defun std-file-delete (fn) (vl-file-delete fn) ) (defun std-%filename-mktemp (fn) (std-%slash-unify (vl-filename-mktemp fn)) ); 2-mar-00; (if (not (std-module-defined-p; "stdlib-ads")) (defun std-%directory-files (dir fn flag) (vl-directory-files dir fn flag) ); ) (defun std-file-size(fname) (vl-file-size fname) ) (defun std-file-systime (fname / date) (if (setq date (vl-file-systime fname)) (std-datlst->cdate (std-select date '(0 1 3 4 5 6 7))) ) ) ) ((std-doslib-p); std-get-drive-list switches; dynamically (defun std-file-rename (from to) (dos_rename from to) ) (defun std-file-copy(from to) (dos_copy from to) ); std-file-append missing! (defun std-file-delete (fn) (dos_delete fn) ) (defun std-%directory-files (dir fn flag) (if (= -1 flag) (dos_subdir dir) (dos_dir (std-make-pathname (list dir fn))) ) ) (defun std-file-size(fname) (cdr (assoc fname (dos_filesize fname))) ) (defun std-truename (fname) (dos_fullpath fname) ) (defun std-file-attrib (fname) (cdr (assoc fname (dos_attrib fname))) ) (defun std-mkdir (fname) (dos_mkdir fname) ) (defun std-rmdir (fname) (dos_rmdir fname) ) (defun std-current-drive () (dos_drive) ) (defun std-current-path () (dos_pwdir) ) (defun std-file-systime (fname / l d m) (if (setq l (dos_file fname)) (progn (setq d (third l) m (fourth l) ); (fname "35530" "03-28-1997"; "09:04:58p" "" "" "" "a") (std-datlst->cdate (list (atoi (substr d 7 4)) (atoi (substr d 4 2) ) (atoi (substr d 1 2 ) ) (if (="p"(substr m 9 1) ) (+ 12 (atoi(substr m 1 2) ) ) ) (atoi (substr m 4 2)) (atoi (substr m 7 2) ) ) ) ) ) ) ) (t; acomp or plain autolisp: use; workarounds instead; either shell calls or fileext; extensions; for the following funcs:; only very dirty workarounds so; far. files is discontinued on r14.; works only on dosbased systems.; mac and unix use different; commands.; even with quoting long fnames; don't work with r13; doslib not loaded yet. (defun std-file-rename (from to) (if (and (std-probe-file from) (not (std-probe-file to)) ) (progn (cond ((std-sys-dosbased-p) (std-%command-shell-wait (strcat "REN " (std-%stringquote-filename from) " " (std-%stringquote-filename to) ) nil ) ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait (strcat "mv '" (std-%stringquote-filename from) "' '" (std-%stringquote-filename to) "'" ) nil ) ) (t (command "_FILES" 4 from to 0) ) ) (if (and (std-probe-file to) (not (std-probe-file from)) ) t ) ) ) ) (defun std-file-copy(from to) (std-%shell-file-copy from to) ); note reverse order (defun std-file-append (dest source) (if (and (std-probe-file dest) (std-probe-file source) ) (progn (cond ((std-sys-dosbased-p) (std-%command-shell-wait (strcat "COPY " (std-%stringquote-filename dest) "+" (std-%stringquote-filename source) " " (std-%stringquote-filename dest) ) nil ) ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait (strcat "cat '" (std-%stringquote-filename dest) "' '" (std-%stringquote-filename source) "' > '" (std-%stringquote-filename dest) "'" ) nil ) ); applemac (t (std-error (strcat "STD-FILE-APPEND " (std-msg "not defined for this system") ) ) ) ) (if (std-probe-file dest) t ) ) ) ) (if (not std-file-delete); problem on win: shell window is; slow (defun std-file-delete (fname) (if (std-probe-file fname) (progn (cond ((std-sys-dosbased-p) (std-%command-shell-wait(strcat"DEL "(std-%stringquote-filename fname))nil ) ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait(strcat"rm '"(std-%stringquote-filename fname)"'")nil ) ) (t (command "_FILES" 3 fname "" 0) ) ) (if (std-probe-file fname) nil t ) ) ) ) ) (defun std-mkdir (fname) (if (not (std-probe-file fname)) (progn (cond ((std-sys-dosbased-p) (std-%command-shell-wait (strcat "MKDIR \"" (std-str-1(std-fpslash fname) ) "\"" ) nil ) ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait (strcat "mkdir '" (std-str-1(std-fpslash fname) ) "'" ) nil ) ); applemac (t (std-error (strcat "STD-MKDIR " (std-msg "not defined for this system") ) ) ) ) (if (std-probe-file fname) t ) ) ) ) (defun std-rmdir (fname) (if (std-file-directory-p fname) (progn (cond ((std-sys-dosbased-p) (std-%command-shell-wait (strcat "RMDIR \"" (std-str-1(std-fpslash fname) ) "\"" ) nil ) ) ((std-sys-unix-p); quote fnames from shell expansion (std-%command-shell-wait (strcat "rmdir '" (std-str-1(std-fpslash fname) ) "'" ) nil ) ); applemac (t (std-error (strcat "STD-RMDIR " (std-msg "not defined for this system") ) ) ) ) (if (std-file-directory-p fname) nil t ) ) ) ) (defun std-file-size(fname) (std-warn (strcat "STD-FILE-SIZE " (std-msg "not yet implemented for plain ALISP") ) ) 0 ); => flag; 1: read-only; 2: hidden; 4: system; 8: archive; 2048: compressed (defun std-file-attrib (fname) (std-warn (strcat "STD-FILE-ATTRIB " (std-msg "not yet implemented for plain ALISP") ) ) 0 ); adsrx version v0.4019 is fixed and; matches this behaviour.; flag:; -1 - directories only; 0 - files and directories; (default); 1 - files only; improved for case 1, but it still; is a hack.; todo: check rbarlow's reported bug; [12/14/99] (defun std-%directory-files (dirfnflag/cmdtemplst*slash-char*nopts ) (if (not fn) (setq fn "*") ) (cond ((std-sys-dosbased-p)(setq *slash-char* "\\")(setq cmd; we should check which dos version; supports these flags (cond ((= -1 flag) "DIR /B/A
" ) ((= 1 flag) "DIR /B/A:-D" ) (t "DIR /B" ) ) opts "") ) ((std-sys-unix-p); note that under unix the returned; filenames include the; path prefix! "test" =>; ("test/file1" "test/file2" ...); under dos or win32 not(setq *slash-char* "/")(cond ((= -1 flag) (setq cmd "find" opts "-maxdepth 1 -type d" ) ) ((= 1 flag) (setq cmd "find" opts "-maxdepth 1 -type f" ) ) (t (setq cmd "ls" opts "" ) )) ) (t(std-error (strcat "(STD-%DIRECTORY-FILES dir fn flag) " (std-msg "unsupported operating system") )) ) ) (setq temp (std-filename-mktemp "dir.lst")) (if (= -1 flag) (std-%command-shell-wait (strcat cmd " " (std-%stringquote-filename dir) opts ) temp ) (std-%command-shell-wait (strcat cmd " " (std-%stringquote-filename (std-make-pathname (list dir fn) ) ) opts ) temp ) ) ); load fileext: probably from a; fileext.lsp (not yet provided); file extensions searched by; std-load-external (lsp, arx, ...); not yet!; (or (std-require-version; "fileext" 0.1); (std-warn "module fileext; not found!")) ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdfile-symbols*))(setq *stdfile-symbols* nil);;; module dependencies:(std-%simple-provide "STDFILE");;; first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.(std-%simple-require "STDSTR");;; various(std-%simple-require "STDLISP");;; various;;; (std-%simple-require "stderror") ; std-file-delete: std-var-push;;; deferred to stdinit2 after fix-module-path to be able to find the arx;;; later we will need a strategy for r15 to go without it.;;; (or (std-%require-external-ads "fileext");;; (and (not (std-ver-r2000-p));;; (std-%accept-fas2-extensions-p);;; (std-%load-fileext-fas)));;; stdinit2 is no seperate module, just an extension for stdfile.;;; don't load it again, because it has top-level calls(if (not *std:%project*) (if (not (std-functionp std-%fix-module-path)) (std-%simple-load "STDINIT2") ));;; 'stdfile;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdinit2.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:31 rurban>;;; copyright (c) 1998,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; load required external libraries and do some toplevel calls;;;;;; this is no module. it is loaded by stdfile or by the project.;;; it is called after having all required functions;;; to safely load the required external modules (fileext) and;;; define workarounds if not found.;;; here toplevel calls (evaluated at load-time) are allowed.;;; with projects call (stdlib-project-init) to do this.;;; status:;;; this is dynamical code so there may be different errors if loaded as;;; one project (stdall.lsp, stdlib.fas, stdlib.bi4) or by std-require.;;; tested with r13/r14 plain, with vill 2,3 and vlisp and vill 2;;; standalone. not yet with earlier versions.;;; and it is very likely subject to change.;;;;;; $log: stdinit2.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-09-07 16:05:18 rurban;;; finds *stdlib-path* via getcfg setting;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-27 15:10:19 rurban;;; added *std:user-color-names* init;;; 2000-04-19 10:13:58 rurban;;; stdinit2, fixed init: std-%top-level-init called only once;;;;;; ===================================================================73;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdinit2-symbols* ' (stdlib-force-delayed stdlib-project-init) ) ));;; check *module-path* for correct path-names and fix it.;;; set global *stdlib-path* to avoid problems with adding paths later.;;; requires stdlib.lsp to be present in the correct path even if it's;;; not loaded! if you want to aviod to carry a dummy stdlib.lsp with,;;; you, set *stdlib-path* in your initialisation.;;; called in stdinit2;;; for using the stdlib inside other projects set std:%project to t,;;; then all std-require calls are delayed and *module-path* and;;; *stdlib-path* are not checked.;;;;;; stress this for tests:;;; (setq *module-path* '(1 2 3 "l:/src/stdlib" "l:/src" "l:/src/"))(defun std-%fix-module-path (/ s) (if (and(not *module-path*)(std-ver-r13-p); at least r13(setq s (getcfg "AppData/STDLIB/MODULE-PATH")) ) (setq *module-path* (read s)) ) (cond ((consp *module-path*)); on a seperate project the paths; must be provided seperately,; e.g. after having fully; initialized the project (*std:%project* nil) ((setq s (cond ((findfile "STDLIB.VLX")) ((findfile "STDLIB.FAS")) ((findfile "STDLIB.BI4")) ((findfile "STDLIB.LSP")) ) ) (setq *module-path* (list (std-filename-directory s))) ) (t (princ (strcat (std-msg "* Warning: *MODULE-PATH* not set!") (std-msg "\n** STDLIB will not find its modules") ) ) ) ); temp fcad fix for std-glob-files (if (and(std-ver-fcad-p)(not *stdlib-path*) ) (setq *stdlib-path* (std-fpslash (std-filename-upcase (car *module-path*)) ) ) ) (setq*module-path* (std-remove nil (mapcar (function (lambda (s) (if (and (stringp s) (std-file-directory-p s) ) (progn (setq s (std-fpslash (std-filename-upcase s) ) ) (if (and (not *stdlib-path*) (std-glob-files (std-force-path s "STDLIB.*") ) ) (setq *stdlib-path* s ) ) s ) ) ) ) *module-path* ) ) ); on projects this path needs not to; be checked (if (or*std:%project**stdlib-path*(setq *stdlib-path* (getcfg "AppData/STDLIB/STDLIB-PATH")) ); 9/7/00 nil (std-cerror "no valid STDLIB path found!") ); re-order it so that *stdlib-path*; is the first, fixed (if *stdlib-path* (setq *module-path* (cons (std-fpslash *stdlib-path*) *module-path*) ) ); no duplicates for faster loading (setq *module-path* (std-remove-duplicates *module-path*)); store the; cfg for other apps and lazy; developers/users (if (std-ver-r13-p); at least r13 (progn (if (/= (setq s (std-prin1-to-string *module-path*)) (getcfg "AppData/STDLIB/MODULE-PATH") )(setcfg "AppData/STDLIB/MODULE-PATH" s) ) (if (and *stdlib-path* (/= (getcfg "AppData/STDLIB/STDLIB-PATH") *stdlib-path*) )(setcfg "AppData/STDLIB/STDLIB-PATH" *stdlib-path*) ) ) ));;; ===================================================================73;;; top-level stuff;;; use lambda to shadow temp. variables. (as let in cl);;; put everything in here that is dynamically needed by;;; stdinit, stdstr, stdlist, stdlisp and stdfile;;; all other modules are allowed to call their own functions, because;;; after this call everything should be up and running.;;; (well, the error handling not)(defun std-%top-level-1(/ lang lang-err) ; redefine slash-char (if (std-acad-connection-p) (setq *slash-char* (cond ((std-sys-dosbased-p) "\\" ) ((std-sys-mac-p) ":" ) (t "/" ) ); fixed; fcad doesn't have this *codepage* (getvar "SYSCODEPAGE") ); no acad: define some useful; defaults, just for testing (setq *sys-mswin* 1 *sys-dosbased* 1 *sys-dos* 0 *sys-language* ':german *sys-locked* 0 *sys-longfnames* 1 *sys-mac* 0 *sys-os2* 0 *sys-r12* 0 *sys-r13* 0 *sys-r14* 1 *sys-fcad* 0 *sys-icad* 0 *sys-tcad* 0 *acadver* "14.0" *acadver-num* 14.0 *acadplatform* "Microsoft Windows"; strcase std-strcase *codepage* "iso8859-1" *std:acad-library-paths* *module-path* *local-language* ':german ) ); provide some expert knowledge; about the maximal recursion stack; missing:; intellicad, r12/win (240; assumed),; <10.10 (138 assumed, but special; lispstack env variable); acomp r10 (1240 assumed, but; special compstack env variable); => error: stack-overflow; (simulated in vlide), but *error*; is; not called in vl! (std-defconstant '*max-recursion-stack* (cond ((and (std-vl-p) (std-vlide-p) ) 984 ); vl ide: simulated,977? ((std-vl-p) *max-shortint* ); vl rts: unlimited ((std-acomp-p) 1240 ); acomp (see above) ((std-ver-fcad-p) 1984 ); then fcad.exe dies! ((= (_ver) "i7.00r") 251 ); r13 ((= (_ver) "i8.00r") 239 ); r14 ((and (std-ver-win-p) (< (std-ver-num) 15) ) 240 ); r12/13/14 win ((< (std-ver-num) 13) 138 ); r12/dos (t 200 ); ?? (unreachable code) ) ); maximal number of arguments to; functions like and; autolisp: => (*error* "too many; arguments"); vl: no *error* is called, hard; error; with fcad the whole app dies. (std-defconstant '*max-args-limit* (cond ((std-ver-r2000-p) 1623 ); have to recheck this in fcs ((std-vl-p) 32767 ) ((std-acomp-p) 32 ); acomp ((std-ver-fcad-p) 2000 ); even more, but with 3000 it; needed; a few minutes and 100 mb heap. ((std-ver-win-p) 1000 ); r12/13/14 win (t 65534 ) ) ); protect a limited number of; not-prefixed functions (vl only); don't add anything here! (std-%protect-assign '(first secondthird fourth fifth sixth seventh eighth ninthtenth rest consp stringp x-of y-of z-ofxy-of ) ); the vl-rts should be loaded by the; developer, not by the library.; so i removed the call.; (if (and (not (std-vl-p)) (std-acad-; connection-p)); (std-%load-vl-rts); ) (if (= (atoi (std-acadver)) 14) (std-defconstant '*r14-lwpoly-bug* t) ); localization stuff (std-defkeyword ':english) (if (not (std-sys-mac-p)) (setq *std:slash-chars* (std-remove ":" *std:slash-chars*)) ); fix the paths supplied so far. (std-%fix-module-path); supply a special var for the; stdlib path; load an external supporting app if; it can be found; this migth cause problems on r15; when trying to; (load "stdlib15") recursively (or (std-%require-external-ads "FILEEXT") (and (not (std-ver-r2000-p)) (std-%accept-fas2-extensions-p) (std-%load-fileext-fas) ) ) (if (eq ':english (std-ver-language)) (progn (std-%simple-require "STDMISC"); with significant upcased chars.; this might get redefined in; stdlocal,; used in color prompts and; keywords. (std-defconstant'*std:user-color-names*(mapcar (function (lambda (s) (std-%extract-significant-key s nil) ) ) (mapcar (function car) *std:color-table* )) ) ); loaded as single module, so we; require the rest (progn (std-%simple-require "STDLOCAL") (std-%simple-require "STDERROR"); (std-%set-language-error) ) ) (if (and(std-module-defined-p "FILEEXT")(<= 0.51 *fileext-version* 0.74) ) (progn (std-%unprotect-assign '(std-randomize)) ; fixed by rg; std-%randomize takes an optional; random-state argument (setq std-randomize std-%sys-randomize) (std-%protect-assign '(std-randomize)) ; fixed by rg ) ))(defun stdlib-force-delayed (/ *std:%project*) (foreach x *std:modules-delayed* (std-require x) ))(defun stdlib-project-init () (if *std:%project*; otherwise it was already; initialized below (std-%top-level-1) ) (if (std-functionp std-%locale-init) (std-%locale-init) ) (stdlib-force-delayed); wait until stdlocal is loaded and; after all delayed modules (std-%load-verbose-print (ifstd-cdate->date-string (list "STDLIB v" (stdlib-version) (if (stdlib-beta-p) "beta" "" ) ", " (std-cdate->date-string (std-datlst->cdate *stdlib-date*) ) "\n" ) (list "STDLIB v" (stdlib-version) "\n") ) ) (setq *std:%project* nil); (setq *std:modules-delayed* nil) (setq*verbose* *std:%old-verbose**load-verbose* *std:%old-load-verbose**std:%old-load-verbose* nil*std:%old-verbose* nil ))(if (not *std:%project*) (std-%top-level-1));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdinit2-symbols*))(setq *stdinit2-symbols* nil)(std-%simple-provide "STDINIT2");;; modulenames of further external extensions:;;; (not required to continue);;; binio : (std-%simple-require "binio");;; registry : (std-%simple-require "registry");;; inifile : (std-%simple-require "inifile");;; 'stdinit2 ; this fails in fcad;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdmath.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:17 rurban>;;; copyright (c) 1998,99 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; mathematical functions for the stdlib;;; - logic;;; - base conversion;;; - math (type preserving arithmetic, random, statistics);;; - trigonometry;;;;;; note:;;; there is no linear algebra code included yet! on purpose.;;; matrix code should be avoided at all to minimize problems with;;; numeric overflow on repeated multiplications and even worse;;; floating underflow on add operations.;;; instead native autocad methods like (trans) with command ucs;;; should be used.;;; status: stable;;; renamed std-faculty to std-factorial in v0.4002.;;; most if it is tested.;;; most arithmetic and trigonometric funcs are excluded from small.;;; not tested yet: hyperbolic and area functions.;;; this module previously had a lot of implementation changes,;;; (type preservation, integer overflows, performance) but should;;; be fairly stable now.;;; no overflow checks are yet implemented for std-lcm.;;; prime functions are now in primes.lsp;;; dynamic random functions are now in random.lsp;;; combinatorial functions are in combinations.lsp;;; missing:;;; optimized algorithms for std-isqrt;;;;;; $log: stdmath.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-11 12:47:18 rurban;;; added std-%(un)protect-assign wrapper for dynamic random funcs;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-14 13:48:00 rurban;;; std-tan improved accuracy, correct return of *infinity* and 0.0;;;;;; revision 0.4009 2000/04/07 17:29:20 rurban;;; v0.4009, see changes;;;;;; 2000-03-21 18:20:40 rurban;;; fixed std-logcount for a2000;;; 2000-04-07 16:27:03 rurban;;; fixed std-logcount for a2000 without activex rts;;;;;; internal functions start with std-%;;; ===================================================================73(std-%simple-require "STDLISP");;; for std-error, std-defconstant;;; we either define std-random as not-linked, which is slower.;;; but better we define it statically, ignore std-make-random-state;;; and provide a dynamic version with the random module.(pragma '((not-link std-random)));;; redefined dynamically?(if std-%unprotect-assign (std-%unprotect-assign (setq *stdmath-symbols* '(*pi2* *pi/2* *pi/4* std-dtr std-rtd std-float-precision std-logxor std-lognot std-setbit std-bitdel std-bitlist std-logcount std-bittoggle std-num->hex std-hex->num std-num->oct std-oct->num std-num->bin std-bin->num std-num-scale std-evenp std-round std-fraction std-floor std-ceiling std-signum std-sign std-sqr std-sqrt std-expt std-log2 std-log10 std-isqrt std-gcd std-lcm std-random std-mean std-median std-standard-deviation std-tan std-sec std-csc std-asin std-acos std-asec std-acsc std-acot std-sinh std-cosh std-tanh std-coth std-sech std-csch std-arsinh std-arcosh std-artanh std-arcoth ) ) ));;; avoid reload warnings in vl;;; (eval (list 'pragma;;; (list 'quote;;; (list (cons 'unprotect-assign;;; '(*pi2* *pi/2* *pi/4*;;; std-dtr std-rtd;;; *num-tol*;;; );;; )))));;; globals:;;; numeric tolerance, used in comparisons with std-equalp.;;; acceptable rounding errors(setq *num-tol* 1e-6);;; constants:(std-defconstant '*max-longint* 2147483647);;; signed longint, 32-bit(std-defconstant '*max-shortint* 32767);;; signed shortint,16-bit;;; max double, 64-bit, ~15 precise digits;;; something like 1.7976931348623157e+308l normally(std-defconstant '*max-real* 1.7e308);;; the minimum double is something like 2.2250738585072014e-308(std-defconstant '*min-real* 2.2250738585072014e-308);;; min double;;; some numerical constants for cl compatibility only.;;; those floats are always normalized. we don't wanna wake the demon.(std-defconstant 'most-positive-fixnum 2147483647)(std-defconstant 'most-negative-fixnum -2147483648);;; another autolisp - vl incompatibility:;;; vl accepts 1.797693134862316e+308 and -1.797693134862315e+308 as;;; largest numbers.(std-defconstant 'most-positive-double-float 1.797693134862315e+308)(std-defconstant 'most-negative-double-float -1.797693134862315e+308);;; lowest precision, kind of zero(std-defconstant 'least-positive-double-float 2.2250738585072014e-308)(std-defconstant 'least-negative-double-float -2.2250738585072014e-308);;; common lisp float-precision function.;;; the value returned here is implementation dependent.;;; since only 64-bit, double precision, is supported;;; we return 53 here, unless the number is 0.0, then 0 is returned.;;; radix 2, 10^15 < 2^53 < 10^16 (15 decimal digits exactness)(defun std-float-precision (r) (if (zerop r) 0 53 ));;; inifinity is not iso conformant, not nan for simplicity.(std-defconstant '*infinity* *max-real*);;; positive infinity;;; epsilon, lowest precision with doubles. usually between;;; 1e-15 and 1e-16. we use 1e-12 for more numerical stability.;;; see *machine-epsilon*(std-defconstant '*epsilon* 1e-12);;; "machine dependent epsilon", lowest possible number;;; something like 2.2204460492503131e-16 with long doubles (64-bit ieee);;; but calculated dynamically, by serge pashkov, see *epsilon*(std-defconstant '*machine-epsilon* (apply (function (lambda (/ eps)(setq eps 1.0)(while (/= (+ 1.0 eps) 1.0) (setq eps (/ eps 2.0)))(* 2.0 eps) ) ) nil ));;; "machine dependent maximal integer";;; panic mode, i know no autolisp version using only 16-bit integers;;; but i'm not absolutely sure.;;; so far only a simple version: detects only 16-bit or 32-bit;;; signed integers. we'll need this for detecting integer overflows(std-defconstant '*max-int* (if (minusp (1+ *max-shortint*)) *max-shortint* *max-longint* ));;; -------------------------------------------------------------------73;;; logic(defun std-logxor (i j) (boole 6 i j))(defun std-lognot (i) (~ i));;; moved to stdinit;;; t if all bitvalues in flag are set or nil;;; (defun std-bitsetp (val flag);;; (= (logand val flag) val)); fixed;;; returns the new flag with the bitvalue val enabled.(defun std-setbit (val flag); (std-setbit 128 1) => 129 (logior val flag));;; returns the new flag with the bitvalue val disabled.;;; (std-bitdel 64 (std-getflag ele)) ; without 64(defun std-bitdel (val flag) (logand flag (std-lognot val)));;; returns a list of all set bitvalues in flag.(defun std-bitlist (n / i lst); list of bitvalues (setq i 1) (while (>= n i) (if(= i (logand i n)) (setq lst (cons i lst)) ) (setq i (lsh i 1)) ) lst);;; counting bits in 32-bit fixnums:;;; (an interesting topic);;; number of bits==1,;;; slow log(n) version, there should exist a constant function;;; 1:1, 2:1, 3:2, 4:1, 5:2, 6:2, 7:3, 8:1, 9:2, 10:2, 11:3;;; (defun std-logcount (n / i r);;; (setq i 1 r 0);;; (while (>= n i);;; (if (= i (logand i n)) (setq r (1+ r)));;; (setq i (lsh i 1));;; );;; r;;; );;; counting bits in 32-bit fixnums: from the scheme slib;;; serge pashkov fixed it for negtaive numbers:;;; (std-logcount -1) => 0(defun std-logcount (n) (cond ((zerop n) 0 ) ((minusp n) (- 32 (std-logcount (~ n))) ); fixed (t (+(std-logcount (lsh n -4))(nth (rem n 16) '(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)) ) ) ));;; toggles all bits of val in flag(defun std-bittoggle (val flag / i new) (setq new val) (foreach i (std-bitlist flag) (if(zerop (logand i val)); bit not set (setq new (+ new i)); add (setq new (- new i)); remove ) ) new);;; -------------------------------------------------------------------73;;; base conversion(defun std-num->hex (i / s a) (setq s "") (while (> i 0) (setq a (rem i 16) i (lsh i -4) ) (setq s (strcat (if(< a 10) (chr (+ 48 a)); 48: (ascii "0") (chr (+ 55 a)) ) s ) ) ));;; 55: (ascii "a") - 10;;; "1c" -> 28;;; strcase needs ads(defun std-hex->num (s / i n a) (std-%simple-require "STDSTR") (setqi 0n 0s (std-strcase s) ); to be ads independant (if (= (substr s 1 2) "0X") (setq s (substr s 3)) ) (while (< i (strlen s)) (setq a (substr s (setq i (1+ i)) 1 ) ) (if(not (<= "0" a "F")) (chr a) ); force bad argument type error (setq n (+ (lsh n 4) (- (ascii a) (if (<= a "9") 48 55 ) ) ) ) ))(defun std-num->oct (i / s a) (setq s "") (while (> i 0) (setq a (rem i 8) i (lsh i -3) ) (setq s (strcat (chr (+ 48 a)) s)) ));;; 48 = (ascii "0")(defun std-oct->num (s / i n a) (setqi 0n 0 ) (while (< i (strlen s)) (setq a (substr s (setq i (1+ i)) 1 ) ) (setq n (+ (lsh n 3) (- (ascii a) 48))) ))(defun std-num->bin (i / lst) (while (> i 0) (setq lst (cons (rem i 2) lst) i (lsh i -1) ) ) lst)(defun std-bin->num (numlst / i n) (setq n 0) (foreach i numlst (setq n (cond ((= i 0) (lsh n 1) ) ((= i 1) (1+ (lsh n 1)) ) (t (chr (chr (+ 48 i))) ) ) ) ));;; throw an meaningful;;; bad argument type error;;; scale the number from the source interval to the target interval;;; to fit in the range to;;; interval: nil: (0 1.0) or;;; num: (0 num) or;;; list: (start end);;; (std-num-scale 1.0 1.0 32767) => 32767(defun std-num-scale (num from to / from1 from2 to1 to2) (setqfrom (std-%force-interval from)to (std-%force-interval to) ) (+ (car to) (*num(/ (- (cadr to) (car to)) (- (cadr from) (car from))) ) ))(defun std-%force-interval (i) (cond ((numberp i) (list 0.0 i) ) ((null i) (list 0.0 1.0) ) ((and (listp i) (= 2 (length i)) (apply (function and) (mapcar (function numberp) i ) ) ) i ) (t (std-error (list (std-msg "bad argument type") " - " i)) ) ));;; -------------------------------------------------------------------73;;; math(defun std-evenp (i) (zerop (rem i 2)));;; round to the nearest integer: 0.5=>1, 0.49=>0(defun std-round (num) (if (>= (abs (std-fraction num)) 0.5) (if(minusp num) (1- (fix num)) (1+ (fix num)) ) (fix num) ));;; return the fractional part of a real only;;; (std-fraction 1.1) => 0.1;;; (std-fraction -1.1) => -0.1(defun std-fraction (num) (- num (fix num)));;; return the lower integer;;; (std-floor 1.1) => 1;;; (std-floor -1.1) => -2(defun std-floor (num) (if (minusp num) (1- (fix num)) (fix num) ));;; return the upper integer;;; (std-ceiling 1.1) => 2;;; (std-ceiling -1.1) => -1(defun std-ceiling (num) (if (minusp num) (fix num) (1+ (fix num)) ));;; returns -1, 0 or 1 if the argument is negative zero or positive(defun std-signum (num) (cond ((minusp num) -1 ) ((zerop num) 0 ) (t 1 ) ));;; fortran-like sign: "assign sign of num2 to num1";;; returns the absolute value of num1 with sign of num2.;;; type of result coincides with type of num1.;;; (sign 1 -2) => -1, (sign 1 2) => 1,;;; (sign 1.0 0) => 0.0, (sign 3 -2.5) => -3(defun std-sign(num1 num2) (cond ((minusp num2) (- (abs num1)) ) ((zerop num2) (if (= (type num1) 'int) 0 0.0 ) ) (t (abs num1) ) ));;; square of number, n*n, n^2;;; obeye integer overflows.(defun std-sqr (n) (if (> n 46340); = (sqrt *max-longint*) (* (float n) n) (* n n) ));;; type preserving square root(defun std-sqrt(n / r i) (if (and(std-integerp n)(= (std-sqr (setq i (fix (setq r (sqrt n))))) n) ) i; int (or real if too large) (cond (r) ((sqrt n)) ); always real, avoid double; calculation ));;; b^e, b raised by e, autolisp expt bugfix, (also often named power);;; we preserve types: (std-expt 2 4) => 16, not 16.0;;; and fix integer overflow problems.;;; real is only returned when x=real or n=real, n<0, x<0;;; or the integer is too large. by serge pashkov and reini urban(defun std-expt(b e / r) (cond ((minusp e) (/ 1.0 (std-expt b (- e))) ) ((= e 1) b ) ((std-realp e) (expt b e) ) ((std-integerp b) (setq r (expt (float b) e)) (if (= r (fix r)) (fix r) r ) ) (t (expt b e) ) ));;; log base 2;;; lg x = ln x/ln 2(defun std-log2(i / x ln2) (setq ln2 1.4426950408889634) (if (and(std-integerp i)(= i (lsh 1 (setq x (std-round (* (log i) ln2))))) ) x; (/ (log i) (log 2)) = (* (log i) (/; 1.0 (log 2))) (* (log i) ln2) ));;; log base 10;;; lg x = ln x/ln 10(defun std-log10 (i / x ln10) (setq ln10 0.4342944819032518) (if (and(std-integerp i)(= i (std-expt 10; fixed (setq x (std-round (* (log i) ln10))) )) ) x; (/ (log i) (log 10)) (* (log i) ln10) ));;; "integer square root";;; to-be-improved implementation, if newton-raphson is faster(defun std-isqrt (n) (fix (sqrt n)));;; "greatest common divisor", already defined in autolisp for two args;;; using euklid's algorithm, the most popular of all numeric algorithms;;; (std-gcd '(10 20 30)) => 10;;; not really needed because autolisp has a native (gcd num1 num2);;; to-be-improved implementation.(defun std-gcd (lst) (setq lst (std-fast-sort lst '<)); ascending integer list (while (cadr lst) (setq lst (cons (gcd (car lst) (cadr lst)) (cddr lst))) ) (car lst));;; recursive gcd: i1 < i2 !!;;; same as the native gcd;;; least common multiple;;; no checks for overflows yet!;;; (2 4) => 4(defun std-lcm (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (/ (abs (apply (function *) lst ) ) (std-gcd lst) ) ));;; -------------------------------------------------------------------73;;; std-faculty eh std-factorial;;; moved to module combinations;;; and renamed to factorial;;; -------------------------------------------------------------------73;;; primes;;; moved to module primes;;; -------------------------------------------------------------------73;;; random numbers;;; status:;;; internal system provided std-%sys-random funcs defined in;;; fileext.fas;;; here is only defined the basic std-random, the other functions with;;; dynamic redefinition of random methods, and support for states is in;;; the seperate module random.;;; (std-random) returns a pseudo random number between 0 (inclusive);;; and num (exclusive). e.g. (std-random 1) always returns 0, never 1.;;; default arg: nil = 1.0;;; type preserving. return types are dependent of the argument type:;;; nil: 0.0 <= (std-random nil) < 1.0;;; real: 0.0 <= (std-random num) < num;;; int: 0 <= (std-random num) < num;;; if we want a fast linked call at startup we should;;; do something different...(if (std-functionp 'std-%sys-rand) (progn (ifstd-%unprotect-assign (std-%unprotect-assign '(std-random)) ) (defun std-random (num) (std-%sys-rand(if (not num) 1.0 num) ) ) (ifstd-%protect-assign (std-%protect-assign '(std-random)) ) ) (progn (ifstd-%unprotect-assign (std-%unprotect-assign'(std-%mult-rand-1 std-%mult-rand std-random) ) ); by serge pashkov:; this is a multiplicative generator; named; urand (universial random; generator) with period length 2^31; and; small value of the explicit; correlations (though every; multiplicative generator suffers; from them in more and less; extent). max seed: *max-int*,; these numbers are fine for 32-bit; ints. (defun std-%mult-rand-1 (/ seed) (setq seed *random-seed*) (if (minusp (setq seed (+ 453816693 (* seed 843314861)))) ; hint:; divide 2^31 as 2^30+2^30(setq seed (+ seed 1073741824 1073741824)) ) (* 4.656612873077392e-10 (setq *random-seed* seed)) ); multiplicative rand (defun std-%mult-rand (n) (cond((std-integerp n) (abs (fix (* n (std-%mult-rand-1)))))((std-realp n) (* n (std-%mult-rand-1)))((null n) (std-%mult-rand-1))(t (std-error (std-msg "bad argument type"))) ) ); some generators require a special; seed range.; std-%get-internal-run-time will; return a number between 0 and; something like 86400000. (* 24 60; 60 1000); but we avoid integer overflows; before calculating random,; because we have no exceptions; before r15. (setq *random-seed* (fix(rem (if (std-acad-connection-p) ; truncate; the days and use only the; fractional; part of the seconds since today; 0:00,; convert it to milliseconds and; integer.; also avoid stdtime requirement, so; it's inlined. (fix (* 86400000 (- (getvar "DATE") (fix (getvar "DATE") ) ) ) ) (if (std-require-version "FILEEXT" 0.3) (std-%get-internal-run-time) ; fileex; t 0 ) ) *max-int*) ) ) (defun std-random (num) (std-%mult-rand(if (not num) 1.0 num) ) ) (ifstd-%protect-assign (std-%protect-assign'(std-%mult-rand-1 std-%mult-rand std-random) ) ) ));;; -------------------------------------------------------------------73;;; statistics;;; average of a list of numbers(defun std-mean(numlst) (if (> (length numlst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (/ (apply (function +) numlst ) (float (length numlst)) ) ));;; median of the sorted list of numbers. 50% is above and 50% below;;; "center of a distribution";;; ex: (std-median (std-make-list 100 std-%random)) => 0.5 +- epsilon;;; (std-median (std-make-list 100 (lambda () (std-random 10))));;; => 4.0-5.0 [0..9];;; (std-median (std-make-list 99 (lambda () (std-random 10))));;; => 4-5;;; (std-median '(0 0 2 4 12))=> 2;;; (std-median '(0 0 4 12))=> 2.0(defun std-median (numlst / l) (setq numlst (std-sort numlst '<)); don't remove duplicates (if (= 0 (rem (setq l (length numlst)) 2 ) ); if even length (* 0.5 (+ (nth (/ l 2) numlst); force float! (nth (1- (/ l 2)) numlst) ) ); fixed by serge pashkov (nth (/ l 2) numlst) ))(defun std-standard-deviation (numlst / n _dev_m r) (setqn (length numlst)_dev_m (std-mean numlst)r (mapcar (function (lambda (x) (std-sqr (- x _dev_m)) ) ) numlst ) ) (sqrt (* (std-mean r) (/ n (float (- n 1))))));;; -------------------------------------------------------------------73;;; trigonometry(std-defconstant '*pi2* (* 2.0 pi))(std-defconstant '*pi/2* (/ pi 2.0))(std-defconstant '*pi/4* (/ pi 4.0));;; degree to radian(defun std-dtr (deg); (* pi (/ deg 180.0)) (* deg 0.0174532925199433));;; radian to degrees(defun std-rtd (rad); (/ (* rad 180.0) pi) (* rad 57.29577951308233));;; note that none of these functions check for valid;;; arguments. passing valid arguments is the responsibility;;; of the calling program.;;; tangent accepts any angle in radians, and returns the;;; tangent in the range -9.7e307+epsilon to 9.7e307 inclusive;;; fixed v0.5 to improve numeric accuracy(defun std-tan (z / cosz) (cond ((zerop (rem z pi)) 0.0 ); added: 0, 180, 360, ... ((zerop (rem z *pi/2*)) *infinity* ); added: 90, 270, ... ((zerop (setq cosz (cos z))); cos *pi/2* is inaccurate *infinity* ) (t (/ (sin z) cosz) ) ));;; some more trigonometric functions by jon fleming, may 20 1997.;;; secant accepts any angle in radians, and returns the;;; secant in the ranges -9.7e307+epsilon to -1.0 inclusive;;; and 1.0 to 9.7e307 inclusive(defun std-sec (z / cosz) (if (zerop (setq cosz (cos z))) *infinity* (/ 1.0 cosz) ));;; cosecant accepts any angle in radians, and returns the;;; cosecant in the ranges -9.7e307+epsilon to -1.0 inclusive;;; and 1.0 to 9.7e307 inclusive(defun std-csc (z / sinz) (if (zerop (setq sinz (sin z))) *infinity* (/ 1.0 sinz) ));;; arcsine (inverse sine) accepts an argument in the range;;; -1.0 to 1.0 inclusive, and returns an angle in radians in;;; the range -pi/2 to pi/2 inclusive.(defun std-asin(z) (cond ((zerop z) 0.0 ) ((= z 1.0) *pi/2* ) ((= z -1.0) (- *pi/2*) ) (t (atan z (sqrt (- 1.0 (* z z)))) ) ));;; arccosine (inverse cosine) accepts an argument in the;;; range -1.0 to 1.0 inclusive, and returns an angle in;;; radians in the range pi to 0 inclusive(defun std-acos(z) (atan (sqrt (- 1.0 (* z z))) z));;; arcsecant (inverse secant) accepts an argument in;;; one of two ranges: minus infinity to -1 inclusive or;;; 1 to infinity inclusive, and returns an angle in;;; radians in the range pi to 0 inclusive (except;;; exactly pi/2 will never be returned on a computer;;; with finite numerical precision)(defun std-asec(z) (std-acos (/ 1.0 z)));;; arccosecant (inverse cosecant) accepts an argument;;; in one of two ranges: minus infinity to -1 inclusive or;;; 1 to infinity inclusive, and returns an angle in;;; radians in the range -pi/2 to pi/2 inclusive (except;;; exactly 0.0 will never be returned on a computer;;; with finite numerical precision)(defun std-acsc(z) (std-asin (/ 1.0 z)));;; arccotangent (inverse cotangent) accepts an argument;;; in the range minus infinity to plus infinity;;; inclusive and returns an angle in radians in the;;; range pi to 0 inclusive.(defun std-acot(z) (- *pi/2* (atan z)));;; -------------------------------------------------------------------73;;; hyperbolic and area functions;;; sinus hyperbolicus(defun std-sinh(z) (/ (- (exp z) (exp (- z))) 2));;; cosinus hyperbolicus(defun std-cosh(z) (/ (+ (exp z) (exp (- z))) 2));;; tangens hyperbolicus(defun std-tanh(z / x) (/ (-(setq x (exp (* 2.0 z)))1 ) (+ x 1) ));;; cotangens hyperbolicus(defun std-coth(z / x) (/ (+(setq x (exp (* 2.0 z)))1 ) (- x 1) ));;; secans hyperbolicus(defun std-sech(z) (/ 2.0 (+ (exp z) (exp (- z)))));;; cosecans hyperbolicus(defun std-csch(z) (/ 2.0 (- (exp z) (exp (- z)))));;; area sinus hyperbolicus(defun std-arsinh (z) (log (+ z (sqrt (+ 1.0 (* z z))))));;; area cosinus hyperbolicus, z: [1..inf), arcosh > 0(defun std-arcosh (z) (if (>= z 1.0) (log (+ z (sqrt (- (* z z) 1.0)))) *infinity* ));;; area tangent hyperbolicus(defun std-artanh (z) (if (<= (abs z) 1.0) (/ (log (/ (+ 1.0 z) (- 1.0 z))) 2.0) *infinity* ));;; area cotangent hyperbolicus(defun std-arcoth (z) (if (>= (abs z) 1.0) (/ (log (/ (+ z 1.0) (- z 1.0))) 2.0) *infinity* ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdmath-symbols*))(setq *stdmath-symbols* nil);;; module dependencies:(std-%simple-provide "STDMATH");;; requires defined above:;;; stdlisp (top level: std-defconstant);;; stdlist (std-gcd),;;; stdinit (top level, std-random);;; no other requirements;;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdpoint.lsp 0.5006 2000/12/31 10:59:00 rurban rel $-*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:43 rurban>;;; copyright (c) 1998,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; abstract geometric autocad independent code, for point and segment;;; structures (points, segments, arcs, bulges);;; status:;;; moved std-pline-segs back to stdent so there's no entity accessing;;; function remaining here.;;; v0.5002: added 4th arg to std-arc->bul,;;; added std-%arc->bul-ccw;;; fixed std-arc->ang, std-arc->seg for ucs (the v0.5 fix was bad);;; renamed std-fixang360 to std-fixang;;; std-arclen is now absolute;;; added std-rtd, ... definitions from stdmath;;; moved std-getpts, std-get-getpts-vertexmask,;;; std-set-getpts-vertexmask;;; from stdpoint to stdent;;; v0.5001: removed std-fixang180;;; v0.5: std-bul->ang: the above fix was wrong! clarified definition,;;; fixed std-arc->seg.;;; finally all segment functions are ucs independent.;;; v0.4008: std-bul->ang: fixed sign;;; v0.4001: entity independent code (points, segs) moved from stdent.lsp;;; and some point code from stdlist.lsp;;;;;; a2000 allows safearrays: segments, segmentlists, points or;;; pointlists may be stored as destructive modifyable safearray's.;;; this is left to an advanced module which may override the segment;;; representation (maker and accessors).;;; $log: stdpoint.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; 2000-06-19 11:00:52 rurban;;; moved std-pline-segs back to stdent so there's no entity accessing;;; function remaining here.;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-06-18 22:55 rurban;;; moved std-getpts, std-get-getpts-vertexmask,;;; std-set-getpts-vertexmask back to stdent;;; 2000-06-14 09:07:35 rurban;;; fixed std-arc->ang, std-arc->seg for ucs;;; std-arclen is now absolute (a distance without sign);;; added std-rtd, ... definitions from stdmath;;; 2000-06-09 17:53 rurban;;; added 4th arg for std-arc->bul,;;; added std-%arc->bul-ccw,;;; renamed std-fixang360 to std-fixang;;; 2000-05-24 rurban;;; removed std-fixang180;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-14 12:57:00 rurban;;; fixed std-%arc->bul, std-arc->bul;;; clarified (wrong) definition for std-bul->ang (wrong sign);;; fixed std-arc->seg: wcs values, not ucs dependent anymore;;; finally all segment functions are ucs independent.;;; 2000-04-05 09:18:55 rurban;;; fixed std-inside-poly-p for different ucs;;; 2000-04-05 07:10:52 rurban;;; std-bul->ang: fixed sign;;; added std-fixang360, std-fixang180, std-ccw, std-ptonseg-p;;; 2000-03-14 22:11:45 rurban;;; moved std-subents to stdent, added std-force3d;;; added std-inside-poly-p, std-poly-inner-pt (not complete yet);;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdpoint-symbols* '(x-of xy-of y-of z-of *pi2* *pi/2* *pi/4* std-dtr std-rtd std-x-min std-y-min std-z-min std-x-max std-y-max std-z-max std-xy-min std-xy-max std-xyz-min std-xyz-max std-midpt std-halfpt std-force3d std-pt+ std-pt- std-new-z std-add-z std-fixang std-pointp std-3dpointp std-2dpointp std-distance-2d std-trans01 std-trans10 std-maptrans01 std-maptrans10 std-make-seg std-seg-p std-seg-p1 std-seg-p2 std-seg-bulge std-seg-bulge-num std-seg-angle std-seg-pts-dist std-seg-straight-p std-seg-p1-uc std-seg-p2-uc std-seg-angle-uc std-seg-length std-segs-closed-p std-pts->segs std-polyedge std-segs->pts std-centroid-2d std-vector-mean-3d std-vector-mean std-ccw std-ptonseg-p std-inside-poly-p std-seg->cir std-arc->seg std-arc->bul std-bul->ang std-arc->ang std-arclen ) ) ));;; avoid reload warnings in vl;;; (eval (list 'pragma;;; (list 'quote;;; (list (cons 'unprotect-assign;;; '(x-of xy-of y-of z-of;;; *pi2* *pi/2* *pi/4*;;; std-dtr std-rtd;;; );;; )))))(if std-defconstant (progn (std-defconstant '*pi2* (* 2.0 pi)) (std-defconstant '*pi/2* (/ pi 2.0)) (std-defconstant '*pi/4* (/ pi 4.0)) ));;; degree to radian(defun std-dtr (deg); (* pi (/ deg 180.0)) (* deg 0.0174532925199433));;; radian to degrees(defun std-rtd (rad); (/ (* rad 180.0) pi) (* rad 57.29577951308233));;; points (from <=0.4 stdlist);;; point coordinate accessors(defun xy-of (p) (list (car p) (cadr p)))(defun x-of (p) (car p))(defun y-of (p) (cadr p))(defun z-of (p) (caddr p));;; boundaries(defun std-x-min (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function min) (mapcar(function car)lst ) ) ))(defun std-y-min (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function min) (mapcar(function cadr)lst ) ) ))(defun std-z-min (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function min) (mapcar(function caddr)lst ) ) ))(defun std-x-max (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function max) (mapcar(function car)lst ) ) ))(defun std-y-max (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function max) (mapcar(function cadr)lst ) ) ))(defun std-z-max (lst) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function max) (mapcar(function caddr)lst ) ) ));;; 2d boundarybox(defun std-xy-min (lst) (list (std-x-min lst) (std-y-min lst)))(defun std-xy-max (lst) (list (std-x-max lst) (std-y-max lst)));;; 3d boundarybox(defun std-xyz-min (lst) (list (std-x-min lst) (std-y-min lst) (std-z-min lst)))(defun std-xyz-max (lst) (list (std-x-max lst) (std-y-max lst) (std-z-max lst)));;; midpoint of 2 points, (2d or 3d);;; p1 + ((p2-p1)/2);;; (2 4)(1 1) -> (1.5 2.5)(defun std-midpt (p1 p2) (std-halfpt (std-pt+ p2 p1)));;; half vector, pt / 2, 2d or 3d, rankless;;; (2 4) -> (1 2)(defun std-halfpt (pt) (mapcar (function /) pt (std-make-list (length pt) 2.0) ));;; assume 2d or 3d points, for safety and convenience(defun std-force3d (pt) (if (caddr pt) pt (std-new-z pt 0.0) ));;; add two vectors(defun std-pt+ (p1 p2); safety (mapcar (function +) (std-force3d p1) (std-force3d p2) ));;; subtract two vectors(defun std-pt- (p1 p2); safety (mapcar (function -) (std-force3d p1) (std-force3d p2) ));;; change z of point(defun std-new-z (pt h) (list (car pt) (cadr pt) h));;; add z value to point(defun std-add-z (pt h) (list(car pt)(cadr pt); safety(cond ((caddr pt) (+ (caddr pt) h) ) (t h )) ));;; force the angle (radians) 0 <= ang < 2pi;;; reduces to [0, 360?;;; takes an angle in radians and reduces it to less than 2pi if ang>=2pi(defun std-fixang (ang) (while (minusp ang) (setq ang (+ ang *pi2*)) ) (if (< ang *pi2*) ang (rem ang *pi2*) ));;; force the angle (radians) 0 <= ang < pi;;; reduces to [0, 180?;;; v0.5001: depricated (no replacement);;; (defun std-fixang180 (ang);;; (while (minusp ang) (setq ang (+ ang *pi2*)));;; (if (< ang pi);;; ang;;; (rem ang pi)));;; -------------------------------------------------------------------73;;; (from <=0.4 stdent);;; predicates:;;; (std-pointp pt) ; 2d or 3d;;; former std-ispointp;;; (std-2dpointppt);;;; (std-3dpointppt);(defun std-pointp (pt) (and (listp pt) (<= 2 (length pt) 3) (apply (function and) (mapcar(function numberp)pt ) ) ))(defun std-3dpointp (pt) (and (listp pt) (= 3 (length pt)) (apply (function and) (mapcar(function numberp)pt ) ) ))(defun std-2dpointp (pt) (and (listp pt) (= 2 (length pt)) (apply (function and) (mapcar(function numberp)pt ) ) ));;; -------------------------------------------------------------------73;;; geometry:;;; (std-distance-2d p1 p2);;;; (std-trans01pt); transform point to ucs;;; (std-trans10pt); transform point to wcs;;; (std-maptrans01pts); transform pointlist to ucs;;; (std-maptrans10pts); transform pointlist to wcs;;; 2d distance (omitting z values)(defun std-distance-2d (p1 p2) (distance (xy-of p1) (xy-of p2)));;; the following four trans functions are acad dependent, but not;;; entity accessing.;;;;;; transform point to ucs;;; easier for (mapcar) with just one argument(defun std-trans01 (pt) (trans pt 0 1));;; transform point to wcs;;; easier for (mapcar) with just one argument(defun std-trans10 (pt) (trans pt 1 0));;; map some pts from wcs to ucs(defun std-maptrans01 (pts) (mapcar (function std-trans01) pts ));;; map some pts from ucs to wcs(defun std-maptrans10 (pts / pt) (mapcar (function std-trans10) pts ));;; -------------------------------------------------------------------73;;; segments, bulges:;;; v0.3013: complete rewrite;;; segment and circle structures:;;; segment: (p1 p2 [bulge]);;; circle: (midpt rad);;; note the changes in v0.3013 in the segment structure from the simple;;; (bulge p1 p2) from the faq to the better (p1 p2 [bulge]) version.;;; v0.5: cleared from ucs dependencies;;; now all segment and bulge functions are ucs independent.;;; all points and angles are wcs values or independent,;;; only the -uc function return ucs values.;;;;;; we may design this "simple" as in the faq or we may define it "good";;; this is a general "worse-is-better" problem, see;;; http://www.ai.mit.edu/docs/articles...ction3.2.1.html;;; making it good but not so simple. i decided to change it to;;; "the right thing" since i prefer lisp over autolisp.;;; but it may be the wrong decision.;;; it may depend of how much code is already written in the faq version;;; which needs to be converted from absolute accessors, like (car seg);;; to relative like (std-seg-bulge), and if care is taken on properly;;; deciding between boolean or numeric use of the bulge.;;;;;; in general you should use abstract segment and circle accessors;;; like (std-seg-p1 seg), (set-make-seg p1 p2 bulge), ...;;; to be able to optimize the internal structure as needed.;;; i changed the function names also from the faq to fit into the;;; general naming scheme.;;; functions:;;; !(std-pline-segspline); is in stdent;;; (std-seg->cirseg); => cir: (midpt radius);;; (std-arc->segcir ang1 ang2); => seg: (p1 p2 bulge);;; (std-arc->bulp1 p2 cir); => bulge as number;;; (std-arc->angchord rad); => arc angle;;; (std-arclenseg); => signed arc length;;; segments:;;; (std-make-seg p1 p2 bulge); create a segment, bulge may be nil;;; (std-seg-p obj); is it a segment? (a2000!);;; (std-seg-p1 seg); first point of segment;;; (std-seg-p2 seg); second point of segment;;; (std-seg-bulge seg); bulge of segment or nil;;; simple segment functions:;;; (std-seg-bulge-num seg); bulge of segment as number;;; (std-seg-angle seg); 2d wcs angle p1-p2;;; (std-seg-pts-dist seg); straight length p1-p2;;; (std-seg-length seg); also curved length;;; (std-seg-straight-p seg); bulge = nil?;;; (std-seg-p1-uc seg); p1 in current ucs;;; (std-seg-p2-uc seg); p2 in current ucs;;; (std-seg-angle-uc seg); 2d angle p1-p2 in current ucs;;; helpers:;;; (std-pts->segs pts) ; (p1 p2 p3) => ((p1 p2)((p2 p3));;; (std-segs->pts segs) ; ((p1 p2)((p2 p3)) => (p1 p2 p3);;; (std-polyedge i poly len) ; 1 (p0 p1 p2 p3) => (p1 p2);;; (std-segs-closed-p segs); closed polygon?;;; segment structure;;; (std-make-seg p1 p2 bulge) => (p1 p2 [bulge]);;; any line or arc may be presented as (p1 p2 [bulge]);;; as in the internal polyline segments. (straight or curved edge);;; we decide to omit zero bulges to use shorter structures.;;; possible a2000 optimization: use safearray(defun std-make-seg (p1 p2 bulge) (if (andbulge(not (zerop bulge)) ) (list p1 p2 bulge) (list p1 p2) ));;; shorter data structure;;; is it a segment?;;; beware of a possible a2000 optimization.;;; that's why we need a special predicate.(defun std-seg-p (obj) (and (consp obj) (std-pointp (car obj)) (std-pointp (cadr obj)) ))(defun std-seg-p1 (seg) (car seg))(defun std-seg-p2 (seg) (cadr seg));;; std-seg-bulge returns always nil on straight edges (bulge=0.0),;;; so it's usable as predicate also.(defun std-seg-bulge (seg) (cond ((not (caddr seg)) nil ) ((zerop (caddr seg)) nil ) ((caddr seg)) ));;; std-seg-bulge-num returns the numeric bulge value.;;; for calculations with bulges, converts nil to 0.0;;; this used less often than the boolean std-seg-bulge(defun std-seg-bulge-num (seg) (cond ((std-seg-bulge seg)) (t 0.0 ) ));;; simple segment functions:(defun std-seg-angle (seg) (angle (std-seg-p1 seg) (std-seg-p2 seg)))(defun std-seg-pts-dist(seg) (distance (std-seg-p1 seg) (std-seg-p2 seg)))(defun std-seg-straight-p (seg) (not (std-seg-bulge seg)))(defun std-seg-p1-uc (seg) (std-trans01 (car seg)))(defun std-seg-p2-uc (seg) (std-trans01 (cadr seg)))(defun std-seg-angle-uc(seg); ucs angle (angle (std-seg-p1-uc seg) (std-seg-p2-uc seg)))(defun std-seg-length (seg) (if (std-seg-straight-p seg); fixed (std-seg-pts-dist seg) (abs (std-arclen seg)) ));;; more segment functions:;;; (std-segs-closed-p segs) => t/nil;;; t if p1 of the first segment is the same as p2 of the last.;;; note: you might also need to check if the last segment is straight.;;; note: don't use it with pointlists! this is completely different.(defun std-segs-closed-p (segs) (equal (std-seg-p1 (car segs)) (std-seg-p2 (last segs))));;; (std-pts->segs pts) => segs;;; converts a pointlist of an open polygon to a list of straight;;; segments. on closed polylines the last closing segment must be forced;;; by;;; adding the first point to the end of the list.;;; (p1 p2 p3) => ((p1 p2)(p2 p3)); open;;; (p1 p2) => ((p1 p2)); straight single line;;; (p1 p2 p3 p1) => ((p1 p2)(p2 p3)(p3 p1)); closed(defun std-pts->segs (_pts / _len) (setq _len (length _pts)) (mapcar (function (lambda (_i)(std-polyedge _i _pts _len) ) ) (std-int-list (1- _len)) ));;; (std-polyedge i poly len) => (p p[i+1]);;; i-th edge of polygon (zero-based) => segment;;; (std-polyedge 1 (p1 p2 p3 p4) 4) => (p2 p3)(defun std-polyedge (i poly len) (list(nth (std-nxtcyc i len 'abs) poly) ; p1 - fixed(nth (std-nxtcyc i len '1+) poly) ));;; p0 - fixed;;; dummy 'abs function to avoid errors with i=-1 or len+1;;; only if you're absolutely sure that 0 <= i < len then use (nth i poly);;; (std-segs->pts segs) => pts;;; converts segments to pointlist;;; ((p1 p2)(p2 p3)) => (p1 p2 p3);;; fixed by serge pashkov(defun std-segs->pts (segs) (append (mapcar (function std-seg-p1) segs ) (list (std-seg-p2 (last segs))) ));;; fixed;;; -------------------------------------------------------------------73;;; some advanced geometry for centroids and planar polygons;;; twice the area of a simple 2d triangle;;; the vector cross product in 2d, z ignored(defun std-%areax2 (a b c) (- (* (- (car b) (car a)) (- (cadr c) (cadr a))) (*(- (car c) (car a))(- (cadr b) (cadr a)) ) ));;; three times the centroid of a simple 2d triangle,;;; z ignored, 2d point returned(defun std-%centroid2dx3 (pts) (if (> (length pts) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (list (apply (function +) (mapcar (function car) pts ) ) (apply (function +) (mapcar (function cadr) pts ) ) ) ));;; computes the centroid (center of gravity) of an arbitrary;;; simple polygon via the weighted sum of the signed triangle areas,;;; weighted by the centroid of each triangle.;;; thanks to kamal boutora <synapse@ist.cerist.dz>;;; returns a 2d or 3d point, dependant on the first given point.;;; the double area and three times centroid functions are used to;;; avoid division. see comp.graphics.algorithms faq or;;; the o'rourke code centroid.c;;; curved areas are not honored, use region and (std-massprop) then.(defun std-centroid-2d (pts / areasum2 a2 p0 c3 cg) (setqareasum2 0.0cg '(0 0)p0 (car pts)pts (cdr pts) ) (if (equal p0 (last pts)) (setq pts (std-butlast pts)) ) (while (cadr pts) (setq c3 (std-%centroid2dx3 (list p0 (car pts) (cadr pts))) a2 (std-%areax2 p0 (car pts) (cadr pts)) cg (list (+ (car cg) (* a2 (car c3))) (+ (cadr cg) (* a2 (cadr c3) ) ) ) areasum2 (+ areasum2 a2) pts (cdr pts) ) ) (setq areasum2 (* areasum2 3.0)) (cond ((zerop areasum2) nil ); or (std-vector-mean-3d pts) ((caddr p0) (list (/ (car cg) areasum2) (/ (cadr cg) areasum2) (caddr p0) ) ) (t (list (/ (car cg) areasum2) (/ (cadr cg) areasum2)) ) ));;; std-vector-mean-3d;;; ((2 4)(1 1)) -> (1.5 2.5 0.0);;; ((2 2)(2 4)(1 1)) -> (2.5 3.5 0.0)(defun std-vector-mean-3d (pts / n) (setq n (float (length pts))) (if (> n *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (list (/ (apply (function +) (mapcar (function car) pts ) ) n ) (/ (apply (function +) (mapcar (function cadr) pts ) ) n ) (if (caaddr pts) (/ (apply (function +) (mapcar (function caddr) pts ) ) n ) 0.0 ) ) ));;; general n-dimensional version. quite hairy.;;; inspired by doug wilson's (list-transpose)(defun std-vector-mean (pts) (if (> (length pts) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) ); mean of each vector (mapcar (function /); sum it up (all x,y..) (mapcar (function(lambda(v) (apply (function +) v )) ); transposition: flip rows with cols (apply(function mapcar)(cons 'list pts) ) ) (std-make-list (length (car pts)) (float (length pts))) ));;; test counter-clockwise of 3 points (the rotation);;; => 1: ccw,;;; -1: cw or p0 between p1 and p2;;; 0: p2 between p0 and p1;;; determinant of matrix >0 (2x signed area of triangle p0,p1,p2);;; |p0x p0y 1|;;; |p1x p1y 1|;;; |p2x p2y 1|;;; see sedgewick or others(defun std-ccw (p0 p1 p2 / dx1 dx2 dy1 dy2) (setqdx1 (- (car p1) (car p0))dy1 (- (cadr p1) (cadr p0))dx2 (- (car p2) (car p0))dy2 (- (cadr p2) (cadr p0)) ) (cond ((> (* dx1 dy2) (* dy1 dx2)) 1 ) ((< (* dx1 dy2) (* dy1 dx2)) -1 ) (t (cond ((or (minusp (* dx1 dx2)) (minusp (* dy1 dy2)))-1 ); explicit distance ((>= (+ (* dx1 dx1) (* dy1 dy1)) (+ (* dx2 dx2) (* dy2 dy2)))0 ) (t1 ) ) ) ));;; (std-ptonseg-p p1 p2 testpt);;; this function is used to test a point being exactly on a straight;;; line segment or not. (not on the extension, in between)(defun std-ptonseg-p (p1 p2 pt) (if (equal p1 p2 1e-6) (equal pt p1 1e-6) (zerop (std-ccw p1 p2 pt)) ));;; (std-inside-poly-p pt pts);;; t if the point is strictly inside the poly,;;; nil if outside or on any boundary segment.;;; status: this is quite hairy and not 100% reliable, because;;; it relies on certain ssget acad features. a fast independent;;; solution is out of the scope of lisp, but there are c libs;;; and a lisp file.;;; note:;;; there must be no duplicate points!;;; the polygon must not be self-intersecting!;;; all points must be in the current ucs.(defun std-inside-poly-p (pt pts / found lay ss) (std-%simple-require "STDTBL"); ensure that the current layer is; on (if (not (std-layer-visible-p (setq lay (getvar "CLAYER")))); find the; first visible layer or; if none is visible, make a new one (if(not (setq lay (car (std-tbl-layer "*" std:lay-thawed 0 std:lay-on)))) (std-layer-add(setq lay (std-tbl-tmpname "LAYER" "$STD-POLY")) ) ) ); check zoom range: all pts must be; visible! (std-var-push '((:zoom))) (std-zoom-if (std-xy-min pts) (std-xy-max pts)) (if (not (entmake (list '(0 . "POINT") (cons 10 (std-trans10 pt)) (cons 8 lay) ) ) ) (std-error "entmake POINT failed") ) (setqfound (and(setq ss (ssget "_WP" pts))(ssmemb (entlast) ss) ) ) (std-var-pop) (entdel (entlast)) found);;; -------------------------------------------------------------------73;;; some simple curves: arcs and circles;;; all functions are ucs independent, we may assume wcs or ucs;;; points and angles.;;; (std-seg->cir seg) => (midpt radius);;; converts a bulged segment (p1 p2 [bulge]) of a polyline;;; to a circle (ctr rad). the start- and endpoints are known,;;; therefore the angles too: (angle ctr pt1)(angle ctr pt2);;; returns nil on a straight segment! fixed by serge pashkov(defun std-seg->cir (seg / bulge p1 p2 cot x y rad dummy) (if (setq bulge (std-seg-bulge seg)); straight line => invalid circle (setq p1(std-seg-p1 seg) p2(std-seg-p2 seg) cot(* 0.5 (- (/ 1.0 bulge) bulge)) x(/ (- (+ (car p1) (car p2)) ; x and y of midpoint (* (- (cadr p2) (cadr p1)) cot) ) 2.0) y(/ (+ (+ (cadr p1) (cadr p2)) (* (- (car p2) (car p1)) cot)) 2.0) rad(distance (list (car p1) (cadr p1)) (list x y)) dummy(list (list x y) rad); return this, i hate progn's ) ));;; (std-arc->seg cir ang1 ang2) => (p1 p2 bulge);;; - inverse conversion:;;; calculates segment (p1 p2 bulge) of arc;;; with given circle (ctr rad), start-angle, end-angle;;; (std-arc->seg cir (angle (car cir) p1) (angle (car cir) p2)) => seg;;; angles in wcs (measured to the world x axis);;; all points (cir p1 p2) ucs independent (wcs or ucs);;; note: polar does not work as described in the docs.;;; the angle is ucs independent, so our function as well.(defun std-arc->seg (cir ang1 ang2 / p1 p2) (setqp1 (polar (car cir) ang1 (cadr cir))p2 (polar (car cir) ang2 (cadr cir)) ) (listp1p2; use this sign(std-tan (* 0.25 (- ang2 ang1))) ));;; (std-%arc->bul ang1 ang2) => bulge;;; - calculates positive bulge of arc defined by its two angles;;; ang1: angle from ctr to p1, ang2: angle from ctr to p2;;; the correct rotation (sign) must be applied later,;;; see std-%arc->bul-ccw;;; fixed 14-apr-00, 9-jun-00(defun std-%arc->bul (ang1 ang2) (std-tan (* 0.25 (std-fixang (- ang2 ang1)))));;; with explicit rotation given(defun std-%arc->bul-ccw (ang1 ang2 ccw) (if (minusp ccw) (- (std-%arc->bul ang2 ang1)) (std-%arc->bul ang1 ang2) ));;; (std-arc->bul p1 p2 cir ccw) => bulge;;; calculates positive bulge (ccw) of arc given both arc endpoints;;; and the circle (ctr rad). (the radius is not needed);;; ucs independent (angle is ucs dependent, but the difference not)(defun std-arc->bul (p1 p2 cir ccw) (std-%arc->bul-ccw (angle (car cir) p1) (angle (car cir) p2) ccw ));;; note:;;; before you had to flip the sign on cw rotation like this:;;; (* (std-ccw p1 xx p2) (std-arc->bul p1 p2 cir)) ; or;;; (* (std-signum (std-seg-bulge segxx)) (std-arc->bul p1 p2 cir));;; old code:;;; this is of course a stupid recalculation of an already computed value;;; (defun std-bul->ang (seg / ctr);;; (- (angle (setq ctr (car (std-seg->cir seg))) (std-seg-p2 seg));;; (angle ctr (std-seg-p1 seg))));;; (std-bul->ang seg) => angle;;; returns inner angle of an arc given by its bulge,;;; angle from center to endpoint minus angle to startpoint.;;; note:;;; fixed again for v0.5 14-apr-00.;;; we assumed a wrong definition here for v0.4008-0.4009,;;; same sign as in the faq again(defun std-bul->ang (seg) (* 4 (atan (std-seg-bulge-num seg))));;; (std-arc->ang chord rad) => angle;;; calculates inner angle of arc given the chord distance and radius;;; this is the absolute inner angle (as with std-bul->ang);;; 14-jun-00: fixed divide by zero on square;;; on chord > 2r => error: function undefined for argument(defun std-arc->ang (chord rad / root) (cond ((= (* 2 rad) chord) 0 ); pi would return wrong bulge (t (*2.0(atan (/ chord 2.0 (sqrt (- (* rad rad) (* 0.25 chord chord))))) ) ) ));;; "bartsch": chord = 2r sin (ang/2) (chord: "sehne", s.236,224);;; => ang = 2 * asin (chord / 2r) , 2r >! chord;;; asin: (atan z (sqrt (- 1.0 (* z z))));;; (defun std-%arc->ang1 (chord rad) ; simplier version? to time;;; (* 2 (std-asin (/ chord rad 2))));;; (defun std-%arc->bul1 (chord rad);;; (std-tan (* 0.5 (std-asin (/ chord rad 2)))));;; (std-arclen seg);;; => length of arc = radius * angle;;; does not check for curved segment, bulge must be <> 0;;; otherwise you'll get 0.0 and not the straight distance.(defun std-arclen (seg) (abs (* (cadr (std-seg->cir seg)); radius 4.0 (atan (std-seg-bulge-num seg)) ) ));;; angle = 4*atan(bulge);;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdpoint-symbols*))(setq *stdpoint-symbols* nil);;; module dependencies:(std-%simple-provide "STDPOINT");;; first provide it, but before you may;;; call it, be sure to have all supporting;;; functions:;;; if all required stdlib modules are contained in one project,;;; we don't have to load it explicitly.;;; stdlib.fas already contains it!;;; (if (not *std:%project*) (progn(std-%simple-require "STDINIT")(std-%simple-require "STDLIST")(std-%simple-require "STDLISP")(std-%simple-require "STDSTR")(std-%simple-require "STDFILE")(std-%simple-require "STDMATH")(std-%simple-require "STDTIME");;; (std-%simple-require "stdaci") ; almost all;;; ));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdtime.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:31:03 rurban>;;; copyright (c) 1994,1998,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; time functions for the stdlib;;; status:;;; std-cdate->datlst has accuracy errors. see the test files.;;; std-time moved to stddebug;;; output and date arithmetic not in small;;; dates around year and month zero are erronous.;;; => wrong time and date calculations.;;; std-canonize-datlst yet impossible;;; std-canonize-cdate is useless art, datlst is the only lossless;;; format;;; $log: stdtime.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-07-27 17:02:18 rurban;;; added std-%timer-ms-str;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; 2000-06-20 16:12:35 rurban;;; added std-canonize-datlst, try to fix dates around zero;;; fixed std-%format-date-string for relative dates (low numbers);;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-19 10:06:24 rurban;;; fixed (std-%format-date-string cdate "sss");;;;;; revision 0.4009 2000/04/07 17:29:20 rurban;;; v0.4009, see changes;;;;;; ==================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdtime-symbols* '(std-date->datlst std-datlst->date std-cdate->datlst std-datlst->cdate std-datlst-year std-datlst-month std-datlst-day std-datlst-hour std-datlst-min std-datlst-secs std-datlst-dow std-date->cdate std-cdate->date std-canonize-cdate std-canonize-datlst std-date-diff std-date-sum std-today std-today-long std-cdate->date-string std-cdate->time-string std-timer-start std-timer-stop std-sleep ) ) ));;; date (julian date) may be used for subtraction and addition.;;; it is the number of days (plus fractional seconds, utc) in the;;; julian calendar.;;; cdate is a readable number of the calendar date, may be used for;;; sorting also.;;; datlst is a a list of numbers in calendar format as in cdate.;;; (year like 1998;;; month [1-12];;; day[1-31];;; hour [0-23];;; minute [0-59];;; seconds [0-59.9] real;;; [dow][0-6] monday-sunday;;; );;; internal-time is the number of non-leap seconds since;;; 00:00:00 utc, january 1, 1970;;; round-off problems in cdate format;;; -----------------------------------;;; the cdate floating point number;;; is defined as a floating-point number interpreted as:;;;;;; yyyymmdd.hhiissttt;;;;;; this gives 17 digits but maximal 16 digits (up to milliseconds);;; can be represented by double iee floating point numbers and this;;; degrade to 15 precise digits after some calculations. (10 ms);;; so don't use cdate numbers in calculations, do everything in datlst;;; (preferred because single numbers don't loose accuracy) or;;; julian date if you need milliseconds accuracy.;;; decompose julian date into calendar date datlst.;;; the algorithm is from collected algorithms from;;; communications of the acm. the only "magic" function here.;;; note: this function is wrong for early dates,;;; for relative date calculations e.g.(defun std-date->datlst(date / time julian yr day mo hh ss mm) (setq time (* 86400.0 (- date (setq julian (fix date))))) (setq julian (- julian 1721119)) (setq yr (/ (1- (* 4 julian)) 146097)) (setq julian (- (* julian 4) 1 (* 146097 yr))) (setq day (/ julian 4)) (setq julian (/ (+ (* 4 day) 3) 1461)) (setq day (- (+ (* 4 day) 3) (* 1461 julian))) (setq day (/ (+ day 4) 4)) (setq mo (/ (- (* 5 day) 3) 153)) (setq day (- (* 5 day) 3 (* 153 mo))) (setq day (/ (+ day 5) 5)) (setq yr (+ (* 100 yr) julian)) (if (< mo 10) (setq mo (+ mo 3)) (setq mo (- mo 9) yr (1+ yr) ) ) (setq hh (fix (/ time 3600.0))) (setq time (- time (* hh 3600))) (setq mm (fix (/ time 60.0))) (setq ss (- time (* mm 60))) (list yr mo day hh mm ss));;; std-datlst->date converts calender datlst into julian date format;;; datlst: (yr mo day hh mm ss);;; date: julian date;;; problem: '(0 0 0 ...) => wrong;;; fails with negative years and dates around zero (for time differences)(defun std-datlst->date(datlst / yr y mo day hh mm ss a b) (setqyr (car datlst)y yrmo (cadr datlst)day (caddr datlst)hh (fourth datlst)mm (fifth datlst)ss (sixth datlst) ) (if (and(zerop y)(zerop mo) ); added 20-jun-00: day 0 when? -4712; probably (=> 1721058 days) (+ 1721024 day (/ (+ (* (+ (* hh 60) mm) 60) ss) (* 24.0 60 60)) ) (progn (if (<= mo 2)(setq y (1- y) mo (+ mo 12)) ) (if (or (< yr 1582) (and (= yr 1582) (or(< mo 10)(and (= mo 10) (< day 5)) ) ) )(setq b 0); simple old julian calendar(setq a(fix (/ y 100)); gregorian calendar fix b(+ (- 2 a) (fix (/ a 4)))) ) (+ (fix (+ (* 365.25 (+ y 4716)) (fix (* 30.6001 (+ mo 1))))) day b -1524.0 (/ (+ (* (+ (* hh 60) mm) 60) ss) (* 24.0 60 60)) ) ) ));;; yr: 4 digit fixnum! (such as 1984);;; fails with negative numbers(defun std-%isleap-year(yr) (setq yr (fix yr)) (or (zerop (rem yr 400)) (and (zerop (rem yr 4)) (not (zerop (rem yr 100))) ) ));;; yr: 4 digit fixnum! (1984);;; fails with negative numbers(defun std-%years->days(yr) (setq yr (fix yr)) (+ (* yr 365) (/ yr 4) (- (/ yr 100)) (/ yr 400)));;; mo: must be fixnum!(defun std-%months->days (mo) (setq mo (fix mo)) (/ (- (* mo 3057) 3007) 100));;; calculate the day of the week for a given date.;;; => 0-6: monday-sunday;;; autodesk's julian.lsp as well as the clib dow functions use sunday;;; as base, common lisp functions use the monday as 0. hmm...;;; thanks to serge pashkov(defun std-%day-of-week(date) (rem (fix date) 7));;; std-datlst->internal-time converts calender datlst into;;; the number of non-leap seconds since 00:00:00 utc, january 1, 1970;;; commonly known as localtime or unix time.;;; datlst: (yr mo day hh mm ss)(defun std-%datlst->internal-time (datlst / yr mo day hh mm ss) (setqyr (car datlst)mo (cadr datlst)day (caddr datlst)hh (fourth datlst)mm (fifth datlst)ss (sixth datlst) ) (+ (*; days -> seconds (+ (std-%years->days (fix (- yr 1970))) (std-%months->days (fix mo) ) day ) 86400.0 ) (* hh 3600.0) (* mm 60.0) (fix ss) ));;; cdate (calendar date) is the string representation of datlst:;;; similar to the string decomposition;;; max. to milliseconds accuracy if you are lucky.;;; 19700101.0 => (1970 1 1 0 0 0.0)(defun std-cdate->datlst (cdate / yr mo day hh mm sec rst) (setq yr (fix (/ cdate 10000.0))) (setq cdate (- cdate (* 10000.0 yr))) (setq mo (fix (/ cdate 100.0))) (setq cdate (- cdate (* 100.0 mo))) (setq day (fix cdate)) (setq rst (- cdate day)); 0.121245 => 12 12 45.0 (setq hh (fix (* rst 100))) (setq rst (- rst (/ hh 100.0))) (setq mm (fix (* rst 10000))) (setq sec (* 1000000.0 (- rst (/ mm 10000.0)))) ; fixed (list yr mo day hh mm sec));;; similar to the string composition;;; max. to milliseconds accuracy if you are lucky [improved by serge;;; pahkov];;; (yr mo day hh mm ss) => cdate;;; todo: normalization(defun std-datlst->cdate (datlst) (+ (/ (nth 5 datlst) 1000000.0) (/ (nth 4 datlst) 10000.0) (/ (nth 3 datlst ) 100.0 ) (nth 2 datlst) (* 100.0 (nth 1 datlst)) (* 10000.0 (nth 0 datlst)) ));;; datlst struct-like accessors(defun std-datlst-year (datlst) (first datlst))(defun std-datlst-month(datlst) (second datlst))(defun std-datlst-day (datlst) (third datlst))(defun std-datlst-hour (datlst) (fourth datlst))(defun std-datlst-min (datlst) (fifth datlst))(defun std-datlst-secs (datlst) (sixth datlst))(defun std-datlst-dow (datlst) (cond ((seventh datlst)) ((std-%day-of-week (std-datlst->date datlst))) ));;; (defun std-%datlst-ampm (datlst) (eighth datlst));boolean?;;; conversion via datlst, best accuracy(defun std-date->cdate (date) (std-datlst->cdate (std-date->datlst date)));;; conversion via datlst, best accuracy(defun std-cdate->date (cdate) (std-datlst->date (std-cdate->datlst cdate)));;; we must go via data for the correct decomposition;;; e.g: day > 31 => month + 1;;; but we cannot fix wrong seconds, so better use;;; std-canonize-datlst when it will work for low dates;;; (time differences)(defun std-canonize-cdate (cdate) (std-date->cdate (std-cdate->date cdate)));;; shift overflows to the left and underflows to the right;;; doesn't work for low dates: (time differences)(defun std-canonize-datlst (datlst) (std-date->datlst (std-datlst->date datlst)));;; ------------------------------------------------------------------73;;; date arithmetic:;;; no such funcs in small;;; some date arithmetic, accept any reasonable date format.;;; cdate with only maximal seconds accuracy, no milliseconds!;;; dat1 - dat2;;; (std-date-diff '(1998 12 01 0 0 0) 4) => 19981127;;; (std-date-diff 19981208 19981204) => 19981212(defun std-date-diff (dat1 dat2) (setqdat1 (std-%guess-date-format dat1)dat2 (std-%guess-date-format dat2) ) (std-date->cdate (- dat1 dat2)));;; dat1 + dat2;;; if one argument is not a resonable cdate, convert it to a;;; reasonable date format.;;; (std-date-sum 19981208 4) => 19981212;;; (std-date-sum 19981130 2) => 19981202;;; (std-date-sum 19981231.12 1) => 19990101.12(defun std-date-sum (dat1 dat2) (setqdat1 (std-%guess-date-format dat1)dat2 (std-%guess-date-format dat2) ) (std-date->cdate (+ dat1 dat2)));;; accept either date, datlst or cdate,;;; cdate must be a number like 19xxxxxx;;; return date format(defun std-%guess-date-format (dat) (cond ((listp dat) (std-datlst->date dat) ) ((< 19000000 dat 20320000) (std-cdate->date dat) ) (t dat ) ));;; ------------------------------------------------------------------73;;; output;;; no output funcs in small, maybe consider std-today;;; current date as string, localized conventions;;; such as "9.7.98" or "7/9/98"(defun std-today () (if (std-acad-connection-p) (std-cdate->date-string (getvar "CDATE")) (progn (std-require-version "FILEEXT" 0.56) (std-cdate->date-string(std-datlst->cdate (std-%standalone-actual-datlst)) ) ) ));;; as "7.july 1998"(defun std-today-long () (std-%format-date-string (if(std-acad-connection-p) (getvar "CDATE") (std-datlst->cdate(std-%standalone-actual-datlst) ) ) "d.mmmm yyyy" ));;; user setable date format options:;;; mm/dd/yy, m/d/yy, m/d/yy;;; locale settings are done in stdlocal(if (not *date-format-string*) (setq *date-format-string* "m/d/yy"))(if (not *time-format-string*) (setq *time-format-string* "hh:nn:ss AMPM"));;; format string: "d.m.yy" if not :english;;; "m/d/yy" if :english(defun std-cdate->date-string (cdate) (std-%format-date-string cdate *date-format-string*));;; format string: "hh:nn:ss", hour, minutes, seconds as "14:00:23"(defun std-cdate->time-string (cdate) (std-%format-date-string cdate *time-format-string*));;; format string: "%d/%d%/%2d", month, day, year if :english;;; => "2/21/98";;; format string: "%d.%d%.%2d", day, month, day if not :english;;; strips leading "0";;; keep leading "0", no milliseconds, no am/pm support yet;;; localized versions see stdlocal(std-defconstant '*month-names* '("January" "February" "March" "April""May" "June" "July" "August" "September""October" "November" "December" ))(std-defconstant '*week-days* '("Monday" "Tuesday""Wednesday" "Thursday" "Friday" "Saturday""Sunday" "???" ));;; returns portions of cdate according the given format string.;;; not all format string options are supported yet.;;; yyyy - long year, 4 digits;;; yy - short year, 2 digits;;; mmmm - long month string;;; mmm - 3char month string abbrevation;;; mm - month 2 digits;;; m - month 1 digit if zero;;; dddd - day of week long string (sunday);;; ddd - 2char day of week string abbrevation (su-sa);;; dd - day 2 digits;;; d - day 1 digit if zero;;; hh - hour 2 digits;;; h - hour 1 digit if zero;;; nn - minutes 2 digits;;; n - minutes 1 digit if zero;;; sss - seconds with milliseconds;;; ss - seconds 2 digits;;; s - seconds 1 digit if zero;;; ampm - am or pm literal suffix;;; ampm - am or pm;;; problem: all magic characters are expanded so far, so we cannot use;;; verbose format strings, like "today is ddd, the d.mmmm yyyy", because;;; the "d" in "today" and the "s" in "is" and the "h" in "the" will be;;; expanded too. this could be fixed by having a look at word boundaries.;;; fixme: wrong for "s" "ss" "sss", "sss" fixed 19-apr-00;;; relative cdates (empty days, ...) fixed 20-jun-00(defun std-%format-date-string (cdate fmt / ws datlstret x i lmagic ampmupcase ); (if (std-acad-connection-p); (setq s; (std-string-right-pad-char (rtos; cdate 2 9) 16 "0")); ;; rounding to the 8-th digit.; improved somewhat for standalone; (setq s (strcat (itoa (fix; cdate)) "."; (substr (std-rtos; (std-fraction cdate)) 3))); ); fixed v0.5002 for 0.0xx seconds (if (std-acad-connection-p) (setq s (rtos cdate 2 9)) (setq s (std-rtos cdate)) ); add zeros at the front (if (setq i (std-strpos "." s)); 11-jul-00 (repeat (- 9 i) (setq s (strcat "0" s)) ) ); add trailing zeros (setq s (std-string-right-pad-char s 16 "0")); (setq s (substr s 1 16)) (setq datlst (std-cdate->datlst cdate)) ; hmm, not true anymore:; we need to calculate datlst for; the month and the hour as number; else it's nil (if (or(std-strpos "ddd" fmt)(std-strpos "mmm" fmt)(setq ampm (std-stripos "AMPM" fmt)) ) (setq datlst (append datlst (list (if (std-strpos "ddd" fmt) (std-%day-of-week (std-datlst->date datlst)); =>; 0-6 (monday-sunday) nil ) ampm ) ) ) ); special handling of ampm (this is; really a pain) (if ampm (if(std-strpos "AMPM" fmt) (setq fmt (std-strchg fmt "AMPM" "") upcase t ) (setq fmt (std-strchg fmt "ampm" "")) ) ); parse out the relevant format; string subportions (setqmagic (std-string->list "mdyhns")i 1l (strlen fmt)ret "" ) (while (< i l) (setq x "") (while (member (ascii (substr fmt i 1)) magic) (setq x (strcat x (substr fmt i 1)) i (1+ i) ) ) (setq ret (strcat ret (if (std-string-not-empty-p x)(std-%format-date-substring s x datlst ampm)(substr fmt (1- (setq i (1+ i))) 1) ) ) ) ) (if ampm (strcat ret (if(= (std-lastchar fmt) " ") " " "" ); temp workaround (std-%format-date-substring s (if upcase"AMPM""ampm" ) datlst ampm ) ) ret ));;; wrong? hmm..;;; 12:00 am is midnight, 12:00 pm is noon(defun std-%time->ampm (hh prefix) (cond ((= hh 0) "12" ) ((>= hh 22) (itoa (- hh 12)) ) ((> hh 12) (strcat prefix (itoa (- hh 12))) ) ((>= hh 10) (itoa hh) ) (t (strcat prefix (itoa hh)) ) ));;; s is the string representation of the cdate;;; fmt the magic substring;;; datlst the date in datlst format to avoid double calcluations;;; ampm is boolean(defun std-%format-date-substring (s fmt datlst ampm / mo) (setq mo (std-datlst-month datlst)) (cond ((= fmt "yyyy") (substr s 1 4) ) ((= fmt "yy") (substr s 3 2) ) ((= fmt "mmmm") (nth (1- mo) *month-names*) ); "january" ((= fmt "mmm") (substr (nth (1- mo) *month-names*) 1 3) ); "jan" ((= fmt "mm") (substr s 5 2) ); "01" ((= fmt "m") (if (= "0" (substr s 5 1)) (substr s 6 1) (substr s 5 2) ) ) ((= fmt "dddd") (nth (std-datlst-dow datlst) *week-days*) ); "sunday" ((= fmt "ddd") (substr (nth (std-datlst-dow datlst) *week-days*) 1 3) ); "sun" ((= fmt "dd") (substr s 7 2) ); "07" ((= fmt "d") (if (= "0" (substr s 7 1)) (substr s 8 1) (substr s 7 2) ) ) ((= fmt "hh") (if ampm (std-%time->ampm (std-datlst-hour datlst) "") (substr s 10 2) ) ) ((= fmt "h") (if ampm (std-%time->ampm (std-datlst-hour datlst) "0") (substr s 10 2) ) ) ((= fmt "nn") (substr s 12 2) ) ((= fmt "n") (if (= "0" (substr s 12 1)) (substr s 13 1) (substr s 12 2) ) ) ((= fmt "sss"); fixed 19-apr-00 (strcat (substr s 14 2) (if (and (std-module-defined-p "STDLOCAL") (std-functionp stdlocal-ads-version) ); should we use the locale comma; delimiter? (std-get-locale-info "decimal_point") "." ) (substr s 16) ) ) ((= fmt "ss") (substr s 14 2) ) ((= fmt "s") (if (= "0" (substr s 14 1)) (substr s 15 1) (substr s 14 2) ) ) ((= fmt "AMPM") (if (> (std-datlst-hour datlst) 11) "PM" "AM" ) ) ((= fmt "ampm") (if (> (std-datlst-hour datlst) 11) "pm" "am" ) ) (t "" ) ));;; ------------------------------------------------------------------73;;; simple benchmarking:;;; see stddebug or (std-require 'stddebug) for std-time which;;; provides much more features.;;; number of milliseconds since midnight 0:00;;; we want a integer for better arithmetics.;;; the milliseconds accuracy should be enough(defun std-%date->milliseconds (date); truncate the days and use only the; fractional; part of the seconds since today; 0:00,; convert it to milliseconds and; integer. (std-round (* 86400000 (std-fraction date))));;; try to improve it with an internal extension,;;; also needed for stand-alone mode.(if (std-functionp std-%get-internal-run-time) ; fileext v0.4 (defun std-%portable-run-time(); => milliseconds (std-%get-internal-run-time) ); any number interpretable as; milliseconds (defun std-%portable-run-time() (std-%date->milliseconds (getvar "DATE")) ));;; starts stopclock, stores a number in milliseconds.;;; around 0:00 you will experience problems, so don't run it in;;; plain autolisp over midnight!(defun std-timer-start () (setq *std:timer-start* (std-%portable-run-time)));;; stops stopclock, stores and returns the difference to;;; std-timer-start in milliseconds;;; around 0:00 you will experience problems, so don't run it in;;; plain autolisp over midnight!(defun std-timer-stop (timer); this is the difference, no; stop-clock (- (std-%portable-run-time) (cond (timer) (*std:timer-start*) ) ));;; elapsed time in seconds (real)(defun std-%timer-secs (timer) (/ (std-timer-stop timer) 1000.0));;; elapsed milliseconds formatted as string.;;; we loose precision, rounding the last number;;; (1000-th -> 100-th)(defun std-%timer-ms-str (msec / cdate) (setqcdate (std-datlst->cdate(std-canonize-datlst (list00000(/ msec 1000.0) )) ) ) (std-%format-date-string cdate (cond ((> msec 3600000) "hh:nn:sss" ) ((> msec 60000) "nn:sss" ) (t "sss" ) ) ));;; sleeps for seconds, does nothing but waiting.;;; takes real and int. uses autocad's date or the internal millisecond;;; timer. this is only approximate, not exact.(if (std-functionp std-%get-internal-run-time) ; fileext v0.4 (defun std-sleep (secs / endt) (setq endt (+ (* 1000 secs) (std-%get-internal-run-time))) (while (< (std-%get-internal-run-time) endt) t ) ); i provide a simplier autolisp; version if someone is; concerned about consing. (defun std-sleep (secs / endt) (setq endt (+ (getvar "DATE") (/ secs 86400.0))) ; fixed (while (< (getvar "DATE") endt) t ) ));;; (defun std-%sleep-ms (ms / endt);;; (setq endt (+ (getvar "date") (/ ms 8640000.0)));;; (while (< (getvar "date") endt) t));;; ------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdtime-symbols*))(setq *stdtime-symbols* nil);;; module dependencies:(std-%simple-provide "STDTIME");;; first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.(std-%simple-require "STDSTR");;; padding, trimming(std-%simple-require "STDLIST");;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdinput.lsp 0.5006 2000/12/31 10:59:00 rurban rel $-*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:43 rurban>;;; copyright (c) 1993,98 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; user input functions for the stdlib;;; because user input functions are the frontend of a program to the;;; user, this module is quite generic but powerful.;;; of course not all fancy input styles are supported and is;;; questionable if and how hooks should be provided.;;; but it is at least a common and better framework than the system;;; provided one.;;;;;; status: experimental;;; std-yes-or-no-p missing.;;; std-inp-ssget and std-ssget are good candidates to be removed.;;; maybe we need hooks for additional :before :after :around methods;;; how to name std-getscale? (or std-inp-getscale);;; translated messages from stdlocal supported.;;; problem:;;; user-interactive funcs cannot be tested automatically;;; ==================================================================73;;; $log: stdinput.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-04-26 18:19:49 rurban;;; renumbered msg id's;;; 2000-04-09 18:36:09 rurban;;; removed std-yes-or-no-p;;;;;; ==================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdinput-symbols* '(std-%inp-return std-getint std-getreal std-getpoint std-getcorner std-getangle std-getangle-deg std-getdist std-getscale std-inp-getkword std-getstring std-inp-edit-string std-inp-getname std-inp-getvector std-inp-entsel std-inp-nentsel std-inp-yesno std-yesno std-dcl-yesno std-getkword std-get1point std-get2point std-get1dist std-get2dist std-entsel std-nentsel std-ssget std-inp-ssget ) ) ))(if (/= (type *std:max-keywordlen*) 'int) (setq *std:max-keywordlen* 65));;; formats message with options and defaults.;;; on keyword list append the default,;;; remove def from it or bracket it in the real position;;; think of supporting different formatting styles:;;; "msg kwd1/kwd2/... <def>: ";;; or "msg [kwd1/kwd2/...] <def>: "(defun std-%inp-format-msg (msg def kwd / x l) ; (setq zin (getvar; "dimzin")); (setvar "dimzin" 0) (setq msg (std-trim msg)); kwd -> list, remove def, kwd ->; "/kwd1/kwd2" (setqkwd (cond ((std-string-not-empty-p kwd) (setq x (std-string->strlist kwd " ")) (setq l (> (length x) 1)) (std-strlist->string (std-remove def x) "/") ) ((not kwd) "" ) ((listp kwd) (setq l (> (length kwd) 1)) (std-strlist->string (std-remove def kwd) "/") ) ) ); use abbrevated option list? (if (and(boundp '*expert*)(or (eq *expert* t) (> *expert* 1)) ) (while (and (stringp kwd) (> (strlen kwd) *std:max-keywordlen*) ) (setq x1 kwd(std-strlist->string (std-butlast (std-string->strlist kwd "/" ) ) "/") ) ) ) (if (= x 1) (setq kwd (strcat kwd "/...")) ); set abbrevation (if (= (std-firstchar msg) "\n") (setq msg (substr msg 2)) ) (if (= (std-lastchar msg) ":") (setq msg (std-str-1 msg)) ); (setvar "dimzin" zin); format the prompt (setq msg(if *new-input-style*; use [] (if def (if(std-string-not-empty-p kwd) (strcat "\n" msg "[" kwd "/<" (std-tostr def) ">]: ") (strcat "\n" msg " <" (std-tostr def) ">: ") ) (if(std-string-not-empty-p kwd) (strcat "\n" msg "[" kwd "]: ") (strcat "\n" msg ": ") ) ); traditional style (if def (if(std-string-not-empty-p kwd) (strcat "\n" msg (if l" ""/" ) kwd "/<" (std-tostr def) ">: " ) (strcat "\n" msg " <" (std-tostr def) ">: ") ) (if(std-string-not-empty-p kwd) (strcat "\n" msg (if l" ""/" ) kwd ": " ) (strcat "\n" msg ": ") ) )) ) msg);;; main user-input driver, returns input or default value.;;; to catch lisp functions we accept strings as well (initget 128);;; and check the string for valid lisp types returned.(defun std-%inp-return (inp def type-pred can-be-string) (setq *std:inp-loop* nil) (if (stringp inp) (if(member(std-firstchar inp)'("(" "'" "!" )); if lisp function, set a loop-again; flag. (if (setqinp (if(= (std-firstchar inp) "!") (eval (read (substr inp 2))) (eval (read inp)) ) ); check here for the correct return; value(if (apply type-pred (list inp) ) inp (progn (setq *std:inp-loop* 1) def )); no return value, loop again(progn (setq *std:inp-loop* 1) def) ); no lispfunction, so return the; string or loop again (if can-be-stringinp(progn (setq *std:inp-loop* 1) inp) ) ) (ifinp inp def ) ))(defun std-getint (flag kwd msg def / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter number")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)) (if def (setq flag (logand flag (~ 1))) ) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (setq flag (logior flag 128)); allow lisp input for temp.; functions; (if (and def (/= (type def) 'int)); (setq def nil)) (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (while *std:inp-loop* (initget flag kwd) (setq inp (getint msg)); use the getint function (std-%inp-return inp def 'std-integerp can-be-string) ));;; std-getreal user interface real number, but better use std-getdist(defun std-getreal (flag kwd msg def / inp zin can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter number")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)); (if (and def (/= (type def); 'real)) (setq def nil)) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (if def (setq flag (logand flag (~ 1))) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (while *std:inp-loop* (initget flag kwd) (setq inp (getreal msg)); the getreal function (std-%inp-return inp def 'numberp can-be-string) ));;; std-getpoint user interface point function(defun std-getpoint (flag kwd msg def bpt / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Select point")) ) (setq *std:inp-loop* 1) (if (not (std-pointp def)) (setq def nil) ) (setq msg (std-%inp-format-msg msg def kwd)); (if (and def (/= (type def); 'list)) (setq def nil)) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (if def (setq flag (logand flag (~ 1))) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (initget flag kwd) (setq inp (if bpt(getpoint bpt msg)(getpoint msg) ) ) (std-%inp-return inp def 'std-pointp can-be-string) ));;; (std-getcorner flag kwd msg def bpt)(defun std-getcorner (flag kwd msg def bpt / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Select second corner")) ) (setq *std:inp-loop* 1); (if (not (std-pointp def)) (setq; def nil)) (setq msg (std-%inp-format-msg msg def kwd)) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (if def (setq flag (logand flag (~ 1))) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (initget flag kwd) (setq inp (if bpt(getcorner bpt msg)(getcorner msg) ) ) (std-%inp-return inp def 'std-pointp can-be-string) ));;; std-getangle user interface angle function;;; accepts and returns radians, but shows degrees(defun std-getangle (flag kwd msg def bpt / def1 inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter angle")) ) (setq *std:inp-loop* 1) (std-var-push '(("DIMZIN" . 8 ) ) ) (if def (if(numberp def) (setq def1 (angtos (std-rtd def)); added v0.4002 flag (logand flag (~ 1)) ) (setq def1 nil) ) ) (setq msg (std-%inp-format-msg msg def1 kwd)) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (std-var-pop) (graphscr) (while *std:inp-loop* (initget flag kwd) (setq inp (if bpt(getangle bpt msg)(getangle msg) ) ) (std-%inp-return inp def 'numberp can-be-string) ));;; accepts and returns degrees(defun std-getangle-deg(flag kwd msg def bpt / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter angle")) ) (setq *std:inp-loop* 1) (if def (if(/= (type def) 'real) (setq def nil) (setq flag (logand flag (~ 1))); remove flag 1 ) ) (setq msg (std-%inp-format-msg msg def kwd)) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (initget flag kwd) (setq inp (if bpt(getangle bpt msg)(getangle msg) ) ) (if(= (type inp) 'real); getangle returns radians (setq inp (std-rtd inp)) ) (std-%inp-return inp def 'numberp can-be-string) ));;; std-getdist user interface distance function;;; bpt is base point (nil for none).(defun std-getdist (flag kwd msg def bpt / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter distance")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)) (if (anddef(/= (type def) 'real) ) (setq def nil) ) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (if def (setq flag (logand flag (~ 1))) ) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (initget flag kwd) (setq inp (if bpt(getdist bpt msg)(getdist msg) ) ) (std-%inp-return inp def 'numberp can-be-string) ));;; scalefactor with option reference(defun std-getscale (flag kwd msg def bpt / inp ref) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter scalefactor")) ) (setq *std:inp-loop* 1) (setq ref (std-msg "Reference")) (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (if (not (wcmatch kwd (strcat "* " ref " *"))) (setq kwd (strcat kwd " " ref)) ) (graphscr) (if (= (setq inp (std-getdist flag kwd msg def bpt)) ref ) (progn; remove ref from kwd (* (/ 1.0 (std-getdist 7 "" (std-msg "old length") nil nil)) (std-getdist 7 "" (std-msg "new length") nil nil) ) ) inp ));;; std-inp-getkword;;; def, if any, must match one of the kwd strings;;; flag (1 for no null, 0 for none) and kwd key word ("" for none);;; are same as for initget.;;; msg is the prompt string, to which a default string is added as;;; <def> (nil or "" for none), and a : is added.(defun std-inp-getkword(flag kwd msg def / inp can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter Option ")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)) (if (anddef(/= (type def) 'str) ) (setq def nil) ) (setqcan-be-string (or (logand flag 128) (std-string-not-empty-p kwd) ) ) (if def (setq flag (logand flag (~ 1))) ); remove flag 1 (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (while *std:inp-loop* (initget flag kwd) (setq inp (getkword msg)); the getkword function (std-%inp-return inp def 'stringp can-be-string) ));;; (std-getstring flag msg def spflag);;; if flag && 1: no null "" input allowed, 0 for none,;;; flag is ignored if def present.;;; msg is the prompt string, to which a default string is added as;;; <def> (nil or "" for none), and a : is added.;;; if spflag t, spaces are allowed in string.;;; see also (std-edit-text s)(defun std-getstring (flag msg def spflag / inp) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter string")) ) (setq msg (std-%inp-format-msg msg def nil)) (if def (setq flag (logand flag (~ 1))) ); remove flag 1 (if (std-string-not-empty-p def) (setq inp (getstring msg spflag); ignore no null flag inp (if (or (not inp) (= inp "") )definp ) ); return default; empty def: (progn (if (= (logand 1 flag) 1); bit 1 set?(while (= "" (setq inp (getstring msg spflag))) ; no "" (prompt (std-msg "\ninvalid string")))(setq inp (getstring msg spflag)) ; else get input, "" ok ) ) ) inp);;; gui one line textedit: edits textstring in ddedit dialog(defun std-inp-edit-string (msg def / l) (if (not def) (setq def "") ) (if (std-string-not-empty-p msg) (prompt (std-%inp-format-msg msg def nil)) ) (if (entmake (list '(0 . "TEXT") (cons 1 def) '(40 . 1.0) (cons 10 (cadr (std-zoom-pts) ) ); out of; sight ) ) (progn (setq l (entlast)) (command "_DDEDIT" (list l (getvar "LASTPOINT")) "") (setq def (cdr (assoc 1 (entget l)))) ; fixed (entdel l) ) (std-error (std-msg "(entmake) temp text")) ) def);;; std-inp-getname user interface string for valid table names;;; enter a "." for an empty string.(defun std-inp-getname (flag msg def / inp errstr) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Enter name")) ) (setq msg (std-%inp-format-msg msg def nil)) (setq errstr (std-msg " invalid name")) (if def (setq flag (logand flag (~ 1))) ); remove flag 1 (if (anddef(/= def "")(not (std-%valid-name def)) ) (progn (princ " invalid chars in default") (setq def "") ) ) (if (anddef(/= def "") ) (progn (if (= "." (setq inp (getstring msg)))(setq inp "") ) (while (not (std-%valid-name inp))(prompt errstr)(setq inp (getstring msg)) ) (setq inp(if (= inp "") def inp) ) ) (progn (if (= flag 1)(while (or (= "" (setq inp (getstring msg))) (not (std-%valid-name inp)) ) (prompt errstr))(while (not (std-%valid-name (setq inp (getstring msg)))) (prompt errstr)) ) ) ) (if inp (strcase inp) ));;; (std-inp-getvector) return a vector;;; with bpt enter the 2.point (here the bpt is the default vector);;; without bpt enter 2 points or the 1.point is the vector(defun std-inp-getvector (flag kwd msg def bpt / inp) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Basepoint or displacement")) ); def only with no bpt (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (if bpt (setq inp (std-getpointflagkwdmsg(setq def nil)bpt ) ) (if(and (setqbpt (std-getpoint (if defflag(logior flag 1) ) kwd msg def nil ) ) (listp bpt) (/= bpt def)) (setq inp(std-getpoint flag kwd (std-msg "Second point of displacement") nil bpt) ) ) ) (if (and(stringp inp)(= (std-firstchar inp) "(") ); ) (setq inp (eval inp)) ) (cond (inp (mapcar (function -) inp bpt ) ) (bpt bpt) (t def ) ));;; adds no null and key words to "entsel"(defun std-inp-entsel (flag kwd msg def / inp ss can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Pick object")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)) (if def (setq flag (logand flag (~ 1))) ) (setq can-be-string (logand flag 128)) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (setq inp (cond((std-picksetp *std:ss-picked*) (princ msg) (setq ss *std:ss-picked* *std:ss-picked* nil ) (std-princ (list " " (sslength ss) " " (std-msg "found") ". " ) ) (if (= 1 (sslength ss)) (list (ssname ss 0) '(0 0 0)) ))((and (logand 1 (getvar "PICKFIRST")) (setq ss (ssget "_I")) (= 1 (sslength ss)) ) (princ (strcat msg " 1 " (std-msg "found") ". ")) (list (ssname ss 0) '(0 0 0)))(t (initget flag kwd) (entsel msg)) ) ) (std-%inp-return inp def 'std-%pick-list-p can-be-string) ))(defun std-%pick-list-p(x) (and (listp x) (std-enamep (car x)) ));;; std-inp-nentsel - attrib's and dimtext's(defun std-inp-nentsel (flag kwd msg def / inp ss can-be-string) (if (std-string-not-empty-p msg) nil (setq msg (std-msg "Pick object")) ) (setq *std:inp-loop* 1) (setq msg (std-%inp-format-msg msg def kwd)) (if def (setq flag (logand flag (~ 1))) ) (setq can-be-string (logand flag 128)) (setq flag (logior flag 128)); allow lisp input (if (listp kwd) (setq kwd (std-strlist->string kwd " ")) ) (graphscr) (while *std:inp-loop* (setq inp (cond(*std:ss-picked* (princ msg) (setq ss *std:ss-picked* *std:ss-picked* nil ) (std-princ (list " " (sslength ss) " " (std-msg "found") ". " ) ) (if (= 1 (sslength ss)) (list (ssname ss 0) '(0 0 0)) ))((and (logand 1 (getvar "PICKFIRST")) (setq ss (ssget "_I")) (= 1 (sslength ss)) ) (princ (strcat msg " 1 " (std-msg "found") ". ")) (list (ssname ss 0) '(0 0 0)))(t (initget flag kwd) (nentsel msg)) ) ) (std-%inp-return inp def 'std-%pick-list-p can-be-string) ));;; hmm, this is not quite correct code yet.;;; returns t or nil(defun std-inp-yesno (msg def / inp kwds yes no) (setqyes (std-msg "Yes")no (std-msg "No")kwds (list yes no) ) (setq def(cond ((member def (list nil no (std-firstchar no) "_No" "_N")) no ) (def yes) (t no )) ) (while (not (member (setq inp (std-inp-getkword 0 kwds msg def)) kwds ) ) ) (cond ((= inp yes) t ) (t nil ) ))(defun std-yesno (msg def) (setqdef (if(memberdef(list nil "_N" "_No" (std-msg "No") (std-firstchar (std-msg "No")))) nil t ) ) (cond ((not (std-acad-connection-p)) def ); to be fixed! ((std-dclactive-p) (std-dcl-yesno msg def) ) ((std-scriptactive-p) def ) (t (std-inp-yesno msg def) ) ))(defun std-dcl-yesno (msg def / dcldef dcl id result msgs i) (setq msgs (std-firstn 10 (std-%line-split msg 40))) (setqdcldef (list "yesno_row : column {" " : row {" " fixed_width = true;" " alignment = centered;" (strcat " : ok_button { label = \" " (std-msg "Yes") " \";}" ) " : spacer { width = 2; }" (strcat " : cancel_button { label = \" " (std-msg "No") " \";}}}" ) "YESNO : dialog {" (if (not def) "initial_focus = \"cancel\";" "" ) "label=\"Please answer\";" "width = 50;" ) ) (setq i 1) (foreach s msgs (setq dcldef (append dcldef (list (strcat ": text {key = \"yesno_msg" (itoa i) "\";" " label = " (std-prin1-to-string s) ";}" ) ) ) ) i (1+ i) ) (setqdcldef (append dcldef '("spacer_1;" "yesno_row;}") ) ); this temp filename gets deleted on; (std-var-restore) (setqdcl (std-%file-write-lines (std-filename-mktemp "YESNO.DCL") dcldef ) ); fcad! (or (and (setq id (load_dialog dcl)) (new_dialog "YESNO" id) ) (std-error "std-dcl-yesno aborted") ) (setq i 1) (foreach s msgs (set_tile (strcat "yesno_msg" (itoa i)) (std-strcenter s 40) ) ) (setq result (= 1 (start_dialog))) (unload_dialog id) result);;; kdwlst either string list or (initget) string "opt1 opt2 ..."(defun std-getkword (flag kwd def) (std-inp-getkword flag kwd "" def));;; replaces (getpoint);;; (std-get1point msg) without base point (1 argument);;; (std-get2point msg bpt) with base point (2 arguments)(defun std-get1point (msg) (std-getpoint 0 "" msg nil nil))(defun std-get2point (bpt msg) (std-getpoint 0 "" msg nil bpt));;; replaces (getdist);;; (std-get1dist msg) without base point (1 argument);;; (std-get2dist msg bpt) with base point (2 arguments)(defun std-get1dist (msg) (std-getdist 0 "" msg nil nil))(defun std-get2dist (bpt msg) (std-getdist 0 "" msg nil bpt));;; replaces (entsel)(defun std-entsel (msg) (std-inp-entsel 0 "" msg nil));;; replaces (nentsel)(defun std-nentsel (msg) (std-inp-nentsel 0 "" msg nil))(defun std-%valid-name (name) (not (wcmatch name "*[] `#`@`.`?`*`~`[`,`'!%^&()+={}|`\\:;\"<>/]*" ) ))(defun std-%valid-char (ch) (not (wcmatch ch "[] `#`@`.`?`*`~`[`,`'!%^&()+={}|`\\:;\"<>/]") ));;; see stdent:;;; (setq *entity-type-breakable* '("line" "polyline" "arc" "circle" "trace";;; "lwpolyline"));;; (setq *entity-type-polyline* '("lwpolyline" "polyline"));;; (setq *entity-type-linear* '("line" "arc" "polyline" "lwpolyline"));;; (setq *entity-type-text* '("text" "mtext"));;; (setq *entity-type-textalike* '("text" "mtext" "attrib" "attdef";;; "dimension"))(setq *ssfilter-insert* '((0 . "INSERT")))(setq *ssfilter-poly* '((0 . "POLYLINE,LWPOLYLINE")))(setq *ssfilter-text* '((0 . "TEXT,MTEXT,ATTDEF")));;; (setq *ssfilter-linear* (list (cons 0 (std-strlist->csstring;;; *entity-type-linear*))))(setq *ssfilter-textalike* (list (cons 0 (std-strlist->csstring *entity-type-textalike* ) ) ))(defun std-ssget (msg lst) (std-inp-ssget msg lst nil));;; ssget with defaults, like '(ssx), msg-prompt and filterlist;;; def is usually a secondary filter function, like '(ssx) or '(filter);;; or simplier '(ssget "x") for all, ...;;; ex:;;; (std-inp-ssget "sel" *ssfilter-insert* '(ssget "x" '((0 . "insert"))))(defun std-inp-ssget (msg lst def / ss) (if (stringp msg) (prompt msg) ) (cond (*std:ss-picked* (setq ss *std:ss-picked* *std:ss-picked* nil ) (std-princ(list " " (sslength ss) " " (std-msg "found") ". ") ); check for locked entities! (cond (ai_ssget (ai_ssget ss)) (tss ) ) ) ((and (logand 1 (getvar "PICKFIRST")) (setq ss (ssget "_I")) ) (std-princ (list " " (sslength ss) " " (std-msg "found") ". ") ) (cond (ai_ssget (ai_ssget ss)) (tss ) ) ) (t (if (equal def '(ssx)) (std-princ (list"\n"(std-msg "Select Objects")"/"(std-msg "SSX with ENTER")": " ) ) ) (if (setq ss (if lst (ssget lst) (ssget) ) ) (setq ss(cond (ai_ssget (ai_ssget ss)) (t ss )) ) (if def (setq ss (cond (ai_ssget (ai_ssget (eval def))) (t (eval def) ) ) ) ) ) (if (and ss *std:max-sslen* (> (sslength ss) *std:max-sslen*) ) (setvar "HIGHLIGHT" 0) ) ss ) ))(if (not ai_ssget) (load "AI_UTILS"));;; ------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdinput-symbols*))(setq *stdinput-symbols* nil);;; module dependencies:(std-%simple-provide "STDINPUT");;; first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.(std-%simple-require "STDSTR")(std-%simple-require "STDMATH")(std-%simple-require "STDLISP");;; (std-%simple-require "stdent");;; (std-%simple-require "stdaci");;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdent.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:08 rurban>;;; copyright (c) 1995,98,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; entity functions for the stdlib;;; some autocad entity dependent code:;;; query/change entities, useful abstractions for properties;;; selection sets, subentities (attrib, vertex);;; status:;;; entity independent code (points, segs) moved to stdpoint.lsp;;; std-entmake-xxx moved to seperate entmake.lsp;;; #+ small uses no entget cache, no std-entmake-xxx, no std-dimstr;;; a2000 allows safearrays: segments or pointlists may be coded as;;; destructive modifyable safearray's (much faster). this will affect;;; the abstract point accessors in stdlist then as well.;;; we should better provide a seperate stdpoint module, for points,;;; segments and pointlist data structures and the geometric stuff.;;; (geometry and segments from stdent; point stuff of stdlist);;; $log: stdent.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-10-05 18:11:49 rurban;;; fixed std-ssval, this never worked so far (!);;; thanks david kozina;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; 2000-06-22 10:36:34 rurban;;; fixed std-bylayer, std-bylayer for versions without getcname (<r13?);;; fixed std-getpts for lwpolyline, z != 0;;; 2000-06-19 11:06:16 rurban;;; added std-pline-segs (from stdpoint);;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-06-18 22:55 rurban;;; fixed std-getpts for pface;;; added std-getpts, std-get-getpts-vertexmask,;;; std-set-getpts-vertexmask from stdpoint;;;;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdent-symbols* '(std-getval std-entity std-init-entget std-entget std-entdel std-entmod std-ent-lastsub-p std-ent-sub-p std-main-entity std-subents std-entnext-main std-nentsel-parent std-gettype std-getdxf1 std-getname std-getflag std-getlay std-gethandle std-getpt std-getendpt std-getcolor std-getcolor-string std-getltype std-arc-pt std-arc-endpt std-bylayer std-byblock std-getexttype std-gettextval std-dimstr std-getpts std-get-getpts-vertexmask std-set-getpts-vertexmask std-pline-segs std-entchg std-chglay std-puttextval std-fix-lwpoly std-flagsetp std-entity-type-p std-entity-exttype-p std-hatch-p std-entity-subtype-p std-nentsel-block-p std-sslist std-ssmap std-ssval std-attele std-attchg ) ) ));;; some entity type constants:;;; they are not constant, because you shoudl be able to add custom;;; objects dynamically.(setq *entity-type-breakable* '("LINE" "POLYLINE" "ARC""CIRCLE" "TRACE" "LWPOLYLINE" "SPLINE""ELLIPSE"))(setq *entity-type-polyline* '("LWPOLYLINE" "POLYLINE"));;; forgot what this was for: applyable to area, perimeter or;;; divide/measure?;;; (setq *entity-type-linear* '("line" "arc" "polyline" "lwpolyline";;; "spline" "ellipse"))(setq *entity-type-text* '("TEXT" "MTEXT"))(setq *entity-type-textalike* '("TEXT""MTEXT""ATTRIB" "ATTDEF" "DIMENSION"));;; value of group in assoc list of element;;; which is either a plain dotted pair list, entsel-,;;; entget-list or ename;;; cache the entget lookup for faster comparison.(defun std-getval (grp ele) (cond ((and (listp ele) (/= (type (car ele)) 'ename) ); entsel (cdr (assoc grp ele)); already a entget-list ) ((eq (std-entity ele) (car *entget-cache*)) ; cache lookup (cdr (assoc grp (cdr *entget-cache*))) ) (t (cdr (assoc grp (std-entget ele))) ) ));;; std-entity returns the entity name of an entget, entsel;;; or ename argument. this is quite fast, at least faster than;;; std-entget.(defun std-entity (ele) (cond ((= (type ele) 'ename) ele ) ((not ele) nil ) ((not (listp ele)) nil ) ((= (type (car ele)) 'ename) (car ele) ); entsel (t (cdr (assoc -1 ele)) ); dotted pair list ))(setq *entget-cache* '(nil));;; initialize the cache:;;; (ename . entget-list);;; clear entget-cache;;; this is needed in special usercode, when you change any entity property;;; without any stdlib function, e.g. by not using std-entmod.;;; you ere not advised to do so, but if so you have to call;;; (std-init-entget);;; otherwise you will get old results, not reflecting your changes.;;; (proposed and insisted by serge pashkov)(defun std-init-entget () (setq *entget-cache* nil));;; with standalone there's no acad connection,;;; no entities to work with;;; fast (entget (std-entity ele));;; use this, if you're not sure, if ele is not already an entget list;;; it is cached, because entget is slow.;;; thanks to vladimir nesterovsky, who mentioned that entget is slow.(defun std-entget (ele) (cond ((eq ele (car *entget-cache*)) (cdr *entget-cache*) ) ((= (type ele) 'ename) (setq *entget-cache* (cons ele (entget ele))) (cdr *entget-cache*) ) ((not (listp ele)) nil ) ((= (type (car ele)) 'ename); entsel (setq *entget-cache* (cons ele (entget (car ele)))) (cdr *entget-cache*) ) (t ele ) ));;; already entget list;;; delete entity with cleaning the cache;;; by serge pashkov(defun std-entdel (ele) (if (setq ele (std-entity ele)) (progn (if (eq ele (car *entget-cache*))(setq *entget-cache* nil) ) (entdel ele) ) ));;; modify entity with updating the cache, fixed for invalid entmod's;;; by serge pashkov(defun std-entmod (elist / ele) (if (setq ele (std-entity elist)) (progn (if (eq ele (car *entget-cache*))(setq *entget-cache* nil) ) (entmod elist) ) ));;; old:;;; (defun std-entmod (elist / rslt);;; (if (setq rslt (entmod elist));;; (progn;;; (setq *entget-cache* (cons (cdr (assoc -1 elist)) rslt));;; rslt)));;; the rest doesn't bother us too much:;;; only tbl*, get*, ent* and ss* funcs are omitted;;; last element of a complex entity?(defun std-ent-lastsub-p (ele) (std-entity-type-p ele '("SEQEND" "ENDBLK")));;; sub-element of a complex entity?(defun std-ent-sub-p (ele) (std-entity-type-p ele '("VERTEX" "ATTRIB" "ATTDEF" ) ));;; main entity of sub or identity.;;; returns ename of the main entity of any entity or subentity;;; ele may be a (entget) list, a (entsel) list or of type 'ename(defun std-main-entity (ele) (setq ele (std-entity ele)) (while (std-ent-sub-p ele); fixed (setq ele (entnext ele)) ) (if (std-ent-lastsub-p ele) (std-getval -2 ele) ele ));;; return list of all sub entity ename's of a complex main-entity.;;; (i.e. polyline vertices or block attributes);;; ele may be a (entget) list, a (entsel) list or of type 'ename;;; ex: (mapcar 'std-getname (std-subents (entsel "blockattr's: ")));;; other definition in stdpoint(defun std-subents (ele / lst) (setqele (std-entity ele)lst nil ) (if (> (std-getval 66 ele) 0) (progn (while (std-ent-sub-p (setq ele (entnext ele)))(setq lst (cons ele lst)) ) (reverse lst) ) ));;; next main entity, fixed by serge pashkov(defun std-entnext-main(ele) (if (std-ent-lastsub-p (setq ele (std-entity ele))) (entnext ele) (progn (setq ele (entnext ele)) (while (std-ent-sub-p ele)(setq ele (entnext ele)) ) (if (std-ent-lastsub-p ele)(entnext ele)ele ) ) ));;; returns ename of the parent block of an with (nentsel) picked element(defun std-nentsel-parent (ele) (if (std-nentsel-block-p ele) (car (nth 3 ele)) (std-entity ele) ));;; -------------------------------------------------------------------73;;; getting entity properties:;;; (std-gettype ele) - group 0;;; (std-getexttype ele) - extended type info;;; (std-getdxf1 ele) - group 1;;; (std-getname ele) - group 2;;; (std-getlayele) - group 8;;; (std-gethandle ele)- group 5;;; (std-getcolor ele)- group 62 as number;;; (std-getltype ele)- group 6 as string;;; (std-getflag ele) - group 70;;; (std-getptele) - group 10 or poly/arc startpoint;;; (std-getendpt ele)- group 11 or poly/arc endpoint;;; (std-arc-ptele) - arc startpoint;;; (std-arc-endpt ele)- arc endpoint;;; (std-gettextval ele) - visible textvalue of text,mtext,;;; dimension,attdef,attrib;;; (std-dimstr ele)- calculated dimension textvalue;;; (std-getptsele)- pointlist from entity(defun std-gettype (ele) (std-getval 0 ele))(defun std-getdxf1 (ele) (std-getval 1 ele))(defun std-getname (ele) (std-getval 2 ele))(defun std-getflag (ele) (std-getval 70 ele))(defun std-getlay (ele) (std-getval 8 ele))(defun std-gethandle (ele) (std-getval 5 ele));;; on polylines and arcs the startpoint(defun std-getpt (ele) (cond ((std-entity-type-p ele *entity-type-polyline*) (car (std-getpts ele)) ) ((std-entity-type-p ele "ARC") (std-arc-pt ele) ) (t (std-getval 10 ele) ) ));;; on polylines and arcs the endpoint(defun std-getendpt (ele) (cond; ((std-entity-type-p ele "vertex"); ;of a segment; (std-require 'poly); (std-nextpolypt ele)) ((std-entity-type-p ele *entity-type-polyline*) (last (std-getpts ele)) ) ((std-entity-type-p ele "ARC") (std-arc-endpt ele) ) (t (std-getval 11 ele) ) ))(defun std-getcolor (ele) (std-getval 62 ele))(defun std-getcolor-string (ele) (std-%simple-require "STDTBL") (std-%color-num->string (cond ((std-getcolor ele)) (t 256 ) ) ))(defun std-getltype (ele / s) (if (stringp (setq s (std-getval 6 ele))) s (std-bylayer) ))(defun std-arc-pt (ele) (trans (polar(std-getval 10 ele)(std-getval 50 ele)(std-getval 40 ele) ) (std-entity ele) 0 ))(defun std-arc-endpt (ele) (trans (polar(std-getval 10 ele)(std-getval 51 ele)(std-getval 40 ele) ) (std-entity ele) 0 ));;; returns localized string for "bylayer".;;; (when was getcname introduced? r13?) fixed for earlier versions(defun std-bylayer () (if (and(boundp 'getcname)(getcname "_BYLAYER") ) (getcname "_BYLAYER") (cond ((std-module-defined-p "STDLOCAL") (std-%translate-string "BYLAYER") ) (t "BYLAYER" ) ) ));;; returns localized string for "byblock", fixed.(defun std-byblock () (if (and(boundp 'getcname)(getcname "_BYBLOCK") ) (getcname "_BYBLOCK") (cond ((std-module-defined-p "STDLOCAL") (std-%translate-string "BYBLOCK") ) (t "BYBLOCK" ) ) ));;; extended type string for polylines, special blocks;;; adds new types:;;; pface, mesh, 3dpoly, spline;;; solmesh, solwire, minsert, xref, hatch(defun std-getexttype (ele / typ tbl) (setq ele (std-entity ele)) (cond ((=(setq typ (std-gettype ele))"POLYLINE" ) (cond ((std-flagsetp 64 ele)"PFACE" ) ((std-flagsetp 32 ele)"MESH" ) ((std-flagsetp 16 ele)"MESH" ) ((std-flagsetp 8 ele)"3DPOLY" ) ((std-flagsetp 4 ele)"SPLINE" ) (ttyp ) ) ) ((/= typ "INSERT") typ ); ((std-solmesh-p ele) "solmesh");; old ame mesh; ((std-solwire-p ele) "solwire");; old ame wireframe (t (setq tbl (tblsearch "BLOCK" (std-getval 2 ele))) (cond ((std-hatch-p ele)"HATCH" ) ((or (> (std-getval 70 ele) 1) (> (std-getval 71 ele) 1))"MINSERT" ) ((std-flagsetp 4 tbl)"XREF" ) (ttyp ) ) ) ));;; returns the visible textvalue from any text element;;; from a dimension the calculated text if default text;;; from a mtext all textlines with formatting info(defun std-gettextval (ele / val x) (cond; dimension only ((and (= (type ele) 'ename) (std-entity-type-p ele "DIMENSION") ) (if (member (setq val (std-getval 1 ele)) '("" "<>") ) (std-dimstr ele); not yet implemented! val ) ) ((std-entity-type-p ele "MTEXT") (setq val "") (foreach x(std-entget ele) (if (member (car x) '(3 1)) (setq val (strcat val (cdr x))) ) ) val ) ((and (consp ele) (std-entity-type-p (car (cadddr ele)) "DIMENSION") ) (setq val (if (std-entity-type-p ele '("TEXT" "MTEXT")) (std-getval 1 ele) (std-dimstr (car (nth 3 ele))) ; calcs the text ) ); strip mtext formatting pre- and; suffices (if (and (std-entity-type-p ele "MTEXT") (= "\\" (substr val 1 1)) ) (setq val (substr val (1+ (std-strpos ";" val)))) ) val ); blocknames? naa! ((std-entity-type-p ele "ATTDEF") (std-getval 2 ele) ) (t (std-getval 1 ele) ) ));;; recalcs geometrically the dimension text, returns the string.;;; status: tolerance missing, not tested(defun std-dimstr (ele / s d p lfac p13 p14 p15 rnd) (if (std-entity-type-p ele "DIMENSION") (progn (setq s (std-getval 1 ele); on standalone ignore lfac and rnd lfac (cond ((not (std-getval 3 ele)) (getvar "DIMLFAC") ) ((= (std-getval 3 ele) "*UNNAMED") (getvar "DIMLFAC") ) (t (std-getval 144 (tblsearch "DIMSTYLE" (std-getval 3 ele) ) ) ); error: check also overriding; values in attached xdata! ) rnd (getvar "DIMRND") p13 (std-getval 13 ele) p14 (std-getval 14 ele) p15 (std-getval 15 ele) ) (cond; ignore _newtext dimension texts.; we want the geometric,not the; textual info; ((and (/= s "") (/= s "<>")); s; ); normal generated dimtxt((= (logior (std-getval 70 ele) 224) 224) ; rotated,hor,ver; rotation angle! (setq p (mapcar (function -) p14 p13 ) d (* (distance p13 p14) (cos (- (angle p13 p14) (std-getval 50 ele) ) ) lfac ) ) (rtos (std-%dimround (abs d) rnd)))((= (logior (std-getval 70 ele) 224) (+ 224 1)) ; aligned (setq d (* (distance p13 p14) lfac)) (rtos (std-%dimround (abs d) rnd)))((= (logior (std-getval 70 ele) 224) (+ 224 3)) ; diameter (setq d (* (distance (std-getpt ele) p15) lfac)) (strcat "%%c" (rtos (std-%dimround (abs d) rnd))))((= (logior (std-getval 70 ele) 224) (+ 224 2)) ; angle (setq d (- (angle p13 p14) (angle p13 p15))) (angtos (std-%dimround (abs d) rnd)))((= (logior (std-getval 70 ele) 224) (+ 224 5)) ; 3p angle (setq d (- (angle p15 p14) (angle p15 p13))) (angtos (std-%dimround (abs d) rnd)))((= (logior (std-getval 70 ele) 224) (+ 224 6)) ; ordinate (setq p (trans p13 0 1) d (if (std-flagsetp ele 64) ; type x (car p) (cadr p); type y ) ) (rtos (std-%dimround (abs (* lfac d)) rnd)))(t s) ) ) ));;; rounds real number as in dim with dimrnd;;; ex: (std-%dimround 1.43 0.5) => 1.0(defun std-%dimround (r rnd) (std-require 'stdmath) (if (zerop rnd) r (* (std-round (/ r rnd)) rnd) ));;; return only some assoc values in the list (for lwpolyline);;; (std-group-only 10 '((0 . x)(8 . y)(10 . p1)(10 . p2)(40 . 0)));;; => (p1 p2)(defun std-%group-only (_grp lst) (mapcar (function cdr) (std-remove-if-not; acomp will fail here! (function; )(lambda(_pair) (if (listp _grp) (member (car _pair) _grp) (= (car _pair) _grp) )) ) lst ) ));;; for vl provide optimized versions:;;; (std-getpts ele) => pts;;; return the vertex list of a polyline or of any other element.;;; always returns a list of wcs points. for arc's the two endpoints.;;; for polylines the current vertex filtermask is used.(defun std-getpts (_ele / pts _elist mask _z) (setq_elist (std-entget _ele)_ele (std-entity _ele) ); force type ename (cond; new: pface without facerecords,; v0.5002 ((and (std-entity-type-p _elist "POLYLINE") (std-flagsetp 64 _elist) ) (setq pts nil) (while (std-entity-type-p (setq _ele (entnext _ele)) "VERTEX" ); accept only 192 vertices (if (= 192 (std-getflag _ele)) (setq pts (cons (trans (std-getval 10 _ele) _ele 0) pts)) ) ) (reverse pts) ) ((std-entity-type-p _elist "POLYLINE"); (setq z (cond ((std-getval 38; _elist))((z-of (std-getval 10; _elist))))) (setq ptsnil mask(std-get-getpts-vertexmask) ); reject bits (while (std-entity-type-p (setq _ele (entnext _ele)) "VERTEX" ); accept only those subentities which; have all mask bits clear (if (zerop (logand mask (std-getflag _ele))) ; changed (setq pts (cons (trans (std-getval 10 _ele) _ele 0) pts)) ) ) (reverse pts) ); special case: you have to map it,; assoc finds only the first.; fix a lwpolyline bug in r14:; internally stored as 2d point,; (entget) returns fantasy; z-values. ((std-entity-type-p _elist "LWPOLYLINE") (setq _z (cond((std-getval 38 _elist))((z-of (std-getval 10 _elist))) ) ) (mapcar; the r14 z bug is fixed here; explicitly (function (lambda (_pt) (trans (list (car _pt) (cadr _pt) _z) _ele 0) ) ) (std-%group-only 10 _elist) ) ); insert here possible other types,; such as: ((std-entity-type-p _ele '("TEXT" "CIRCLE")) (list (std-getpt _elist)) ) ((std-entity-type-p _elist "ARC"); added v3.017 (list (std-arc-pt _elist) (std-arc-endpt _elist)) ); todo: hatch boundary? (t (apply (function append) (mapcar (function (lambda (_n / _p) (if (setq _p (std-getval _n _elist)) (list _p) ) ) ) '(10 11 12 13) ) ) ) ));;; returns group codes of the all subentities (vertices, attributes);;; of the complex element as list.;;; rejection of subentities is ruled out by flag *std:getpts-vertexmask*(defun std-%cplx-list (grp ele / lst mask) (if (= 1 (std-getval 66 ele)); logand? (progn (setq mask (std-get-getpts-vertexmask)) (setq ele(entnext (std-entity ele)) lstnil ) (while (and ele (not (std-ent-lastsub-p ele)) ); accept only those subentities which; have all mask bits clear(if (zerop (logand mask (std-getflag ele))) (setq lst (cons (std-getval grp ele) lst)))(setq ele (entnext ele)) ) (reverse lst) ) ));;; list of all subelement enames, by serge pashkov;;; moved to stdent;;; (defun std-subents (ele / *std:getpts-vertexmask*);;; we are interesting in all entities so temp. clear mask;;; (setq *std:getpts-vertexmask* 0);;; (std-%cplx-list -1 (std-main-entity ele)));;; get current vertex bitmask, by serge pashkov;;; functional interface to *std:getpts-vertexmask*(defun std-get-getpts-vertexmask () *std:getpts-vertexmask*);;; set current vertex bitmask filter for (std-getpts) and (std-subents);;; bitmask 16 would reject all spline frame points,;;; bitmask 9 reject every computer-added vertices,;;; bitmask 0 rejects none.;;; ex:;;; (std-set-getpts-vertexmask '(1 8)) => 9;;; (std-set-getpts-vertexmask 16) => 16;;; (std-set-getpts-vertexmask '(1 aa)) => 0;;; (std-set-getpts-vertexmask nil) => 0;;; by serge pashkov(defun std-set-getpts-vertexmask (mask) (setq*std:getpts-vertexmask* (cond ((numberp mask) mask ) ((null mask) 0 ) ((std-number-list-p mask) (apply (function logior) mask ) ) (t 0 ) ) ));;; initialize vertex bitmask used for rejecting vertices.;;; ex: 0 - all vertices passed;;; 9 = 1+8 - reject spline-fit and curve-fit vertices;;; 16 - reject spline frame vertices;;; by serge pashkov(std-set-getpts-vertexmask 0);;; (std-pline-segs pline) => segs;;; creates a segment list for the polyline;;; as a list of (p1 p2 [bulge]). wcs return values.;;; a straight line has no bulge.(defun std-pline-segs (pline / pts segs) (setq pline (std-entget pline)) (setqsegs (mapcar (function std-make-seg) (setq pts (std-getpts pline)) (std-rotate-left pts) (if (std-entity-type-p pline "LWPOLYLINE") (std-%group-only 42 pline) (std-%cplx-list 42 pline) ) ) ) (if (std-flagsetp 1 pline); closed segs; fixed (std-butlast segs) ));;; open: without the last segment;;; -------------------------------------------------------------------73;;; entity modifiers:;;; (std-entchg ele types grp val);;; (std-chglayele lay);;; (std-puttextvalele val)- to dim, text, attrib;;; (std-fix-lwpolyele)- fixes z bug;;; change dxf group of entity to value if it is of this type.;;; types is a list of strings or if nil at takes all types.;;; returns 1 or 0 to be able to use it in increment functions.;;; nr-value maybe atoms or list, which must match then.;;; ex:;;; (foreach ele (std-sslist (ssget));;; (setq i (+ i (std-entchg ele '("line") 62 7))));;; (std-princ (list i " lines changed to color white"));;; or: (std-entchg ele nil (62 8) (7 "0")))))(defun std-entchg (ele types nr value / _elist new old) (if (and(setq _elist (entget (std-entity ele))) ; not deleted entityvalue; don't use std- functions for; performance reasons(or (not types) (member (cdr (assoc 0 _elist)) types)); fix arguments to lists(progn (if (atom nr) (setq nr(list nr) value(list value) ) ) (setqnew (mapcar (function cons) nr value )old (mapcar (function(lambda(n) (cons n (cdr (assoc n _elist)))) ) nr ) ) (not (equal old new)))(progn; this should be set at; initialization time, t as long as; this is not fixed, also affects; hatches. (if *r14-lwpoly-bug* (setq _elist (std-fix-lwpoly _elist)) ) (mapcar (function (lambda (n o); make subst else append (cons; doesn't work on lwpolyline!)(setq _elist (if (cdr o) (subst n o _elist ) (append _elist (list n) ) )); fixed ) ) new old ) (std-entmod _elist)) ) 1 0 ));;; previous definition:;;; (defun std-entchg (ele types nr value / _elist new old);;;;;; (if (and;;; (setq _elist (entget (std-entity ele))) ;not deleted entity;;; value;;; ;; don't use std- functions for performance reasons;;; (or (not types) (member (cdr (assoc 0 _elist)) types));;; ;; fix arguments to lists;;; (progn;;; (if (atom nr) (setq nr (list nr) value (list value)));;; (setq new (mapcar 'cons nr value);;; old (mapcar (function (lambda (n);;; (cons n (cdr (assoc n _elist))))) nr));;; (not (equal old new)));;; (progn;;; ;; this should be set at initialization time, t as long as;;; ;; this is not fixed, also affects hatches.;;; (if *r14-lwpoly-bug* (setq _elist (std-fix-lwpoly _elist)));;; (mapcar (function (lambda (n o);;; (setq _elist (subst n o _elist))));;; new old);;; (std-entmod _elist);;; );;; );;; 1;;; ; let it return 0;;; 0;;;;;; );;;;;; );;; changes the layer for the element(defun std-chglay (ele lay) (std-entchg ele nil '(8) (list lay)) lay);;; sets new text value for dim, text, attrib,...(defun std-puttextval (val ele) (cond ((std-entity-subtype-p ele "DIMENSION") (std-entchg (std-main-entity ele) nil 1 val) ) ((std-entity-type-p ele "ATTDEF") (std-entchg ele nil 2 val) ) (t (std-entchg ele nil 1 val) ) ));;; fixing a r14 bug, random z values for points in entget lists;;; => fixed elist of entity for lwpolyline and hatch(defun std-fix-lwpoly (ele / _z _e) (if (std-entity-type-p ele '("HATCH" "LWPOLYLINE")) (progn (setq _z (cond ((std-getval 38 ele)) (t 0.0 ) ) ) (mapcar(function (lambda (_e) (if(= 10 (car _e)) (cons 10 (std-new-z (cdr _e) _z)) ; fixed _e ) ))(std-entget ele) ) ) (std-entget ele); more or less unchanged ));;; -------------------------------------------------------------------73;;; predicates:;;; (std-enamepele); entity?;;; (std-picksetpss); pickset?;;; (std-flagsetpval ele); val in flag 70?;;; (std-entity-type-p ele type) ;;;; former std-istypep;;; (std-entity-exttype-p ele type) ;;;; former std-istypep-ext;;; (std-entity-subtype-p ele typlst) ;for (nentsel) objects;;; former std-issubtype;;; (std-hatch-p ele) ;;;; former std-ishatch;;; (std-nentsel-block-p pick);;;; see stdlisp;;; (defun std-enamep (ele);;; (eq (type ele) 'ename));;; (defun std-picksetp (ss);;; (eq (type ss) 'pickset));;; std-flagsetp - bitvalue val in flag of element set?;;; ex: (std-flagsetp 1 pline) => t if closed;;; ex: (std-flagsetp 16 vertex) => t if spline control point(defun std-flagsetp (val ele) (std-bitsetp val (std-getflag ele)));;; type argument must be uppercase!(defun std-entity-type-p (ele typlst) (cond ((listp typlst) (member (std-gettype ele) typlst) ) ((stringp typlst) (= (std-gettype ele) typlst) ) (t nil ) ));;; type argument must be uppercase!(defun std-entity-exttype-p (ele typlst) (cond ((listp typlst) (member (std-getexttype ele) typlst) ) ((stringp typlst) (= (std-getexttype ele) typlst) ) (t nil ) ));;; r14 hatch object or previous hatch block (associative or not)(defun std-hatch-p (ele / eed) (or (std-entity-type-p ele "HATCH"); r14: native object or (and ele; pre-r14 hatch insert (= "INSERT" (std-gettype ele)); with eed info (= "*" (substr (std-getval 2 ele) 1 1)) (setq eed (cdadr (assoc -3 (entget (std-entity ele) '("ACAD"))))) (= "HATCH" (cdr (assoc 1000 eed))) ) ));;; for (nentsel) objects(defun std-entity-subtype-p (ele typlst) (std-entity-type-p (std-nentsel-parent ele) typlst))(defun std-nentsel-block-p (ele) (and (listp ele) (= 4 (length ele)) (= (type (car (nth 3 ele))) 'ename) ));;; -------------------------------------------------------------------73;;; selection sets:;;; (std-sslistss); selset -> list of ents;;; (std-ssmapfunc ss); apply a function to each element;;; (std-ssvalss grp); common value in selset;;; selection set => ordered list of entities(defun std-sslist (ss / n lst) (if (eq 'pickset (type ss)) (repeat (setq n (fix (sslength ss))) ; fixed (setq lst (cons (ssname ss (setq n (1- n))) lst)) ) ));;; apply a function to each ent in ss, in reversed order;;; faster than with std-sslist, but not so easy to understand.;;; in the faq named: ssapply;;; ex: (std-ssmap 'entupd (ssget)) ; regenerate only some entities(defun std-ssmap (func ss / n) (if (eq 'pickset (type ss)) (if(> (sslength ss) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (repeat (setq n (fix (sslength ss))) ; fixed(apply func (list (ssname ss (setq n (1- n))))) ) ) ));;; std-ssval returns the common value of the group as string;;; or the special strings "varies" or "too much".;;; usually used in user prompts.(defun std-ssval (ss _grp / values) (std-default-type '*std:max-sslen* 600) (cond ((> (sslength ss) *std:max-sslen*) (std-msg "too much") ); only english msg? ((apply (function =) (setq values (mapcar (function; )(lambda(ele) (std-getval _grp ele)) ) (std-sslist ss) ) ) ) (if (<= 50 _grp 59) (angtos (car values)); treat angles special (std-princ-to-string (car values)) ) ); use any string in standalone for; testing (t (std-msg "varies") ); only english msg? ));;; -------------------------------------------------------------------73;;; attributes:;;;;;; (std-atteleblock name); attribute list;;; (std-attchgblock name val); change attribute value;;; std-attele returns entget-list of attribute attname (string) in;;; ele or nil if not found;;; (std-attele (entsel) "date")(defun std-attele (block attname / res ele elist) (cond; block insertion ((= 1 (std-getval 66 block)) (setq ele (entnext (std-entity block))) (while (and ele (std-entity-type-p(setq elist (entget ele))"ATTRIB" ) ) (if (std-string-equal (std-getval 2 elist) attname) (setq res elist ele nil ) (setq ele (entnext ele)) ) ) ); table definition ((and (setq ele (std-getval -2 block)) (std-flagsetp 2 ele) ) (while (and ele (std-entity-type-p(setq elist (entget ele))"ATTDEF" ) ) (if (std-string-equal (std-getval 2 elist) attname) (setq res elist ele nil ) (setq ele (entnext ele)) ) ) ) ); return nil res);;; change the attribute value (group 1) of insert entity to new value.;;; takes also attrib entities.;;; fixed by raymond barlow. 10/27/99.;;; (std-attchg (entsel) "date" (std-today))(defun std-attchg (block name val / att) (if (std-entity-type-p block "ATTRIB") (setq att block) (setq att (std-attele block name)) ) (if att (std-entmod (subst(cons 1 val)(cons 1 (std-getval 1 att))att ) ) ));;; -------------------------------------------------------------------73;;; geometry: entity independent funcs moved to stdpoint;;; segments, bulges: completely moved to stdpoint (entity independent);;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdent-symbols*))(setq *stdent-symbols* nil);;; module dependencies:(std-%simple-provide "STDENT");;; first provide it, but before you may;;; call it, be sure to have all supporting;;; functions:;;; if all required stdlib modules are contained in one project,;;; we don't have to load it explicitly.;;; stdlib.fas already contains it!;;; (if (not *std:%project*) (progn(std-%simple-require "STDINIT")(std-%simple-require "STDLIST")(std-%simple-require "STDLISP")(std-%simple-require "STDSTR")(std-%simple-require "STDFILE")(std-%simple-require "STDMATH")(std-%simple-require "STDPOINT")(std-%simple-require "STDTIME");;; ?;;; (std-%simple-require "stdaci") ; almost all;;; ));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdtbl.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:56 rurban>;;; copyright (c) 1994,1998,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; table functions for the stdlib;;; status:;;; not tested by runtest at all, but in heavy production use since;;; 1992-1999;;; several fcad fixes, but not complete yet.;;;;;; $log: stdtbl.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-10-18 14:47:12 rurban;;; renamed std-%zoom-if-apply to std-zoom-if-apply;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-08-30 10:32:18 rurban;;; fixed std-zoom-if, std-zoom-extents for dclactive;;; added std-%zoom-if-apply;;; 2000-07-22 17:15:18 rurban;;; added layer arg as list to layer functions;;; some return the last, some the whole list;;; (thanks david for reminding me);;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-04-15 11:06:00 rurban;;; std-restore-ucs added arbitrary strings,;;; like "world" "prev" (pro: flexibility), but may cause errors in;;; std-error (contra: stability). fixed transparent bug;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;; 2000-04-07 15:00:07 rurban;;; removed entmake dependency;;; 2000-04-05 09:04:48 rurban;;; fixed std-zoom-if for ucs;;; 2000-03-14 22:09:57 rurban;;; fixed std-restore-ucs, fixed std-tbl-layer for "*";;; reversed output from std-tbl-props, std-tbl-names, std-tbl,;;; std-tbl-layer to reflect the normal db order.;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdtbl-symbols* '(std-tbl-p std-tbl-group std-tbl-names std-tbl-props std-tbl std-tbl-layer std-tbl-tmpname std-pix->units std-units->pix std-view-plan-p std-view-persp-p std-paperspace-p std-vport-next std-zoom-pts std-zoom-if std-zoom-extents std-tbl-rename std-not-worlducs-p std-layer-visible-p std-layer-on-p std-layer-frozen-p std-save-layer std-restore-layer std-save-ucs std-restore-ucs std-save-zoom std-restore-zoom std-save-view std-restore-view std-save-vports std-restore-vports std-save-undo std-restore-undo std-disable-undo std-enable-undo std-layer-lock std-layer-unlock std-layer-freeze-vp std-layer-thaw-vp std-layer-freeze std-layer-thaw std-layer-off std-layer-on std-layer-put-color std-layer-put-ltype std-layer-add std-layer-set std-layer-make std-zoom-if-apply ) ) ))(std-%simple-require "STDLISP")(std-defconstant '*tbl-groups*; tables and dxf groups '(("BLOCK" . 2 ) ("LAYER" . 8 ) ("STYLE" . 7 ) ("COLOR" . 62 ) ("LTYPE" . 6 ) ("DIMSTYLE" . 3 ) ("VPORT" . nil ) ("VIEW" . nil ) ("UCS" . nil ) ("APPID" . nil ) ))(std-defconstant '*tables*; names only (mapcar (function car) *tbl-groups* ));;; tbl must be uppercase!(defun std-tbl-p (tbl) (member tbl *tables*));;; nil - cannot pick(defun std-tbl-group (tbl) (cdr (assoc (strcase tbl) *tbl-groups*)));;; returns all table names;;; see also (std-tbl tbl "*" 0 0)(defun std-tbl-names (tbl) (std-tbl-props tbl 2));;; returns list of table properties of all table elements;;; treat color as virtual table to be able to use the same tbl-get;;; funcs(defun std-tbl-props (tbl grp / lst ele) (if (= tbl "COLOR"); todo: use *std:color-table* (if(= grp 2) (mapcar(function car)*std:color-table* ) ); (list "bylayer" "byblock" "red"; "yellow" "green"; "cyan" "blue" "magenta"; "white") (progn (setq ele (tblnext tbl t)) (while ele(setq lst (cons (std-getval grp ele) lst) ele (tblnext tbl)) ) (reverse lst) ) ));;; flags for std-tbl, common table groups(std-defconstant 'std:tbl-all 0)(std-defconstant 'std:tbl-extern 16);;; external dependent (xref)(std-defconstant 'std:tbl-bound 32);;; bound external xref(std-defconstant 'std:tbl-exist 64);;; referenced, not valid if >= r13;;; returns all table names which flags in <must> must be set,;;; and which flags in <ignore> may not be set,;;; using wcmatch with match on the name;;; e.g:;;; (std-tbl "layer" "*" std:tbl-all std:tbl-bound);;; => all not externally bound layer names;;; (std-tbl "layer" "*" (+ std:lay-frozen std:lay-exist);;; std:lay-extern);;; => all existing + frozen + off layer names;;; ignoring external(defun std-tbl (tbl match must ignore / name names ele) (setqmust (if (std-ver-r13-p) (std-bitdel std:tbl-exist must) must ) ) (if (= tbl "COLOR"); all (std-tbl-names tbl) (if(std-tbl-p tbl) (progn(foreach name (std-tbl-names tbl) (setq ele (tblsearch tbl name)) (if (and(std-flagsetp must ele)(or (= match "*") (wcmatch name match))(if (zerop ignore) t (not (std-flagsetp ignore ele))) ) (setq names (cons name names)) ))(reverse names) ) ) ));;; flags for std-tbl-layer(std-defconstant 'std:lay-thawed 0);;; 1.arg - must(std-defconstant 'std:lay-frozen 1);;; 1.arg - must(std-defconstant 'std:lay-locked 4);;; 1.arg - must(std-defconstant 'std:lay-exist 64);;; 1.arg - must(std-defconstant 'std:lay-extern 48);;; 2.arg - ignore(std-defconstant 'std:lay-on 1);;; 3.arg - on/off(std-defconstant 'std:lay-off -1);;; 3.arg - on/off(std-defconstant 'std:lay-on-or-off 0);;; 3.arg - on/off;;; returns all layer names which flags in <must> must be set,;;; and which flags in <ignore> may not be set,;;; using wcmatch with match on the name,;;; ison=0: ignore on/off;;;; 1: only turned on layers;;; -1: only turned off layers;;; e.g:;;; (std-tbl-layer "*" std:lay-thawed std:tbl-all std:lay-on-or-off);;; => all layer names;;; (std-tbl-layer "*" (+ std:lay-frozen std:lay-exist);;; std:lay-extern std:lay-off);;; => all existing + frozen + off layer names;;; ignoring external;;; (std-tbl-layer "*" std:lay-thawed 0 std:lay-on) all visible ones(defun std-tbl-layer (match must ignore ison / name names ele tbl) (setqtbl "LAYER"ele (tblnext tbl t); >=r13: ignore flag 64must (if (std-ver-r13-p) (std-bitdel std:tbl-exist must) must ) ) (while ele (setq name (std-getname ele)) (if(and (std-flagsetp must ele) (or (= match "*") (wcmatch name match) ); fixed (if (zerop ignore) t (not (std-flagsetp ignore ele)) ) (if (zerop ison); any t (if(minusp ison); only off (minusp (std-getcolor ele)) (> (std-getcolor ele) 0) ) )); and (setq names (cons name names)) ) (setq ele (tblnext tbl)) ) (reverse names));;; creates a new unique table name.;;; e.g. for new named blocks, views or such (error handling)(defun std-tbl-tmpname (tbl prefix / i) (if (not prefix) (setq prefix "$STD-") ) (if (tblsearch tbl prefix) (progn (setq i 0) (while (tblsearch tbl (strcat prefix (itoa i)))(setq i (1+ i)) ) (strcat prefix (itoa i)) ) prefix ));;; -------------------------------------------------------------------73;;; user input: (getting existing names);;; these will be removed from the stdlib!;;; ask for table name[s];;; status: not ready yet, missing is the extendability;;; and various checks;;; parameter flag:;;; data driven extensions via flag?;;; attributes: multiple, mustexist, allowspaces, noxref, onlyvisible,;;; allowpick, ...;;; (defun std-tbl-getname (tbl flag msg def / l);;; (setq tbl (strcase tbl));;; (cond;;; ((= tbl "color");;; (std-getstring 0 msg def nil)) ;numbers as well;;; ((std-tbl-p tbl);;; (std-inp-getname 1 msg def);;; );;; );;; );;;;;; prompt for single blockname;;; (defun std-tbl-getblockname (msg def);;; (std-tbl-getname "block" 0 msg def));;;;;; prompt for mult. blocknames;;; (defun std-tbl-getblocknames (msg def);;; (std-tbl-getname "block" 1 msg def));;;;;; prompt for mult. linetypes;;; (defun std-tbl-getltypename (msg def);;; (std-tbl-getname "ltype" 1 msg def));;;;;; prompt for mult. color names or numbers;;; (defun std-tbl-getcolorname (msg def);;; (std-tbl-getname "color" 1 msg def));;;;;; prompt for single color number;;; (defun std-tbl-getcolornum (msg def);;; (std-%color-string->num (std-tbl-getname "color" 0 msg def)));;; english color names: (upcase-string . number);;; will not be localized(std-defconstant '*std:color-table* '(("BYBLOCK" . 0 ) ("BYLAYER" . 256 ) ("RED" . 1 ) ("YELLOW" . 2 ) ("GREEN" . 3 ) ("CYAN" . 4 ) ("BLUE" . 5 ) ("MAGENTA" . 6 ) ("WHITE" . 7 ) ("GREY" . 8 ) ));;; converts full color string in number;;; no localization support yet.;;; color string must be in english so far,;;; no abbrevations allowed.(defun std-%color-string->num (s / n) (cond ((numberp s) s ) ((not (std-string-not-empty-p s)) nil ) ((cdr (assoc (strcase s) *std:color-table*))) ; fixed (t (atoi s) ) ));;; converts color number into english uppercase string;;; no localization support yet.(defun std-%color-num->string (n) (cond ((stringp n) n ) ((cdr (std-rassoc n *std:color-table*))) (t (itoa n) ) ));;; -------------------------------------------------------------------73;;; view calculations:;;; no workarounds possible;;; conversion pixel to drawing units, fcad 4.01 ok(defun std-pix->units (pix) (* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))));;; conversion drawing units to pixel, fcad 4.01 ok(defun std-units->pix (ze) (* ze (/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE"))));;; plan view mode, fcad has no viewmode(defun std-view-plan-p () (and (or (std-ver-fcad-p) (zerop (getvar "VIEWMODE")) ) (equal (getvar "VIEWDIR") '(0.0 0.0 1.0) 1e-3) ));;; perspective view mode(defun std-view-persp-p() (cond ((std-ver-fcad-p) nil ) (t (not (zerop (getvar "VIEWMODE"))) ) ));;; in paperspace?, fcad 4.01 ok(defun std-paperspace-p() (= (caar (vports)) 1));;; switch to next vport: like ctrl-v(defun std-vport-next (/ vp) (if (setq vp (cdr (vports))) (setvar "CVPORT" (caar vp)) ));;; returns actual zoom points, in wcs;;; vport extents, fcad 4.01 ok(defun std-zoom-pts (/ ctr h screen ratio size size_2) (setqctr (xy-of (std-trans10 (getvar "VIEWCTR"))) ; 2dh (getvar "VIEWSIZE"); realscreen (getvar "SCREENSIZE"); 2d: pixel x,yratio (/ (float (car screen)) (cadr screen))size (list (* h ratio) h)size_2 (mapcar (function /) size '(2.0 2.0) ) ) (list(mapcar (function -) ctr size_2)(mapcar (function +) ctr size_2) ));;; do zoom window if we don't already see everything;;; if the actual view is larger, if we see all sides, we won't zoom;;; minpt/maxpt in wcs. not dcl-transparent!;;; use std-zoom-extents instead(defun std-zoom-if (minpt maxpt) (std-zoom-if-apply minpt maxpt (function (lambda (p1 p2)(if (std-dclactive-p) (std-error "DCL active. cannot perform COMMAND.") (command "'_ZOOM" "_W" p1 p2))t; (if (zerop (getvar; "regenmode"))(command "_y")) ) ) ));;; expects a function with two args, suitable to;;; (command "_zoom" "_w" arg1 arg2);;; point arguments in wcs(defun std-zoom-if-apply (minpt maxpt func / zm z1 z2) (setqzm (std-zoom-pts)z1 (std-trans01 (car zm))z2 (std-trans01 (cadr zm)) ) (if (or(> (x-of z1) (x-of minpt))(> (y-of z1) (y-of minpt))(< (x-of z2) (x-of maxpt))(< (y-of z2) (y-of maxpt)) ) (apply func (list (std-xy-min (list z1 minpt)) (std-xy-max (list z2 maxpt)) ) ) ));;; do zoom extents if we don't already see everything;;; if the actual view is larger, if we see all sides, we won't zoom.;;; fixed for transparent dcl usage with vla.(defun std-zoom-extents(/ zm ei ea) (std-var-push '(("EXPERT" . 1 ) ) ) (if (or(> (x-of (car (setq zm (std-zoom-pts)))) (x-of (setq ei(getvar "EXTMIN") ) ))(> (y-of (car zm)) (y-of ei))(< (x-of (cadr zm)) (x-of (setq ea (getvar "EXTMAX"))))(< (y-of (cadr zm)) (y-of ea)) ) (progn (if (std-dclactive-p)(if (std-vla-p) (if (std-ver-r2000-p); r2000 improvement (vla-zoomextents (vlax-get-acad-object)) (vla-zoomextents; r14 quirks (vla-get-activeviewport(vla-get-activedocument (vlax-get-acad-object)) ) ) ) (std-error "DCL active. cannot perform COMMAND."))(command "'_ZOOM" "_E") ); (if (zerop (getvar; "regenmode"))(command "_y")) ) ) (std-var-pop));;; -------------------------------------------------------------------73;;; miscellaneous:;;; returns t on success or nil;;; to be able to print user prompts as below on failure or success.;;; (std-tbl-rename "layer" "wand" "wand-01")(defun std-tbl-rename (tbl old new) (if (tblsearch tbl old) (if(tblsearch tbl new); (std-verbose-print (list "\n" tbl "; " new " already exists")) nil (progn(command "_RENAME" tbl old new); fcad 4.01 ok; (std-verbose-print (list "\n" tbl "; " old " renamed to " new))t ) ); (std-verbose-print (list "\n" tbl "; " old " doe not exist")) ))(defun std-not-worlducs-p () (zerop (getvar "WORLDUCS")))(defun std-layer-visible-p (layname) (and (std-layer-on-p layname) (not (std-layer-frozen-p layname)) ));;; existing and on(defun std-layer-on-p (layname / elist) (and (setq elist (tblsearch "LAYER" layname)) (> (std-getcolor elist) 0) ))(defun std-layer-frozen-p (layname) (std-flagsetp std:lay-frozen (tblsearch "LAYER" layname)));;; 1;;; -------------------------------------------------------------------73;;; save/restore pairs;;; save layer state(defun std-save-layer (laynam) (tblsearch "LAYER" laynam));;; restore layer state(defun std-restore-layer (layer / layobj laynam changed) (if (std-ver-r14-p) (command) ); command buffer bug (setq laynam (std-getname layer)); fixed v0.4002 8/19/99:; std-save-layer may return nil (if (andlayer(not (tblsearch "LAYER" laynam)) ) (entmake layer); (std-entmake-layer layer) (progn (setq layobj (entget (tblobjname "LAYER" laynam))) (foreach grp '(7 62 70)(if (/= (cdr (assoc grp layobj)) (cdr (assoc grp layer))) (setqlayobj(subst (assoc grp layer) (assoc grp layobj) layobj)changedt )) ) (if changed(entupd (cdr (assoc -1 (entmod layobj)))) ) ) ));;; returns ucs list to store in *std:var-stack*;;; => actual ucs(defun std-save-ucs () (list(getvar "UCSORG")(getvar "UCSXDIR")(getvar "UCSYDIR") ));;; ucs: list of (ucsorg ucsxdir ucsydir) or a symbol table name(defun std-restore-ucs (ucs / u x y) (if (not (std-ver-fcad-p)); added v0.4006 (progn (if (std-ver-r14-p)(command) ); command buffer bug (while (std-dclactive-p)(done_dialog) ) (while (std-cmdactive-p)(command) ) ) ) (cond ((stringp ucs); todo: add transparent methods; instead of command ucs (if (tblsearch "UCS" ucs); v0.5001 added "world" (command "_UCS" "_Restore" ucs); allow (std-var-push '((:ucs .; "world"))) or "prev" or such (command "_UCS" ucs) ); this is some magic here: "$"; denotes a temp ucs to be deleted! (if (= (std-firstchar ucs) "$") (command "_UCS" "_Delete" ucs) ) ) ((not (std-view-persp-p)) (setq u (trans (car ucs) 0 1); fcad fix: t -> 1 x (mapcar (function +) u (trans (cadr ucs) 0 1 1) ) y (mapcar (function +) u (trans (caddr ucs) 0 1 1) ) ) (if (std-ver-fcad-p) (command "._UCS" "_3" u x y) (command "._UCS" "_3" "_NON" u "_NON" x "_NON" y) ) ) ));;; todo: transparent ucs methods;;; (std-ucs-make ...);;; (std-ucs-delete ...);;; (std-%ucs-restore "name"|3points);;; transparent helper for strings(defun std-%ucs-restore(ucs) (if (tblsearch "UCS" ucs) (command "_UCS" "_Restore" ucs) (command "_UCS" ucs) ));;; => actual zoom in wcs(defun std-save-zoom () (std-zoom-pts));;; zoom: list of two points in wcs(defun std-restore-zoom(zoom) (command "'_ZOOM" "_W" (std-trans01 (car zoom)) (std-trans01 (cadr zoom) ) ));;; => view name(defun std-save-view (/ name) (if (std-ver-r14-p) (command) ); command buffer bug (while (std-dclactive-p) (done_dialog) ) (setq name (std-tbl-tmpname "VIEW" "$VIEW")) ; unique temp. name (if (std-ver-fcad-p) (command "_QVIEW" "_Save" name) (command "_VIEW" "_Save" name) ); a2000 bugfix name);;; string of existing table name;;; we have to distinguish temporary system generated names;;; and user given names. the first have to be deleted, the latter not.;;; after (std-var-push '((:view . "myview"))) "myview" may not be;;; deleted but the view generated with (std-var-push '((:view))) should(defun std-restore-view(name) (if (std-ver-r14-p) (command) ); command buffer bug (while (std-dclactive-p) (done_dialog) ) (if (std-ver-fcad-p) (command "_QVIEW" "_Restore" name) (command "_VIEW" "_Restore" name) ); a2000 bugfix (if (= (std-firstchar name) "$") (if(std-ver-fcad-p) (command "_QVIEW" "_Delete" name) (command "_VIEW" "_Delete" name) ) ); a2000 bugfix);;; this is not the same as view, because users could change the;;; viewport entity in paperspace and fool the view info therefore.;;; this is needed esp. for paperspace plotting.;;; => vport-name(defun std-save-vports (/ name) (if (std-ver-r14-p) (command) ); command buffer bug (while (std-dclactive-p) (done_dialog) ); end dialogs (setq name (std-tbl-tmpname "VPORT" "$VPORT")) ; unique temp. name (if (std-ver-fcad-p) (command "_QVIEWPORT" "_Save" name) (command "_VPORTS" "_Save" name) ) name);;; string of existing table name(defun std-restore-vports (name) (if (std-ver-r14-p) (command) ); command buffer bug (std-break-command) (if (std-ver-fcad-p) (command "_QVIEWPORT" "_Restore" name) (command "_VPORTS" "_Restore" name) ) (if (= (std-firstchar name) "$") (if(std-ver-fcad-p) (command "_QVIEWPORT" "_Delete" name) (command "_VPORTS" "_Delete" name) ) ));;; this could be renamed to undoctl because it handles undo;;; according this var, hmm...;;; => undoctl bitcode;;; 0undo is turned off;;; 1undo is turned on;;; 2only one command can be undone;;; 4turns on the auto option;;; 8a group is currently active(defun std-save-undo () (getvar "UNDOCTL"));;; restore old state. it accepts a integer value, which is the;;; same as the undoctl setting.(defun std-restore-undo(old / crt) (if (std-ver-r14-p) (command) ); command buffer bug (setq crt (getvar "UNDOCTL")); fixed (if (zerop old); disable (if(zerop crt); fixed nil; already off or (command "._UNDO" "_Control" "_None") ) (progn; truthtable:; old crt new; 2 0 one; ~2 0 all (if (zerop crt)(if (std-bitsetp 2 old) (command "._UNDO" "_O") (command "._UNDO" "_All")) ); old crt new; 8 ~8 begin; ~8 8 end; 8 8 -; ~8 ~8 - (if (std-bitsetp 8 old); if old had a group(if (std-bitsetp 8 crt) nil (if (std-ver-fcad-p) (command "._UNDO" "_Group-B") (command "._UNDO" "_Begin") ))(if (std-bitsetp 8 crt) (if (std-ver-fcad-p) (command "._UNDO" "_Group-E") (command "._UNDO" "_End") )) ); old crt new; 2 ~2 one; ~2 2 all; 2 2 -; ~2 ~2 - (if (std-bitsetp 2 old); one(if (std-bitsetp 2 crt) nil (command "._UNDO" "_Control" "_O")); one | once: fcad(if (std-bitsetp 2 crt) (command "._UNDO" "_Control" "_All")) ); old crt new; 4 ~4 on; ~4 4 off; 4 4 -; ~4 ~4 - (if (std-bitsetp 4 old); auto on or off(if (std-bitsetp 4 crt) nil (command "._UNDO" "_Auto" "_ON"))(if (std-bitsetp 4 crt) (command "._UNDO" "_Auto" "_OFF")) ) ) ));;; set some useful predefined undo states:;;; not the same as in ai_utils.lsp: (ai_undo_off)(defun std-disable-undo() (if (zerop (getvar "UNDOCTL")) nil (command "._UNDO" "_Control" "_None") ));;; not the same as in ai_utils.lsp: (ai_undo_on);;; turn menu autogrouping off,;;; don't start a new group, as this is done by (ai_undo_push)(defun std-enable-undo (/ ctl) (setq ctl (getvar "UNDOCTL")) (if (std-bitsetp 8 ctl); end active group (if(std-ver-fcad-p) (command "._UNDO" "_Group-E") (command "._UNDO" "_End") ) ) (if (or(zerop ctl)(std-bitsetp 2 ctl) ); undo is disabled or one (command "._UNDO" "_Control" "_All") ) (if (and(std-bitsetp 4 ctl); undo is one(not (std-ver-fcad-p)) ) (command "._UNDO" "_Auto" "_OFF") ));;; i know, this is confusing.;;; -------------------------------------------------------------------73;;; layer methods, require stdent;;; written by ralph gimenez. minor changes by reini urban;;; (std-%layer-obj "0") =>;;; ((-1 . <entity name: 2de0798>);;; (0 . "layer");;; (5 . "3fb");;; (100 . "acdbsymboltablerecord");;; (100 . "acdblayertablerecord");;; (2 . "0");;; (70 . 0);;; (62 . 7);;; (6 . "continuous"))(defun std-%layer-obj (name / layer); (tblsearch "layer" (strcase name)) (if (setq layer (tblobjname "LAYER" name)) (entget layer) ))(defun std-%flag-add-bit (bit obj) (if (std-flagsetp bit obj) (progn (setq obj(subst (cons 70 (std-setbit bit (std-getflag obj))) (assoc 70 obj) obj) ) (entmod obj) (entupd (cdr (assoc -1 obj))) ) ) (cdr (assoc -1 obj)))(defun std-%flag-del-bit (bit obj) (if (std-flagsetp bit obj) (progn (setq obj(subst (cons 70 (std-bitdel bit (std-getflag obj))) (assoc 70 obj) obj) ) (entmod obj) (entupd (cdr (assoc -1 obj))) ) ) (cdr (assoc -1 obj)));;; -------------------------------------------------------------------73;;; 1 = layer is frozen, otherwise layer is thawed;;; 2 = layer is frozen by default in new viewports;;; 4 = layer is locked(defun std-layer-lock (name / layer) (if (listp name) (foreach x name (std-layer-lock x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-add-bit 4 layer) ) ))(defun std-layer-unlock(name / layer) (if (listp name) (foreach x name (std-layer-unlock x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-del-bit 4 layer) ) ))(defun std-layer-freeze-vp (name / layer) (if (listp name) (foreach x name (std-layer-freeze-vp x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-add-bit 2 layer) ) ))(defun std-layer-thaw-vp (name / layer) (if (listp name) (foreach x name (std-layer-thaw-vp x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-del-bit 2 layer) ) ))(defun std-layer-freeze(name / layer) (if (listp name) (foreach x name (std-layer-freeze x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-add-bit 1 layer) ) ))(defun std-layer-thaw (name / layer) (if (listp name) (foreach x name (std-layer-thaw x) ) (if(setq layer (std-%layer-obj name)) (std-%flag-del-bit 1 layer) ) ));;; 62color number if negative, layer is off(defun std-layer-off (name / layer) (if (listp name) (mapcar (function std-layer-off) name ) (if(setq layer (std-%layer-obj name)) (progn(if (not (minusp (std-getcolor layer))) (progn (setq layer(subst (cons 62 (- (std-getcolor layer))) (assoc 62 layer) layer) ) (entmod layer) (entupd (cdr (assoc -1 layer))) ))(cdr (assoc -1 layer)) ) ) ))(defun std-layer-on (name / layer) (if (listp name) (mapcar (function std-layer-on) name ) (if(setq layer (std-%layer-obj name)) (progn(if (minusp (std-getcolor layer)) (progn (setq layer(subst (cons 62 (- (std-getcolor layer))) (assoc 62 layer) layer) ) (entmod layer) (entupd (cdr (assoc -1 layer))) ))(cdr (assoc -1 layer)) ) ) ));;; changes the color of the layer.;;; current settings of the layer visibility is maintained.;;; however, you can force the layer off is you pass a negative number,;;; but you cannot force it on (to keep the off state);;; returns the ename of the layer. returns nil only when the color;;; argument is 0 or greater than 255 or is not a number(defun std-layer-put-color (name colorasinteger / layer) (if (listp name) (foreach x name (std-layer-put-color x colorasinteger) ) (if(or (not (numberp colorasinteger)) (not (<= 1 (abs colorasinteger) 255))); fix by david kozina (progn(std-warn (list"STD-LAYER-PUT-COLOR - "(std-msg "Color argument must be an integer from 1 to 255.\n")(list 'std-layer-put-color name colorasinteger) ))nil ) (if (setq layer (std-%layer-obj name))(progn (setqcolorasinteger (if (minusp (std-getcolor layer)) (- (abs colorasinteger)) ; keep it off colorasinteger )layer (subst (cons 62 colorasinteger) (assoc 62 layer) layer ) ) (entmod layer) (entupd (cdr (assoc -1 layer))) (cdr (assoc -1 layer))) ) ) ));;; tries to load it(defun std-layer-put-ltype (name ltype / layer) (if (listp name) (foreach x name (std-layer-put-ltype x ltype) ) (if(not (stringp ltype)) (std-warn(list "STD-LAYER-PUT-LTYPE - " (std-msg "Ltype argument must be an string.\n") (list 'std-layer-put-ltype name ltype)) ) (progn(if (not (tblsearch "LTYPE" ltype)) (command "_'LINETYPE" "_LOAD" ltype "" ""))(if (not (tblsearch "LTYPE" ltype)) (std-warn (list "STD-LAYER-PUT-LTYPE - " (std-msg "Ltype not found.\n") (list 'std-layer-put-ltype name ltype) ) ) (if (setq layer (std-%layer-obj name)) (progn (setq layer (subst (cons 6 ltype) (assoc 6 layer) layer ) ) (entmod layer) (entupd (cdr (assoc -1 layer))) (cdr (assoc -1 layer)) ) )) ) ) ));;; if the layer name exists nothing is performed. if it does not exist it;;; creates the layer. always returns the ename of the layer(defun std-layer-add (name / layer) (if (listp name) (mapcar (function std-layer-add) name ) (if(setq layer (std-%layer-obj name)) (cdr (assoc -1 layer)) (progn(if (>= (std-ver-num) 14) (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") ' (100 . "AcDbLayerTableRecord") (cons 2 name) ' (70 . 0) ) ) (entmake (list '(0 . "LAYER") (cons 2 name) '(70 . 0))))(cdr (assoc -1 (std-%layer-obj name))) ) ) ));;; makes the layer name current;;; always returns the ename of the layer(defun std-layer-set (name / layer) (if (setq layer (std-%layer-obj name)) (progn; since when is this allowed? (setvar "CLAYER" name) (cdr (assoc -1 layer)) ) ));;; synonymous to command layer make. create or set;;; always returns the ename of the layer;;; groups: '("color" 6 "ltype" "hidden") or just nil;;; changed 13-jul-00: keep old properties,;;; only assure that it's current and on.(defun std-layer-make (name groups) (if (not (tblobjname "LAYER" name)) (progn (std-layer-add name) (while groups(cond ((= (strcase (car groups)) "COLOR") (std-layer-put-color name (cadr groups)) ) ((= (strcase (car groups)) "LTYPE") (std-layer-put-ltype name (cadr groups)) ))(setq groups (cddr groups)) ) ) ) (std-layer-set name) (std-layer-on name));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdtbl-symbols*))(setq *stdtbl-symbols* nil);;; module dependencies:(std-%simple-provide "STDTBL");;; at first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.;;; (std-%simple-require "stdaci")(std-require "STDINIT")(std-require "STDSTR")(std-require "STDLIST")(std-require "STDMATH")(std-require "STDFILE")(std-require "STDERROR")(std-require "STDTIME")(std-require "STDMISC");;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdmisc.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:30:29 rurban>;;; copyright (c) 1998,99 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; miscellaneous acad specific functions for the stdlib;;; status:;;; not tested: std-block-update,std-%install-acomp-ctrl-c-interceptor;;;;;; $log: stdmisc.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; revision 0.4008 2000/05/14 17:36:23 rurban;;; 0.5 release;;;;;; 2000-04-26 18:37:49 rurban;;; added std-%all-significant-chars, std-%create-significant-chars;;; 2000-04-09 10:46:36 rurban;;; added std-%install-acomp-ctrl-c-interceptor;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stdmisc-symbols* ' (std-block-require std-block-update std-bpoly std-scriptactive-p std-dclactive-p std-break-command std-pause-command std-open-command std-entity-mark std-entity-unmark std-osmstr ) ) ));;; no workarounds possible;;; assure block is loaded. if not inserts the first found dwg.;;; does no block update, use (std-block-update name) therefore.(defun std-block-require (name / fn) (if (not (tblsearch "BLOCK" name)); truncate for dos 8.3 or is it done; by acad? (if(setq fn (findfile (std-force-extension (std-%block-fname name) ".DWG" ) )) (if (std-scriptactive-p)(std-block-update name)(progn (command "_INSERT" (strcat name "=" fn)) (command) fn) ) (std-error(list (std-msg "Block ") name (std-msg " not found!\n")) ) ) name ));;; truncate blockname for dos8.3(defun std-%block-fname(s) (if (std-sys-longfname-p) s (substr s 1 8) ));;; re-load a block from the harddisc, update its internal definition;;; if it was not defined before load a new one.;;; either return t/nil or call std-cerror(defun std-block-update(name / fname fname1 l ele) (std-var-push '(("ATTREQ" . 0 ) ) ) (setq fname1 (std-force-extension (std-%block-fname name) ".DWG")) (if (setq fname (findfile fname1)) (if(std-scriptactive-p); scripting variant. slow, but; (command) is not allowed. (progn(std-verbose-print (list(std-msg " Update block ")name" (SCRIPT)...\r" ))(setq l (entlast))(command "_INSERT" (strcat name "=" fname) "-1000,1000" "" "" "")(if (and (= name (std-getname (setq ele (entlast)))) (= (std-gettype ele) "INSERT") (/= l ele) ) (entdel ele) (std-cerror (std-msg "Couldn't delete temp. block"))) ); normal variant with (command) (progn(std-verbose-print (list (std-msg " Update block ") name " ...\r")); old acomp workaround(if (= (type std-acomp-ctrl-c-interceptor) 'list) (std-acomp-ctrl-c-interceptor))(command "_INSERT" (strcat name "=" fname))(command) ) ) (std-verbose-print (list (std-msg " File ") fname1 (std-msg " not found!\n")) ) ) (std-var-pop) fname);;; create a bpoly, r14 compatible, 2 arguments, ss may be nil(defun std-bpoly (pt ss / ele) (cond ((member (type c:bpoly) '(subr exrxsubr exsubr)) (if ss (c:bpoly pt ss); old arx or ads function (c:bpoly pt) ) ) ((std-ver-r14-p); >=r14: native command (setvar "CMDDIA" 0) (setq ele (entlast)) (std-break-command) (command "_BPOLY" "_A" "_I" "_N" "") ; advanced options; without island detection (if ss (command "_B" "_N" ss "") ); define boundary set if ss (command "" pt "") (setvar "CMDDIA" 1) (if (/= (entlast) ele) (entlast) ) ); return created bpoly (t (std-cerror (std-msg "command _BPOLY not available")) ) ));;; old version;;; no ordinary [1] or transparent [2] command active.;;; defined in stderror;;; (std-%cond-defun;;; '(defun std-cmdactive-p ();;; (std-bitsetp 3 (getvar "cmdactive")));;; )(defun std-scriptactive-p () (std-bitsetp 4 (getvar "CMDACTIVE")))(defun std-dclactive-p () (std-bitsetp 8 (getvar "CMDACTIVE")))(defun std-break-command (); cancel all possibly open dialogs (while (std-dclactive-p) (done_dialog) ); ~ term_dialog; cancel all command loops (dim,; -layer, ...) (while (std-cmdactive-p) (command) ));;; repeat user prompts while in command loop;;; set texteval for dtext and such.(defun std-pause-command (/ name) (std-var-push '(("TEXTEVAL" . 1 ) ("CMDECHO" . 1 ) ) ); v0.3013 (setq name (getvar "CMDNAMES")) (or (zerop (getvar "CMDACTIVE")) (while (= (getvar "CMDNAMES") name) (command pause) ) ) (std-var-pop));;; open-ended command loop;;; repeat user prompts while in command loop;;; (std-open-command (list "_copy" ele "" "_m" pt));;; asks for all further points, e.g. _endp,...(defun std-open-command(lst) (setvar "CMDECHO" 1) (if (> (length lst) *max-args-limit*) (std-error (std-msg "maximal number of arguments exceeded")) (apply (function command) lst ) ) (std-pause-command));;; highlights entity;;; on errors it's unhighlighted(defun std-entity-mark (ele); calls (redraw ele 3) implicitly (std-%var-add-pair (cons ':redraw ele)));;; normal again;;; restore error stack frame(defun std-entity-unmark (ele); calls (redraw ele 4) implicitly (std-%var-delete-pair (cons ':redraw ele)));;; -------------------------------------------------------------------73;;; upcase all significant chars, for getkword options.;;; ("byblock" "bylayer" "red" "yellow" "green" "cyan" "blue");;; => ("byblock" "bylayer" "red" "yellow" "green" "cyan" "blue")(defun std-%all-significant-chars (_lst) (mapcar (function (lambda (s)(std-%create-significant-chars s _lst) ) ) _lst ));;; "green" '("byblock" "bylayer" "red" "yellow" "green" "cyan" "grey");;; => "green" (because of "grey"(defun std-%create-significant-chars (s lst / _i l) ; search all union; prefixes, upcase this, downcase the; rest (setqs (strcase s)lst (mapcar 'strcase lst )lst (std-remove s lst)_i 1l (strlen s) ) (while (and (<= _i l) (member (substr s 1 _i) (mapcar (function (lambda (x) (substr x 1 _i) ) ) lst ) ) ) (setq _i (1+ _i)) ) (if (= _i l) (strcase s) (strcat (strcase (substr s 1 _i)) (strcase (substr s (1+ _i)) t) ) ));;; return all uppercase chars as string.;;; only the first maxlen chars or all chars if not maxlen.;;; ignore leading underscore or dot.;;; (std-%extract-significant-key "center" 3) => "cnt";;; (std-%extract-significant-key "_.center" nil) => "_.cntr"(defun std-%extract-significant-key (s maxlen / i l c ret lret) (setqret (std-%strip-command-prefixes s); if we had multiple values..s (cdr ret); okay we have it as sampleret (car ret) ); but i don't want it to include (setqi 1; into the stdlib.lret (strlen ret)l (strlen s) ) (if (not maxlen) (setq maxlen l) ) (while (and (< lret maxlen) (<= i l) ) (if(std-isupper (setq c (substr s i 1))) (setq ret (strcat ret c) lret (1+ lret) ) ) (setq i (1+ i)) ) ret);;; returns a list of stripped prefixes ("_" "." "_." "._") and the rest;;; => (prefix . s)(defun std-%strip-command-prefixes (s) (std-%strip-prefix "." (std-%strip-prefix "_" (std-%strip-prefix"."(cons "" s) ) ) ));;; lst: <= (s . prefix) => (s . prefix)(defun std-%strip-prefix (prefix lst) (if (std-strcmp prefix (std-firstchar (cdr lst))) (cons (strcat (car lst) prefix) (substr (cdr lst) 2)) lst ));;; other language settings override this in stdlocal(std-require "STDLISP")(std-defconstant '*stdsmode-long-strings* '("NONe" "ENDpoint" "MIDpoint" "CENter" "NODe" "QUAdrant" "INTersection" "INSert" "PERpendicular" "TANgent" "NEArest" "QUIck" ))(if (std-ver-r14-p) (std-defconstant '*stdsmode-long-strings* (append *stdsmode-long-strings* ' ("APParent Intersection") ) ))(if (std-ver-r2000-p) (std-defconstant '*stdsmode-long-strings* (append *std:osmode-long-strings* '("EXTension" "PARallel") ) ))(std-defconstant '*std:osmode-short-strings* (mapcar (function (lambda (s)(std-%extract-significant-key s 3) ) ) *std:osmode-long-strings* ));;; returns osmode string for osmode value such as;;; (std-osmstr (+ 1 4 8)) => "end,cen,nod";;; the first string has to be treated special.(defun std-osmstr (i / osm n x) (foreach n (std-int-list (length *std:osmode-short-strings*)) (if(= (logand (setq x (expt 2 n)) i ) x) (setq osm (cons (nth (1+ n) *std:osmode-short-strings*) osm)) ) ) (if osm (std-strjoin (reverse osm) ",") (car *std:osmode-short-strings*) ));;; -------------------------------------------------------------------73;;; install acomp-ctrl-c-interceptor, the acomp (ctrl-break) enabler.;;; without calling this somewhere acomp will never break on <esc>;;; or <ctrl-c>. but this must be defined in an uncompiled lisp.;;; best in the mnl file or in acad.lsp before s::startup;;; the problem is to load it into the autolisp space instead of into;;; the compiled lisp.;;; (defun acomp-ctrl-c-interceptor () (princ));;;;;; usage:;;; ;;; must be at toplevel!;;; (if (not (listp acomp-ctrl-c-interceptor));;; (std-%install-acomp-ctrl-c-interceptor))(defun std-%install-acomp-ctrl-c-interceptor (/ fn f) (std-require "STDFILE") (setqfn (std-filename-mktemp "$acomp.scr")f (std-fopen fn "w") ) (write-line "(defun ACOMP-CTRL-C-INTERCEPTOR () (princ))" f) (std-fclose f) (command "_SCRIPT" fn));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdmath-symbols*))(setq *stdmath-symbols* nil);;; module dependencies:(std-provide "STDMISC");;; at first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.;;; (std-require 'stdaci) ; the whole bunch (better list them explictly)(std-require "STDINIT")(std-require "STDSTR")(std-require "STDLIST");;; (std-require "stdmath"); std-bitsetp now in stdinit(std-require "STDFILE")(std-require "STDERROR")(std-require "STDTIME");;; >>cut here ---------------------------------------------- <<cut here;;; $id: stderror.lsp 0.5006 2000/12/31 10:59:00 rurban rel $-*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:12 rurban>;;; copyright (c) 1998,99 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; error handling and state save/restore;;; this is an important and tricky one.;;;;;; status:;;; seems to be okay though there are some critical functions here.;;;;;; $log: stderror.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-05-19 rurban;;; fixed std-%cmdecho-0 print;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-03-14 22:07:54 rurban;;; fixed not changed sysvars handling, when they had been;;; changed during execution;;; fixed empty :ucs handling (in stdtbl);;; 2000-04-07 14:52:32 rurban;;; removed std-assert from error handler;;;;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *stderror-symbols* '(*std-error* std-var-push std-var-pop std-ename-exist-p std-unchanged-dwg-p std-cmdactive-p std-var-init std-var-restore std-%var-simple-init std-%var-simple-restore ) ) ));;; keywords as error handler keys:;;; make them self evaluating and ide expandable (blue).;;; needed as special error initializers.;;; as keyword you may also forget the quotes.;;; usage with (std-var-init '(pairs*))(std-%simple-require "STDLISP");;; system:(std-defkeyword ':transparent);;; (:transparent)(std-defkeyword ':error);;; (:error my-err)(std-defkeyword ':function);;; (:function std-princ my-princ)(std-defkeyword ':protected-function);;; (:protected-function princ my-princ)(std-defkeyword ':file);;; (:file file);;; entities:(std-defkeyword ':entupd);;; (:entupd ele*)(std-defkeyword ':entdel);;; (:entdel ele)(std-defkeyword ':redraw);;; (:redraw [ele])(std-defkeyword ':grvecs);;; (:grvecs [vec-sym | clear-func]);;; tables:(std-defkeyword ':ucs);;; (:ucs [ucs]), see stdtbl(std-defkeyword ':zoom);;; (:zoom [p1 p2])(std-defkeyword ':view);;; (:view [view-name])(std-defkeyword ':vports);;; (:vports [vports-name])(std-defkeyword ':undo);;; (:undo [undoctl])(std-defkeyword ':layer);;; (:layer [laynam]);;; fcad errors:;;; "warning: program terminated by exit!";;; "user break"(setq *std:error-strings* (cond ((std-ver-fcad-p) ' ("Warning: Program terminated by EXIT!" ; (qu; it) "User break"; *cancel* on prompts ) ); *cancel* during evaluation; impossible ((eq (std-ver-language) :german) '("quit / exit abort" "Funktion abgebrochen"; *abbruch* bei prompts "Tastatur-Abbruch" ) ); *abbruch* in ausf?rung; thanks to serge pashkov; <psw@rt.kiam.ru> for the russian; strings.; the cp ansi_1251 strings are the; same as in cp dos866 (dos/windows) ((eq (std-ver-language) :russian) ' ("\242\353\345\256\244 \341 \257\256\254\256\351\354\356 \344\343\255\252\346\250\250 \242\353\345\256\244\240" "\224\343\255\252\346\250\357 \257\340\245\340\242\240\255\240." "\257\340\245\340\353\242\240\255\250\245 \341 \252\256\255\341\256\253\250" ) ); thanks to nobuhiro haketa; <nobuhiro@trialsoftware.com>; trial software laboratories, japan ((eq (std-ver-language) :japanese) ' ("quit / exit \202\311\202\346\202\351\222\206\216~" "\212\326\220\224\202\252\267\254\335\276\331\202\263\202\352\202\334\202\265\202\275" "\272\335\277\260\331 \314\336\332\260\270" ) ) (t '("quit / exit abort" "Function cancelled"; *; cancel* on prompts "Console break" ) ); *cancel* during evaluation ));;; standard error handler, honors *fopen* and (std-var-restore),;;; but doesn't process environment cleanup: local vars become globals!;;; error handlers must be fast, so there are special versions for;;; each supported language.(defun *std-error* (msg); verbosity:; print nothing on (quit),(exit); and user breaks. (if (not (member msg *std:error-strings*)) (princ msg) ) (std-var-restore) (term_dialog); ??? fixme (if (and*debug*(std-ver-r2000-p) ) (vl-bt) ))(defun *std-%simple-error* (msg) (princ msg) (std-%var-simple-restore));;; -------------------------------------------------------------------73;;; error stack frames;;; *std:var-stack* is a list of assoc-lists with saved states.;;; each list is a frame to be restored by (std-var-pop).;;;;;; ex: ( ((:file . <file>)) ((:error . *error*)) ) has two frames:;;; the first (or top) frame holds the original *error* handler,;;; the last (or actual) frame an open file, which will be closed;;; in case of errors.;;;;;; (std-var-init) starts with a complete new stack,;;; (std-var-restore) empties the whole stack, restores all frames.;;; both are to be used as first and last function of a user c: command;;; definition. (std-var-push) and (std-var-pop) are used in between;;; library or user functions to be able to restore changes in case of;;; errors, such as open files, special error handlers, highlighted or;;; temp. deleted entities, changed zoom, view or ucs,and such.;;;;;; this behaviour is extendable by applying more std-save-... and;;; std-restore-... functions for any key.;;; adds variables (stack-frame) to the global var-stack;;; used in inner functions to be able to clean up in case of errors.;;; must be followed by a matching (std-var-pop);;; (std-var-push '(("dimzin" . 12)("luprec" . 16)));;; ==> std:var-stack ( (("dimzin" . 12)("luprec" . 16));;; var-state1 var-state2 ...)(defun std-var-push (alst / pair lst) (foreach pairalst (setq lst (cons (std-%var-handler (car pair) (cdr pair) t) lst)) ) (setq *std:var-stack* (cons lst *std:var-stack*)));;; removes last std-var-push'ed variables from global *std:var-stack*;;; used in inner functions in case of errors.;;; must be used in conjunction with a previous matching (std-var-push);;; an error in this routine will leave a pending *std:var-stack*;;; we could use our own *error* hook just for this func or try to reset;;; it at (std-var-init);;; example: (std-var-pop);;; => *std:var-stack* ( var-state1 var-state2 ...)(defun std-var-pop (/ pair) (foreach pair(car *std:var-stack*) (std-%var-handler (car pair) (cdr pair) nil) ) (setq *std:var-stack* (cdr *std:var-stack*)));;; adds a pair -but no seperate stack frame- to the;;; actual (first) stack-frame of the global var-stack(defun std-%var-add-pair (pair / frame) (setqframe (cons (std-%var-handler (car pair) (cdr pair) t) (car *std:var-stack*) ) ) (setq *std:var-stack* (cons frame (cdr *std:var-stack*))));;; deletes (pops) this pair from the actual (first) stack-frame;;; of the global var-stack.(defun std-%var-delete-pair (pair / frame) (setqframe (substnilpair(car *std:var-stack*) ) ) (setq *std:var-stack* (cons frame (cdr *std:var-stack*))) (std-%var-handler (car pair) (cdr pair) nil));;; regen a single entity if it exists and is not deleted(defun std-%safe-entupd(ele) (if (std-ename-exist-p ele) (entupd ele) ));;; not deleted autocad entity(defun std-ename-exist-p (ele) (and (std-enamep ele); #- standalone|; (entget ele) ));;; the complete engine for *std:var-stack* handling;;; -------------------------------------------------;;; sets sysvars (strings) and treats special commands (symbols);;; if init then initialize *var-stack*, else restore it.;;; the init part must return a meaningful list to be able to restore;;; the previous state at restore, restore doesn't have to provide a;;; return value.;;; (:vports nil t) only saves a name to be restored with;;; (:vports name nil)(defun std-%var-handler(key val init / x func) (cond ((not key) nil ) ((stringp key); set normal system var (if init; we cannot check if key is a; write-protected sysvar, (progn; if val is nil we'll get the error; on restauration (setq x (getvar key)); and an error inside *error*! (if val (setvar key val) ) (cons key x); store it always to restore; intermediate changes ) (if val (setvar key val) ) ) ) ((eq key ':transparent) (list key) ); (:error new-err) - overload; *error* function; the init value must be a symbol,; no function,; but stored is the function, not; the symbol.; (defun my-err (s)(princ; s)(std-%var-simple-restore)); (std-var-push '((:error .; my-err))); => (((:error . <subr; *error*>))); or even:; (std-var-push (list (cons :error; (defun my-err (s)(princ; s)(std-%var-simple-restore))))) ((eq key ':error); (if (and (not (std-vl-p)); fixed; autolisp 0.3009; init; (std-symbolp val)); (setq val (eval val))) (cons key (if init (progn; (print val)(print (type val)); fixed v0.5003: in alisp; *std-error* is passed as sym (cond ((eq val '*std-error*)) ((std-symbolp val) (if (not (std-functionp (std-symbol-value val))) (std-error (list "(std-functionp (std-symbol-value " val ")) failed" ) ) ) ) ((not (std-functionp val)) (std-error (list "(std-functionp " val ") failed")) ) ); (std-assert (list 'std-functionp; val) nil) (setq x *error*; set new and store old error; handler *error* (if (std-symbolp val) (std-symbol-value val) val ) ) x ) (setq *error* val) ) ) ); restore previous; (:function ori-func new-func) -; overload any function; (:function my-princ new-princ) =>; (:function princ <usubr>); use this if the new function; should not be protected, regardless; if the ori-func is protected; overload a protected function:; (:protected-function ori-func; new-func); (:protected-function princ; std-princ); => (:protected-function princ; <usubr>); use this if the new function; should be protected also, and the; if the ori-func is protected,; but this not important.;; get the original value of the; ori-func with:; (setq ori-func (std-%ori-function; ori-func)) resp.; (setq ori-func (std-%ori-protected-; function ori-func));; note: function overloading will; not work with compiler mode; :link or :make-internal, unless; you provide a not-link pragma for; these functions! ((member key '(:function :protected-function)) (cons key (if init (progn; we do strict assertions here, to; check errors at init,; not at restore (if (not (std-functionp (car val))) ; removed assertion; v0.3015 (std-error (list "std-functionp " (car val) (std-msg " failed") ) ) ) (if (not (std-functionp (cadr val))) (std-error (list "std-functionp " (car val) (std-msg " failed") ) ) ); (setq ori-func (car val) new-func; (cadr val)) (setq x (std-gensym)) (set x (std-symbol-value (car val))) (std-%unprotect-assign (list (car val))) (set (car val) (std-symbol-value (cadr val))) (if (eq key ':protected-function) (std-%protect-assign (list (car val))) ) (list (car val) (std-symbol-value x)) ) (progn (std-%unprotect-assign (list (car val))) (set (car val) (cadr val)) ; restore ori-func (if (eq key ':protected-function) (std-%protect-assign (list (car val))) ) ) ) ) ); close file on restauration ((eq key ':file) (cons key (if init val; store open file (std-fclose val) ) ) ); close it; do and undo highlighting ((eq key ':redraw); undo highlighting, single entity; only (if (std-ename-exist-p val) (if init (redraw val 3); called by std-entity-mark (redraw val 4) ); called by std-entity-unmark (redraw) ); added v0.4001 (cons key val) ) ((eq key ':entupd); regen element on restore, (if init; multiple entities allowed also (cons key val) (if (listp val) (mapcar (function std-%safe-entupd) val ) (std-%safe-entupd val) ) ) ); same file; undo entdel on restore only ((eq key ':entdel); undo temp. deletion (std-require "STDENT") (if init (cons key val) (if (std-enamep val) (std-entdel val) ) ) ); fixed by serge pashkov ((eq key ':grvecs); undo temp. grvecs on restore only; accept symbol holding the temp; vecs or a function to clear it (if init (cons key val) (cond ((null val)); changed v0.4001 ((std-functionp val) (eval val) ) ((and (std-symbolp val) (consp (setq x (std-symbol-value val))) ) (grvecs x) ) ) ) ) ((eq key ':ucs) (std-require "STDTBL"); fixme: check for perspective; viewport, no errors! (if init (progn (setq x (std-save-ucs)); save ucs (if val (std-restore-ucs val) ) (cons key x) ) (std-restore-ucs val) ) ); restore ucs ((eq key ':layer) (std-require "STDTBL") (if init (if val (cons key (std-save-layer val)) (cons "CLAYER" (getvar "CLAYER")) ; change key!! ) (if val (std-restore-layer val) ) ) ); extendable definition for your own; keywords, no error checking.; usable for :view, :zoom, :vports,; :undo, ...; just supply a std-save- and a; std-restore- function.; the symbol must not have a leading; colon. if so it is removed; for calling the save/restore; function. ((std-symbolp key) (setq x (std-symbol-name key) x (if (= ":" (std-firstchar x)) (substr x 2) x ) ) (setq func(read (strcat "std-" (if init"save-""restore-" ) x )) ) (std-require "STDTBL") (if (std-functionp func) (if init (progn (setq x (apply func nil ) ); return actual setting; if a object (a name) was supplied,; restore (=set) it,; else do nothing, we just had; stored the original value; without setting a new. (if val (apply (read (strcat "std-restore-" x)) (list val) ) ) (cons key x) ) (apply func (list val) ) ) (std-error (list (std-msg "missing function definition: ") func) ) ) ) (t nil ) ));;; accessor for the original protected function.;;; return the last definition of the original function;;; definition in the stack frame.;;; *std:var-stack*: (((:protected-function + #<subr @00188664 +>)));;; (std-%ori-protected-function '+) => #<subr @00188664 +>(defun std-%ori-protected-function (func) (std-%search-stack ':protected-function 2 func));;; accessor for the original function.;;; better than (caddr (assoc ':function (car *std:var-stack*)));;; because there may be some more std-var-push in between;;; *std:var-stack*: (((:function + #<subr @00188664 +>)));;; (std-%ori-function '+) => #<subr @00188664 +>(defun std-%ori-function (func) (std-%search-stack ':function 2 func));;; general accessor to get the first saved value;;; from the error stack frame.;;; ex: (std-%find-error-key "osmode") => ("osmode" . 0)(defun std-%find-error-key (key / stack x) (setq stack *std:var-stack*) (while (and stack (not (setq x (std-%search-list key nil (car stack)))) ) (setq stack (cdr stack)) ) x);;; search for the last key in the frame and return the original value;;; which is stored in position pos;;; *std:var-stack* : (((:protected-function + #<subr @00188664 +>)));;; (std-%search-stack ':protected-function 2 '+) => #<subr @00188664 +>(defun std-%search-stack (key pos val / stack x) (setq stack *std:var-stack*) (while (and stack (not (setq x (std-%search-list key val (car stack)))) ) (setq stack (cdr stack)) ) (if x (nth pos x) ));;; searches the list for a (key val ...) or (key . val) pair;;; val may be the cadr of a plain list or a cdr of an alist.;;; (std-%search-list ':function '+;;; '((:function - #<subr @00188665 ->);;; (:function + #<subr @00188664 +>)));;; => (:function + #<subr @00188664 +>)(defun std-%search-list(_key _val lst) (if (not _val) (car (member _key lst)) (car (std-member-if (quote; ) (lambda (x) (and (eq (car x) _key) (if (std-dotted-pair-p x) (eq (cdr x) _val) (eq (cadr x) _val) ) ) ) ) lst ) ) ));;; set cmdecho to 0. but not on drawing startup, not to change dbmod.;;; otherwise the dwg would be marked as changed.;;; returns old setting.(defun std-%cmdecho-0 (/ msg var) (setq msg (std-msg "CMDECHO 0 suppressed during startup")) (setq var (getvar "CMDECHO")) (if (std-unchanged-dwg-p) (progn (if (not (zerop var))(std-verbose-print msg) ) var ) (progn (if (zerop (getvar "DBMOD"))(progn (if (not (zerop var)) (std-verbose-print msg) ) var)(setvar "CMDECHO" 0) ) ) ));;; not to change the database in startup functions(defun std-unchanged-dwg-p () (or (not (std-acad-connection-p)); #- standalone|; (zerop (getvar "DBMOD")) ));;; no ordinary [1] or transparent [2] command active(defun std-cmdactive-p () (/= 0 (logand 3 (getvar "CMDACTIVE"))));;; this happens most likely because of vlide-abort <ctrl-r>,;;; but it can be error inside your user- *error* as well.(std-defconstant 'std:errmsg-pend-stack (std-msg "pending *STD:VAR-STACK* deleted. Previous function didn't end correctly." ));;; this happens most likely because of nested init/restore calls!(std-defconstant 'std:errmsg-wrong-error (std-msg "Tried to restore wrong error handler. Fixed."));;; used as first functions in a user function. to initialize systemvars;;; and such. similar to std-var-push, it only does some more book;;; keeping stuff: undo handling, implicit picksets, ...(defun std-var-init (alst / oldcmd) (setq oldcmd (std-%cmdecho-0)); non-destructive cmdecho 0; sets verbosity off; remember pickfirst selection; because _undo _group deletes it; in (bd4a) compiled functions; (ssget "_i") does not work! (acomp); needed for user-input funcs (if (and(std-bitsetp 1 (getvar "PICKFIRST"))(not (std-cmdactive-p))(setq *std:ss-picked* (ssget "_I")) ) nil (setq *std:ss-picked* nil) ); initialize break stepper (if *break* (setq *cont* nil) ); initialize std-entget cache, to; avoid cache inconsistencies,; e.g. entities changed by not; stdlib commands.; many thanks to ralph gimenez (setq *entget-cache* nil); v0.4001; undo handling; no undo with transparent flag or; active command (if (or(std-cmdactive-p)(assoc ':transparent alst) ) nil (progn (if (std-bitsetp 8 (getvar "UNDOCTL")) ; group already active,(progn; most likely an error (std-warn (std-msg "end old UNDO group")) (command "_.UNDO" "_END")) ); panic mode 12/14/99 (if (not undo_init)(setq undo_init (getvar "UNDOCTL")) ); save actual command on command; stack?; (std-push (getvar "cmdnames"); '*std:cmdstack*); this is dangerous! (if (std-functionp 'ai_undo_push)(ai_undo_push); start new undo group(command "_.UNDO" "_Begin"); earlier called _group (r12?) ) ) ); delete pending *std:var-stack*,; only if :transparent flag; most likely an error (if (and*std:var-stack*(not (assoc ':transparent alst)) ) (progn (std-debug-print *std:var-stack*) (std-warn std:errmsg-pend-stack) (setq *std:var-stack* nil) ) ); save all keys (std-var-push alst); add error handler and cmdecho to; stack frame (if (and(not *debug*)(not (assoc "CMDECHO" alst)) ) (std-%var-add-pair (cons "CMDECHO" oldcmd)) ); see if the standard error handler; is already supplied (if (and(not (eq *std-error* *error*)); fixed v0.4001(not (assoc ':error alst)) ) (std-%var-add-pair '(:error . *std-error*)) ) *std:var-stack*);;; use this simple without acad connection,;;; just for files and error handling(defun std-%var-simple-init (alst) (if *break* (setq *cont* nil) ); delete pending *std:var-stack*,; only if :transparent flag; most likely an error (if (and*std:var-stack*(not (assoc ':transparent alst)) ) (progn (std-debug-print (list "*error*: " *std:var-stack*)) (std-warn std:errmsg-pend-stack) (if (eq *error* *std:ori-error*)nil(progn (std-debug-print *error*) (std-warn std:errmsg-wrong-error) (setq *error* *std:ori-error*)) ) (setq *std:var-stack* nil) ) ); save all keys without the acad; symbol vars (std-var-push (std-remove-if 'stringp alst)) (if (and(not (eq *std-%simple-error* *error*)) ; fixed v0.4001(not (assoc ':error alst)) ) (std-%var-add-pair '(:error . *std-%simple-error*)) ) *std:var-stack*);;; use it without acad connection, just for files and error handling;;; fixme :transparent usage will fail so far(defun std-%var-simple-restore (/ topframe); restore vars, ignore for now; recursive stack frames (setq topframe (last *std:var-stack*)) (while *std:var-stack* (std-var-pop) ) (if (and(listp topframe); safe assoc(std-every 'std-dotted-pair-p topframe)(not (assoc ':transparent topframe))(std-module-defined-p "STDFILE") ) (progn (std-fcloseall) (std-%delete-mktemp) ) ) (if (eq *error* *std:ori-error*) nil (progn (std-debug-print *error*) (std-warn std:errmsg-wrong-error) (setq *error* *std:ori-error*) ) ) (prin1));;; restore all stack frames.;;; fixme :transparent usage will fail so far;;; used as last user function(defun std-var-restore (/ topframe oldcmd); restore vars, ignore for now; recursive stack frames (setq topframe (last *std:var-stack*)) (setq oldcmd (std-%find-error-key "OSMODE")) ; get safed cmdecho (while *std:var-stack*; the way to handle cmdecho is; arguable:; cmdecho could be forced to; ("cmdecho" . 1) eg. for debugging; or; interactive commands as in; std-open-command.; now we turn off cmdecho for every; restoration stack frame,; mainly to avoid undo end; verbosity. (std-%cmdecho-0); set it off until the end (std-var-pop) ) (if (or(std-cmdactive-p); safe assoc(and (listp topframe) (std-every 'std-dotted-pair-p topframe) (assoc ':transparent topframe)) ) nil (progn (std-%cmdecho-0) (if (std-module-defined-p "STDFILE")(progn (std-fcloseall) (std-%delete-mktemp)) ) (if (std-functionp 'ai_undo_pop)(progn (command); r2000 fix; panic mode 12/14/99 (if (not undo_init) (setq undo_init (getvar "UNDOCTL")) ) (ai_undo_pop))(command "_.UNDO" "_End") ) (term_dialog) ) ) (if (and(numberp oldcmd)(/= oldcmd (getvar "CMDECHO")) ) (setvar "CMDECHO" oldcmd) ) (if (eq *error* *std:ori-error*) nil (progn (std-warn std:errmsg-wrong-error) (setq *error* *std:ori-error*) ) ) (prin1));;; prin1 does not expand escape sequences, so it may be;;; a bit faster.;;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *stdent-symbols*))(setq *stdent-symbols* nil);;; module dependencies:(std-%simple-provide "STDERROR");;; at first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.;;; if all required stdlib modules are contained in one project,;;; we don't have to load it explicitly. stdlib.fas already contains it(if (not *std:%project*) (progn (std-%simple-require "STDINIT") (std-%simple-require "STDFILE"); std-fcloseall ); else: if it's loaded as project; (stdall, stdlib.fas or stdlib.bi4); we have to do it in; (stdlib-project-init));;; 'stderror;;; >>cut here ---------------------------------------------- <<cut here;;; $id: entmake.lsp 0.5006 2000/12/31 10:59:00 rurban rel $-*-autolisp-*-;;; time-stamp: <2000-12-31 11:31:21 rurban>;;; copyright (c) 1998,99,2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; entmake module for the stdlib;;; checked but fast creation of autocad objects.;;; status:;;; fixed for felixcad;;; not full featured yet, more entities and objects to be added;;; eventually. thanks to david kozina who's doing this.;;; the new as temporary marked functions by david kozina might fail.;;; they are very experimental.;;; with the new std-entmake-pface update, changes must be fixed at;;; the user side: either add a "0" to the call or fix the face;;; indices.;;; std-entmake-xxx moved from stdent.lsp;;; not included in the seperate package small;;; bug in template opts (2000i with lwpolyline temp. fixed);;; $log: entmake.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-11-27 20:56:42 rurban;;; fixed std-entnake-lwpolyline for a2000i;;; todo: fix bug in std-%entmake-template (reverts 100 opts);;; 2000-09-23 19:17:38 rurban;;; removed std-entmake-mline, added std-entmake-xrecord,;;; fixed std-%entmake-valid-group-p for 280;;; revision 0.5004 2000/09/20 12:48:22 rurban;;; 0.5004 release, see changes;;;;;; 2000-07-12 00:54:12 rurban;;; fixed std-entmake-pface for explicit layer (in faces);;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; fixed last segment for std-entmake-polyline,;;; std-entmake-lwpolyline. it broke june 21, 2000;;; 2000-07-04 19:08:26 rurban;;; added layer arg to std-entmake-seqend;;; fixed vertex layer in std-entmake-3dpoly, std-entmake-polyline,;;; std-entmake-pface;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; 2000-06-18 19:05:50 rurban;;; fixed std-entmake-endblk, std-entmake-seqend;;; 2000-05-24 rurban;;; fixed std-%force-3dpoint and added it to various calls;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; 2000-05-05 rurban;;; fixed (std-entmake-pline nil segs);;; 2000-04-26 18:19:49 rurban;;; renumbered msg id's;;; 2000-04-25 12:32:27 rurban;;; renamed std-entmake-pface to std-entmake-pface0,;;; the face indices in std-entmake-pface are now one-based;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign (setq *entmake-symbols* ' (std-entmake-blockstd-entmake-attdef std-entmake-endblkstd-entmake-insert std-entmake-attribstd-entmake-seqend std-entmake-layerstd-entmake-style std-entmake-textstd-entmake-mtext std-entmake-circlestd-entmake-point std-entmake-plinestd-entmake-polyline std-entmake-lwpolylinestd-entmake-pface std-entmake-pface0std-entmake-3dpoly std-entmake-linestd-entmake-leader std-entmake-arcstd-entmake-ellipse std-entmake-groupstd-entmake-hatch std-entmake-solidstd-entmake-spline std-entmake-mlinestd-entmake-mlinestyle ) ) ));;; corresponds to the stdlib version for now(std-defconstant '*entmake-version* (atof (substr "$Revision: 0.5006 $" 11)));;; to load stdent acad should be connected 
;;; for now assume this:;;; (if (std-ver-r14-p) (setq *r14-lwpoly-bug* t));;; entmake templates;;; for small the whole module is too large;;; simplify entmake calls by assuming defaults.;;; textpt defaults may be improved.;;; the new 100 groups are not supported for now,;;; but will added to the opts lists step by step.;;; test if the group number is valid, release specific,;;; used to filter out groups 100 and so on.(defun std-%entmake-valid-group-p (n) (cond ((< (std-ver-num) 1) t ); alpha/beta versions ((>= (std-ver-num) 14) t ); allow all ((<= 100 n 199) nil ); subclass data markers and other; new ((= 280 n) nil ); duplicate flag ((<= 300 n 399) nil ); object handles, pointer and owner; id's (t t ) ));;; helper to check an entmake list template and to fill in defaults.;;; needs the entget-list, some defaults and some required groups.;;; the idea is also useful for other purposes.;;; 0.4006: added xflag as 4th parameter;;; todo: check and fix points for 2d/3d. (thanks to david kozina);;; rationale: if 3d needed but only 2d provided sometimes a random;;; z-value is used.;;; logic: all points are 3d, unless they are 2d elements: polylines;;; but for those the z-value is correctly stripped.;;; fixme: broken for double opts groups: reverts order.;;; (e.g. 100, fails with lwpolyline)(defun std-%entmake-template (_elist def req xflag / i new-elist newx x) (setqdef (reverse def)i 0 ) (if (or(not req)(apply (function and) (mapcar (function (lambda (_x)(assoc _x _elist) ) ) req )) ) (progn; rebuild the list of dxf groups in; the correct order; and with defaults.; note that invalid groups are only; removed if they; appear in the default list!; fixme: double 100 get reverted! (foreach x def(setq newx (cond ((not (std-%entmake-valid-group-p (car x))) nil ) ((assoc (car x) _elist)) ; okay (t (nth i def) ); get default ))(if newx (setq new-elist (cons newx new-elist)))(setq _elist (std-remove (assoc (car x) _elist) _elist) i (1+ i)) ) (setq new-elist (appendnew-elist_elist ) ) ) (ifreq (std-cerror(list (std-msg "missing dxf group in ") "(STD-ENTMAKE-" (std-gettype def) ")" (std-msg "\nele-list: ") _elist (std-msg "\ndefaults: ") def (std-msg "\nrequired: ") req) ) ) ); r15 fix, 13-mar-00 (if (or(assoc 330 new-elist)(assoc 410 new-elist) ) (setq xflag t) ) (std-%entmake-call new-elist xflag));;; v0.4005;;; will this work with multiple 10 groups? (e.g. leader);;; fixme: replace subst by position and setnth(defun std-%force-3dpoint (elist groups / x) (foreach g groups (if(and (setq x (assoc g elist)) (not (std-3dpointp (cdr x)))); ur fixed 24-may-00 (setq elist (subst (cons g (std-new-z (cdr x) 0.0)) x elist ) ) ) ) elist);;; for debugging and converting std-entmake- calls to plain entmake;;; 0.4006: added 2nd parameter xflag(defun std-%entmake-call (elist xflag) (if *debug* (progn (princ (strcat "\n(ENTMAKE" (if xflag "x" "" ) " '" ) ) (prin1 elist) (princ ")") ) ) elist (if xflag (entmakex elist) (entmake elist) ));;; added v0.4007(defun std-%textpt-below (pt); 1.25 * height: typical shx; linespacing (std-pt- pt (list 0 (* 1.25 (getvar "TEXTSIZE")) 0)));;; sample:;;; (std-entmake-block '((2 . "testblock")(70 . 2)));;; entmake some geometry...;;; (std-entmake-attdef (list '(2 . "att1")(cons 1 name)));;; (std-entmake-attdef '((2 . "att2")));;; (std-entmake-attdef '((2 . "att3")));;; (std-entmake-endblk)(defun std-entmake-block (elist / opts); 100 groups missing for r14, but; not required (setqopts (list '(0 . "BLOCK") '(2 . "") '(70 . 0) '(3 . "") ; fcad; fails with '(10 . (0 0 0)) '(10 0 0 0)) ); v0.4007 (setq*last-insertion-point* (cond ((cdr (assoc 10 elist))) (t '(0 0 0) ) ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(2) nil))(defun std-entmake-attdef (elist / opts x) (setqx (cond (*last-insertion-point*) (t '(0 0 0) ) ) ) (setq*last-insertion-point* (if (not (assoc 10 elist)) (std-%textpt-below x) (std-%textpt-below (cdr (assoc 10 elist))) ) ) (setqopts (list '(0 . "ATTDEF") '(100 . "AcDbEntity") (cons 10 x) (cons 40 (getvar "TEXTSIZE")) '(8 . "0") '(100 . "AcDbText") '(1 . ""); prompt '(3 . ""); value (cons 7 (getvar "TEXTSTYLE")) '(100 . "AcDbAttributeDefinition") '(2 . ""); name '(70 . 0) ) ); flag (visibility, constant, ...) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(2) nil));;; required 2;;; not really required but nice to have(defun std-entmake-endblk () (if (std-%entmake-valid-group-p 100) (std-%entmake-call '((0 . "ENDBLK") (100 . "AcDbBlockEnd")) nil ) (std-%entmake-call '((0 . "ENDBLK")) nil) ));;; sample:;;; (std-entmake-insert (list '(2 . "testblock")'(66 . 1)(cons 10 pt)));;; (std-entmake-attrib (list '(2 . "att1")(cons 1 name)));;; (std-entmake-attrib '((2 . "att2")));;; (std-entmake-attrib '((2 . "att3")));;; (std-entmake-seqend)(defun std-entmake-insert (elist / opts x) (setqopts (list '(0 . "INSERT") '(100 . "AcDbEntity") '(100 . "AcDbBlockReference" ) '(2 . "") '(66 . 0) '(10 0 0 0) ) ) (setq elist (std-%force-3dpoint elist '(10))) (setq x (std-%entmake-template elist opts '(2) nil)) (setq *last-insertion-point* (cdr (assoc 10 x))) x)(defun std-entmake-attrib (elist / opts x) (setqx (cond (*last-insertion-point*) (t '(0 0 0) ) ) ) (setq*last-insertion-point* (if (not (assoc 10 elist)) (std-%textpt-below x) (std-%textpt-below (cdr (assoc 10 elist))) ) ) (setqopts (list '(0 . "ATTRIB") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 10 x); same as insert (cons 40 (getvar "TEXTSIZE")) '(1 . ""); value '(100 . "AcDbAttribute") '(2 . ""); name (cons 7 (getvar "TEXTSTYLE")) '(70 . 0) ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(2) nil));;; required: 2 - attname;;; not really required but nice to have.;;; fixes layer problem in r14 (see faq).;;; v0.5003: added layer argument which might be nil(defun std-entmake-seqend (layer / elist) (setqelist (if (stringp layer)(list '(0 . "SEQEND") (cons 8 layer))'((0 . "SEQEND")) ) ) (if (std-%entmake-valid-group-p 100) (std-%entmake-call (appendelist'((100 . "AcDbEntity")) ) nil ) (std-%entmake-call elist nil) ))(defun std-entmake-layer (elist / opts name) (or (setq name (cdr (assoc 2 elist))) (std-error "STD-ENTMAKE-LAYER: require group 2") ) (if (and(snvalid name)(not (tblsearch "LAYER" name)) ) (progn; 100 groups required for >=r14 (setq opts (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(2 . "") '(70 . 0) ) ) (std-%entmake-template elist opts '(2) nil) ) (std-error (list "STD-ENTMAKE-LAYER " (std-msg "Layer already exists or wrong name") ) ) ));;; some properties are required, some optional;;; more is a entget list which might contain groups;;; 41 width, default 1.0;;; (70 . 4) vertical flag;;; 50 oblique angle, default 0.0;;; 4 bigfont filename, default "";;; based on code provided by michael puckett(defun std-entmake-style (name font height more / opts) (if (and(snvalid name)(not (tblsearch "STYLE" name)) ) (progn (setq opts (list '(0 . "STYLE") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbTextStyleTableRecord") '(2 . "") ; style; name '(70 . 0); 1 describes a shape, 4 vertical '(40 . 1.0); height '(41 . 1.0); width '(50 . 0.0); oblique angle '(71 . 0); 2 backwards, 4 upside down '(42 . 1.0); last height used (?) '(3 . "txt"); default font file '(4 . ""); bigfont file name ) ) (std-%entmake-template(append (list(cons 2 name)(cons 40 height)(cons 3 font) ) more)opts'(2 40 3)nil ) ) ))(defun std-entmake-text(elist / opts x) (setqx (cond (*last-insertion-point*) (t '(0 0 0) ) ) ) (setq*last-insertion-point* (if (not (assoc 10 elist)) (std-%textpt-below x) (std-%textpt-below (cdr (assoc 10 elist))) ) ); 100 groups missing for r14, but; not required (setqopts (list '(0 . "TEXT") (cons 10 x) (cons 40 (getvar "TEXTSIZE")) (cons 7 (getvar "TEXTSTYLE")) '(1 . "") ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(1) nil));;; required: 1 - textvalue(defun std-entmake-mtext (elist / opts x) (setqx (cond (*last-insertion-point*) (t '(0 0 0) ) ) ) (setq*last-insertion-point* (if (not (assoc 10 elist)) (std-%textpt-below x) (std-%textpt-below (cdr (assoc 10 elist))) ) ) (setqopts (list '(0 . "MTEXT") '(100 . "AcDbEntity") ; subclass marker; '(67 . 0) ; model space '(100 . "AcDbMText"); subclass marker (cons 10 x) (cons 40 (getvar "TEXTSIZE")) '(41 . 100.0); rectangle width (100% ?) '(71 . 1); attachment point '(72 . 5); drawing direction '(1 . "") (cons 7 (getvar "TEXTSTYLE")) '(11 1.0 0.0 0.0); x axis (cons 42 (* 0.8 (getvar "TEXTSIZE"))); horizontal width; of characters (cons 43 (getvar "TEXTSIZE")) ; vertical height of; characters '(50 . 0.0); rotation angle in radians. ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(1) nil));;; required: 1 - textvalue(defun std-entmake-circle (elist / opts) (setqopts (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle" ) '(10 0 0 0) ' (40 . 1) ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(10 40) nil))(defun std-entmake-point (elist / opts) (setqopts (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") '(10 0 0 0) '(50 . 0.0) ; ecs rotation ) ) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(10) nil));;; (std-entmake-pline elst pts);;; creates a simple 2d-polyline, either open or closed.;;; accepting either segment-list like ((seg1) (seg2)...),;;; supporting bulges or a simple pointlist (=> straight pline);;; creates lwpolylines or 2d-polylines;;; elist may be nil or contains layer info: ((8 . "0")) is enough(defun std-entmake-pline (elist pts / segs flag) ; convert pointlist to; segments (setqsegs (if (std-pointp (car pts)) (std-pts->segs pts) pts ) ) (setq flag (std-getflag elist)); check for explicit straight; closing segment:; we may safely omit it. check the; closed flag accordingly (if (and(std-segs-closed-p segs); last segment = closing(std-seg-straight-p (last segs)) ); and zero bulge; closed flag? (if(and flag (std-flagsetp 1 elist)); fixed 5-may-00; close: delete the segment, acad; draws it for you.; fixme with segs nil; (setq segs (std-butlast segs)); open: change flag to closed and; delete last segment (setq; segs (if (std-pointp (car pts)); (std-butlast segs) segs)elist (if flag(subst (cons 70 (1+ flag)) (cons 70 flag) elist)(cons '(70 . 1) elist) ) ) ) ); lwpolyline? (if (and(std-ver-r14-p)(not (zerop (getvar "PLINETYPE")))(/= "POLYLINE" (cdr (assoc 0 elist))) ) (std-entmake-lwpolyline elist segs) (std-entmake-polyline elist segs) ));;; general linear 2d-pline, needs segments to support bulges;;; cannot be used for splined plines (no tangent info) or width;;; segs: ((p1 p2 [bulge])(p2 p3 [bulge])...);;; elist may be nil or contain other properties, such ((8 . "0"))(defun std-entmake-polyline (elist segs / opts flag seg) ; check for; pointlist instead of segmentlist (if (numberp (caar segs)) (setq segs (std-pts->segs segs)) ); check again for last closing; segment. if so set the flag (setqflag (cond ((cdr (assoc 70 elist))) ((and (std-segs-closed-p segs) (std-seg-straight-p (last segs)))1 ) (t0 ) ) ) (setqopts (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDb2dPolyline") '(66 . 1) (cons 10 (list 0 0 (z-of (std-seg-p1 (car segs) ) ) ) ) (cons 70 flag) ) ) (std-%entmake-template elist opts nil nil); add layer info, wrong layers; might crash acad. (setq elist (std-%filter-groups '(8 60 67 62) elist)) (setqopts '((0 . "VERTEX") (100 . "AcDbEntity") (100 . "AcDbVertex") (100 . "AcDb2dVertex") (70 . 0) ) ) (foreach seg segs (std-%entmake-template (append(list (cons 10 (std-seg-p1 seg)) (cons 42 (std-seg-bulge-num seg) ))elist ) opts nil nil ) ); always add last vertex, 7-jul-00 (std-%entmake-template (list (cons 10 (std-seg-p2 (last segs)))) opts nil nil ) (std-entmake-seqend (cdr (assoc 8 elist))));;; general linear lwpolyline;;; needs segments to support bulges, segs: ((0 p1 p2)(0 p2 p3)...);;; elist may be nil or contain layer info: ((8 . "0"));;; but points or bulges are ignored.;;; nvert fix by serge pashkov;;; ignores segment specific widths;;; not release ready yet. fails on r15 sometimes.(defun std-entmake-lwpolyline (elist segs / opts flag seg nvert zdir xflag); check for pointlist instead of segmentlist (if (numberp (caar segs)) (setq segs (std-pts->segs segs)) ); closed? if so set the flag (setqflag (cond ((cdr (assoc 70 elist))) ((and (std-segs-closed-p segs) (std-seg-straight-p (last segs)))1 ) (t0 ) ) ); provide number of vertices (setq nvert (1+ (length segs))); 7-jul-00 (setqzdir (cond ((assoc 210 elist)); 13-mar-00 (t'(210 0 0 1) ) ) ); 2000-11-27: better defaults,; because std-%entmake-template is; broken (if (and(std-position '(0 . "LWPOLYLINE") elist)(std-position '(100 . "AcDbEntity") elist)(std-position '(100 . "AcDbPolyline") elist)(< (std-position '(100 . "AcDbEntity") elist) (std-position ' (100 . "AcDbPolyline") elist )) ) (setq opts (append (std-firstn (1+ (std-position '(100 . "AcDbPolyline") elist)) elist ) (list (cons 90 nvert) (cons 70 flag)) ) ) (setq opts (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") ' (100 . "AcDbPolyline") (cons 90 nvert); fixed (cons 70 flag) ) ) ); remove geometry from elist. take; only segs. (if (assoc 8 elist) (setq opts (append (std-firstn 3 opts) (list (cons 8 (std-getlay elist))) (std-nthcdr 3 opts) ) ) ) (setq elist nil); (std-remove-if; (function (lambda (_x); (member (car _x) '(-1 0 100 90 70; 5 8 330 410 10 40 41 42 210)))); elist)) (foreach seg segs (setq elist(append elist (if (std-seg-bulge seg) (list (cons 10 (std-seg-p1 seg)) (cons42(std-seg-bulge seg) ) ) (list (cons 10 (std-seg-p1 seg)) (cons 42 0.0)); 13-ma; r-00 )) ) ); always add last vertex, fixed; 11/27/00 (setq elist (append opts elist (list (cons 10 (std-seg-p2 (last segs))) '(42 . 0.0) zdir) ) ); needed?; (if (std-bitsetp 1 flag) (setq; elist (append elist '((42 .; 0.0))))); (setq elist (append elist (list; zdir))) (std-%entmake-template elist nil nil nil));;; (std-entmake-pface elist points faces);;; elist contains layer info: ((8 . "layer0")) is enough, nil also.;;; faces: ((-1 2 3)(3 4 -1)...) - one based;;; note: the old zero-based backwards compatible function is called;;; std-entmake-pface0(defun std-entmake-pface (elist pts faces / opts flag layer face pt) (setqflag (cond ((cdr (assoc 70 elist))) (0) ) ); flag or 0 (setqlayer (cond((cdr (assoc 8 elist)))((getvar "CLAYER")) ) ) (setqopts (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyFaceMesh") '(66 . 1) '(10 0 0 0) (cons 70 (+ 64 (logand 128 flag))) ) ); 64 or 192 (std-%entmake-template elist opts nil nil) (setqopts '((0 . "VERTEX") (100 . "AcDbEntity") (100 . "AcDbVertex") (100 . "AcDbPolyFaceMeshVertex") (70 . 192) ) ); points (foreach pt pts (if(std-2dpointp pt) (setq pt (std-new-z pt 0.0)) ) (std-%entmake-template (list (cons 10 pt) (cons 8 layer)) opts nil nil ) ) (setqopts '((0 . "VERTEX") (100 . "AcDbEntity") (100 . "AcDbFaceRecord") (70 . 128) ) ); face indices; relevant attributes from elist for; the vertices (setq elist (std-%filter-groups '(8 60 67 62) elist)) (foreach facefaces; (if (not (cadddr face)) (setq face; (append face (list (car face))))) (std-%entmake-template (appendelist; added 11-jul-00(list '(10 0 0 0) (cons 71 (car face)) (cons 72 (cadr face)) (cons 73 (caddr face) ) (cons 74 (cond ( (cadddr face) ) (t 0 ) ) )) ) opts nil nil ) ) (std-entmake-seqend layer));;; depricated, for backwards compatibility only.;;; (std-entmake-pface0 elst points faces);;; elist contains layer info: ((8 . "0")) is enough, () also;;; faces: ((0 1 2)(-1 2 3)...) - zero based;;; note: we have a problem if the first vertex must be invisible!;;; we cannot define it this way if you use zero-based indices.(defun std-entmake-pface0 (elist pts faces) (std-verbose-print (list "\nSTD-ENTMAKE-PFACE0 " (std-msg "is depricated")) ) (setqfaces (mapcar(function (lambda (flst) (mapcar (function(lambda(i) ; 0 => 1, -1 => -2 (if (minusp i) (1- i) (1+ i) )) ) flst ) ))faces ) ) (std-entmake-pface elist pts faces))(defun std-%filter-groups (_groups elist) (std-remove-if-not (function (lambda (x)(member (car x) _groups) ) ) elist ))(defun std-entmake-3dpoly (elist pts / opts flag seg) (setqflag (cond; closed? ((assoc 70 elist)(std-setbit 8 (cdr (assoc 70 elist))) ) ((equal (car pts) (last pts))9 ) (t8 ) ) ) (setqopts (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDb3dPolyline") '(66 . 1) '(10 0 0 0) (cons 70 flag) ) ) (std-%entmake-template elist opts nil nil) ; relevant attributes from; elist for the vertices (setq elist (std-%filter-groups '(8 60 67 62) elist)) (setqopts '((0 . "VERTEX") (100 . "AcDbEntity") (100 . "AcDbVertex") (100 . "AcDb3dPolylineVertex") (70 . 32) ) ) (foreach pt pts (if(std-2dpointp pt) (setq pt (std-new-z pt 0.0)) ) (std-%entmake-template (cons (cons 10 pt) elist) opts nil nil ) ); (if (and (std-bitsetp 1 flag);; closed logic; (not (equal (car pts) (last; pts)))); (std-%entmake-template (list; (cons 10 (car pts))) opts nil nil)) (std-entmake-seqend (cdr (assoc 8 elist))));;; -------------------------------------------------------------------73;;; the following functions were all written completely by david kozina(defun std-entmake-line(elist / opts) (setqopts (list '(0 . "LINE")'(100 . "AcDbEntity") '(100 . "AcDbLine")' (10 0 0 0) '(11 1 0 0) ) ) (setq elist (std-%force-3dpoint elist '(10 11))) (std-%entmake-template elist opts '(10 11) nil));;; no mtext support yet. only the arrow and the lines;;; partially by david kozina(defun std-entmake-leader (elist / opts pts) (setqopts (list '(0 . "LEADER") '(100 . "AcDbEntity") '(100 . "AcDbLeader" ) (cons 3 (getvar "DIMSTYLE") ) '(71 . 1) ' (72 . 0) '(73 . 3) '(74 . 0) '(75 . 0) '(40 . 0.0) ' (41 . 0.0) '(76 . 2); '(10 0 0 0);; fixed v0.4001; '(10 1 0 0) '(77 . 256) '(210 0 0 1) '(211 1 0 0) '(212 0 0 0) ) ) (setq pts (std-%group-only 10 elist)) (if (> (length pts) 1) (progn (setq elist (subst (cons 76 (length pts)) (assoc 76 elist) elist ) ); (setq elist (std-%force-3dpoint; elist '(10 210 211 212))) (std-%entmake-template elist opts '(10) nil) ) ))(defun std-entmake-arc (elist / opts) (setqopts (list '(0 . "ARC") '(100 . "AcDbEntity") '(100 . "AcDbCircle") '(10 0 0 0); center '(40 . 1.0); radius '(210 0 0 1) '(100 . "AcDbArc") '(50 . 0); start angle; (radians) (cons 51 *pi/2*) ) ); end angle (radians) (setq elist (std-%force-3dpoint elist '(10))) (std-%entmake-template elist opts '(10 40 50 51) nil))(defun std-entmake-ellipse (elist / opts) (setqopts (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") '(100 . "AcDbEllipse") '(10 0 0 0); center '(11 2 0 0); major axis endpoint '(40 . 0.5); ratio: minor axis / major axis '(41 . 0); start parameter; 0.0 for full ellipse (cons 42 *pi2*); end parameter; 2*pi for full ellipse '(210 0 0 1) ) ) (setq elist (std-%force-3dpoint elist '(10 11))) (std-%entmake-template elist opts '(10 11 40) nil));;; (std-entmake-group elist) - group entmake function;;; in r14, this function can create a group, but only an empty group.;;; of very limited usefulness - if useful at all.;;; untested in a2000.;;;;;; example:(defun std-entmake-group (elist / opts) (std-require "DICT") (cond; make sure the group name doesn't; exist ((not (dict-search "ACAD_GROUP" (setq name_str (std-getval 2 elist)) ) ) (setq elist (std-remove-if (function (lambda (_x) (member (car _x) '(2)) ) ) elist ) opts (list '(0 . "GROUP") '(102 . "{ACAD_REACTORS") (cons 330 (dict-entity "ACAD_GROUP")) '(102 . "}") ' (100 . "AcDbGroup") '(300 . ""); description '(70 . 0); "unnamed" flag values:; 0 - named, 1 - unnamed; 2 - blockgroup? '(71 . 1) ); selectability flag:; 0 - not selectable, 1 - selectable grp_ent (std-%entmake-template elist opts '() t) ); this crashes r14 if the elist; contains any group 340 ents (dictadd (dict-entity "ACAD_GROUP") name_str grp_ent) ) ));;; testcode for the func above:;;; following lines necessary as well? (unable to test in r14):;;; (std-entmake-hatch elist bdy_ents pathflag_lst) - hatch entmake;;;;;; use data from closed polylines or circles or seglists to entmake;;; non-associative (only) hatch. (use vlr for associative hatches);;; must extract vertices, bulges, # sides from plines, seglists;;;;;; pathflag_lst => (flag1 flag2 flag3...);;; => '(92 . flag1) '(92 . flag2) '(92 . flag3)...;;;;;; example: '(0 0 0) for a hatch w/ 3 boundary loops;;; boundary path type:;;; 0 - default;;; 1 - external;;; 2 - polyline;;; 4 - derived;;; 8 - textbox;;; 16 - outermost;;;;;; only non-associative hatches yet;;; highly experimental!(defun std-entmake-hatch (elist bdy_ents pathflag_lst / _elev _segs_lst opts data_alst 330_list rct_list ent_list ) (cond ((and bdy_ents; entity list argument? (apply 'and (mapcar; bdy_ents ok? (function (lambda (ele) (or (std-entity-type-p ; pline or circle? ele '("LWPOLYLINE" "POLYLINE" "CIRCLE" ) ) (listp ele) ) ) ); seglist? bdy_ents ) ) (apply 'and (mapcar; check members of bdy_ents (function (lambda (ele / _segs) ; and get an elev (cond ((= (std-gettype ele) "CIRCLE") ; circle (if (not _elev) (setq _elev (third (std-getval 10 ele))) ) (setq_segs_lst (cons(cons "CIRCLE" ele)_segs_lst ) ) ) ((= (std-gettype ele) "POLYLINE") ; closed; polyline? (if (not _elev) (setq _elev (third (std-getval 10 ele))) ) (if (std-segs-closed-p(setq _segs (std-pline-segs ele)) ) (setq _segs_lst (cons _segs _segs_lst)) ) ) ((= (std-gettype ele) "LWPOLYLINE") ; closed; lwpolyline? (if (not _elev) (setq _elev (std-getval 38 ele)) ) (if (std-segs-closed-p(setq _segs (std-pline-segs ele)) ) (setq _segs_lst (cons _segs _segs_lst)) ) ) (t; seglist? (if (not _elev) (setq _elev 0) ) (if (std-segs-closed-p ele) (setq _segs_lst (cons ele _segs_lst)) ) ) ) ) ) bdy_ents ) ) ); cond and clause => t (setq _segs_lst (reverse _segs_lst) ; since _segs_lst is reverse data_alst (mapcar; of bdy_ents, reverse again (function (lambda (ele) (cond ((= (car ele) "CIRCLE") ; create; data_alst - circle (list '(93 . 1) ; number of edges; this loop '(72 . 2) ; return alst (cons 10 (xy-of (std-getval 10 (cdr ele) ) ) ) (cons 40 (std-getval 40 (cdr ele) ) ) '(50 . 0.0) (cons 51 *pi2*) '(73 . 1) '(97 . 0) ) ); source bdy objects? (not yet) (t; create data_alst - seglist (cons(cons 93 (length ele)) ; numb; er of edges this loop(append (apply 'append (mapcar (function(lambda (seg / ccw_flag ctr ) (cond ( (std-seg-straight-p seg); line edge? (list ' (72 . 1); return alst (cons 10 (xy-of (std-seg-p1 seg) ) ) (cons 11 (xy-of (std-seg-p2 seg) ) ) ) ) (t ; arc; edge? (setq ccw_flag ; ccw? (/ (1+ (std-signum (std-seg-bulge-num seg) ) ) 2 ) ) (append(list ' (72 . 2); return alst (cons10(setq ctr (first (xy-of (std-seg->cir seg) ) )) ) (cons40(second (std-seg->cir seg)) ))(cond ( (zerop ccw_flag); cw (list (cons 50 (- *pi2* (angle ctr (xy-of (std-seg-p1 seg) ) ) ) ) (cons 51 (- *pi2* (angle ctr (xy-of (std-seg-p2 seg) ) ) ) ) ) ) (t ; ccw (list (cons 50 (angle ctr (xy-of (std-seg-p1 seg) ) ) ) (cons 51 (angle ctr (xy-of (std-seg-p2 seg) ) ) ) ) ))(list (cons 73 ccw_flag)) ) ) )) ) ele ) ) '((97 . 0))) ) ) ) ) ); source bdy objects? (not yet) _segs_lst ) data_alst (apply 'append; append data_alst after (mapcar 'cons; consing pathtype flag alst (mapcar 'cons; to each data_alst member (std-make-list (length pathflag_lst) 92) pathflag_lst ) data_alst ) ) opts (append (list '(0 . "HATCH") ; entity type '(100 . "AcDbEntity") (cons 67 (cond ( (std-getval 67 bdy_ents) ); space (t; current; space if seglist (std-bittoggle(getvar "TILEMODE")1 ) ) ) ) '(100 . "AcDbHatch") (list 10 0 0 _elev) ; elevation (cons 210 (cond ((std-getval 210 bdy_ents)); extrusio; n vector (t; current ext vect if seglist (trans '(0 0 1) 1 0 t) ) ) ) '(2 . "SOLID") ; hatch pattern name '(70 . 1); solid fill flag:; 0 - pattern fill; 1 - solid fill '(71 . 0) ); non-associative flag; (cond ((= (std-getval 71 elist) 0); associativity flag:; '((71 . 0))) ; 0 -; non-associative; (t ; 1 -; associative; '((71 . 1))) ; we must use; ole; ) (list (cons 91 (length _segs_lst))); number of bdy; loops data_alst; bdy_ents data; (cond ((= (std-getval 71 elist) 0); ; boundary objs; '((97 . 0)) ;; non-associative only; ); (t ; yes (won't happen); (list '(97 . 1); (cons 330 (std-entity; bdy_ents)))); ) (list '(75 . 0); hatch style:; 0 - normal,; "odd parity"; 1 - hatch outermost; area only; 2 - hatch entire; area, "holes"; included '(76 . 1); hatch pattern type:; 0 - user-defined; 1 - predefined; 2 - custom '(98 . 1); number of seed points '(10 0 0) ) ); seedpoint elist (std-remove-if (function (lambda (_x) (member (car _x) '(7191 92 93 97 330) ) ) ) elist ) ) (cond (t; (= (std-getval 71 elist) 0) ;; non-associative hatch(std-%entmake-template elist opts '() nil) ) (nil; associative hatch (not easy)(list elist opts); return name of new hatch(setq hatch_ent(std-%entmake-template elist opts '() nil) ent_list(std-entget bdy_ents) rct_list(append (std-%group-only 330 ent_list) (list hatch_ent)) 330_list(append; add hatch_ent to existing '((102 . "{ACAD_REACTORS")) ; => 330 ents (mapcar (function (lambda (_ele)(cons 330 _ele) ) ) (cons hatch_ent (std-%group-only 330 ent_list ) ) ) '((102 . "}"))) ent_list(std-remove-if (function (lambda (_x) (member (car _x) ' (102 330) ) ) ) ent_list) ent_list(append ent_list 330_list))(entmod ent_list)(entupd bdy_ents)(foreach ele elist (setqent_list (std-entget ele)330_list (append '((102 . "{ACAD_REACTORS")) (mapcar (function (lambda (_ele) (cons 330 _ele) ) ) (cons grp_ent (std-%group-only 330 ent_list) ) ) '((102 . "}")) )ent_list (std-remove-if (function (lambda (_x)(member (car _x) ' (102 330)) ) ) ent_list )ent_list (append ent_list 330_list ) ) (entmod ent_list)); _ end of foreach(std-entchg bdy_ents nil (append '(102) (std-make-list (length elist) 330) '(102) ) (append '("{ACAD_REACTORS") elist '("}") ))(entupd bdy_ent)(entupd hatch_ent) ) ) ) ));;; (std-entmake-solid elist) - solid entmake --- temporary;;; experimental!(defun std-entmake-solid (elist / opts) (setqopts (list '(0 . "SOLID") '(100 . "AcDbEntity") '(100 . "AcDbTrace"); '(39 . 0.0) ; thickness; '(210 0 0 1) ; extrusion; direction ) ) (std-%entmake-template elist opts '(10 11 12 13) nil));;; experimental!(defun std-entmake-spline (elist pts / opts flag nvert pttype); closed? (setqflag (cond ((cdr (assoc 70 elist))) ((and (assoc 73 elist) (std-segs-closed-p (std-pts->segs pts)))9 ); control points? ((and (assoc 74 elist) (std-segs-closed-p (std-pts->segs pts)))9 ); fit points? (t8 ) ) ); provide number of vertices (setqnvert (if (std-bitsetp 1 flag); fixed(1+ (length pts))(length pts) ) ) (setqopts (list '(0 . "SPLINE") '(100 . "AcDbEntity") '(100 . "AcDbSpline" ) (cons 70 flag); spline flag - bit coded:; 8 - planar, 9 - closed planar '(71 . 3); default degree of spline curve (cond ((assoc 73 elist) (cons 73 nvert) ); # control pts or ((assoc 74 elist) (cons 74 nvert) ); # fit points ) ) ) (setqpttype (cond ((assoc 73 opts) 10 ) ((assoc 74 opts) 11 ) ) ); remove geometry from elist, take; only pts. (setqelist (std-remove-if'(lambda (_x) (member (car _x) '(10 11 73 74)) )elist ) ) (foreach pt pts (setq elist(append elist (list (cons pttype pt))) ) ); point data (std-%entmake-template elist opts nil nil));;; std-entmake-mlinestyle usage example:;;; (setq elist;;; '((2 . "mystyle");;; (3 . "my mlinestyle");;; (62 . 0);;; (70 . 0);;; (71 . 3);;; (49 . -5.0);;; (62 . 256);;; (6 . "bylayer");;; (49 . 0.0);;; (62 . 152);; color;;; (6 . "abe05");; ??;;; (49 . 5.0);;; (62 . 256);;; (6 . "bylayer")));;; (std-entmake-mlinestyle elist)(defun std-entmake-mlinestyle (elist / opts) (std-require "DICT") (setqopts (list '(0 . "MLINESTYLE") '(102 . "{ACAD_REACTORS") (cons 330 (dict-entity "ACAD_MLINESTYLE")) '(102 . "}") ' (100 . "AcDbMlineStyle") '(70 . 0); end cap flag; values: 0 - no caps; 16 - cap first; end; 256 - cap last end; 272 - cap; each end;; see also autocad customization; guide, appendix c -; "acad_mlinestyle group codes"; table for other values; '(62 . 0) ; fill color, if flag; 70 has 1 set (cons 51 (/ pi 2)); start angle (cons 52 (/ pi 2)) ) ); end angle (dictadd (dict-entity "ACAD_MLINESTYLE") (std-getval 2 elist) (std-%entmake-template elist opts '(2 3 71 49 62 6) t) ))(defun std-entmake-xrecord (elist / opts) (setq opts (list '(0 . "XRECORD") '(100 . "AcDbXrecord") '(280 . 1))) (std-%entmake-template elist opts nil t));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign *entmake-symbols*))(setq *entmake-symbols* nil);;; module dependencies:(std-provide "ENTMAKE");;; at first provide it. but before you may;;; call it, be sure to have all supporting;;; functions.(std-require "STDPOINT");;; segment stuff(std-require "STDENT");;; attributes;;; also some list, lisp and init stuff;;; >>cut here ---------------------------------------------- <<cut here;;; $id: dict.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:31:16 rurban>;;; copyright (c) 1999 by david kozina;;; copyright (c) 2000 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; dictionaries as seperate stdlib module;;; a 'dict' dictionary entity may be defined as ename or string, the;;; valid (and in a2000 even case-sensitive) name.;;; status:;;; not fully tested.;;; seperated, new namespace with dict- prefix.;;; so far only querying functions,;;; destructive operations (dict-put) and converter functions;;; later. see http://members.tripod.com/~vnestr/savedata.lsp for a;;; commercial version.;;; ===================================================================73;;; $log: dict.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; 2000-09-23 19:44:54 rurban;;; added dict-get, dict-put, dict-list->xdata, dict->xdata->list;;; (dict-list->xdata only non-recursive yet);;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; 2000-07-07 12:02:18 rurban;;; added std-%(un)protect-assign wrapper;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; internal functions start with std-%;;; ===================================================================73(if std-%unprotect-assign (std-%unprotect-assign '(dict-version dict-pdict-entity dict-search dict-valdict-list dict-names dict-getdict-put dict-list->xdata dict->xdata->list ) ))(setq *dict-version* 0.4)(defun dict-version () *dict-version*);;; -------------------------------------------------------------------73;;; (dict-p dict);;; is 'dict' one of the dictionaries in (namedobjdict)?;;; 'dict' may be a dictionary entity or valid name;;; usage: (dict-p "acad_group") => t;;; (dict-p "acad_mlinestyle") => t;;; (dict-p (namedobjdict)) => t;;; (dict-p "group") => nil;;; (note that the name must be valid);;; (dict-p "mlinestyle") => nil;;; (dict-p "goober") => nil;;; -------------------------------------------------------------------73(defun dict-p (dict) (cond ((and (std-enamep dict) (member dict (mapcar (function cdr) (std-entget (namedobjdict)) ) ) ) ) ((and (stringp dict) (dictsearch (namedobjdict) dict) ) ) ));;; -------------------------------------------------------------------73;;; (dict-entity dict);;; return the dictionary entity name of 'dict' if valid, else return nil;;; 'dict' may be a dictionary entity or valid name;;; usage: (dict-entity "acad_group") => <entity name: xxxx>;;; (dict-entity "acad_mlinestyle") => <entity name: yyyy>;;; (dict-entity (namedobjdict)) => <entity name: zzzz>;;; (dict-entity "group") => nil invalid name;;; (dict-entity "mlinestyle") => nil;;; (dict-entity "goober") => nil;;; -------------------------------------------------------------------73(defun dict-entity (dict) (cond ((and (std-enamep dict); this should better check group 350; only (member dict (mapcar (function cdr) (std-entget (namedobjdict)) ) ) ) dict ) ((stringp dict) (std-entity (dictsearch (namedobjdict) dict)) ) ));;; -------------------------------------------------------------------73;;; (dict-search dict name);;; return a dictionary entry alst upon valid input, else return nil;;; 'dict' may be a dictionary entity or valid name;;; -------------------------------------------------------------------73(defun dict-search (dict name) (if (and(setq dict (dict-entity dict))(stringp name) ) (dictsearch dict name) ));;; -------------------------------------------------------------------73;;; (dict-val grp dict name);;; return dxf group value of a dictionary entry alst upon valid input,;;; else return nil;;; 'dict' may be a dictionary entity or valid name;;; -------------------------------------------------------------------73(defun dict-val(grp dict name) (std-getval grp (dict-search dict name)));;; -------------------------------------------------------------------73;;; (dict-list dict);;; return a dictionary alist or nil;;; 'dict' may be a dictionary entity or valid name;;; -------------------------------------------------------------------73(defun dict-list (dict / alst lst) (cond; complicated way to get alst: force; the first two cond's ((and (std-enamep dict); is dict one of the dictionary; entities (member dict (mapcar (function cdr) (std-entget (namedobjdict)) ) ) (setq alst (entget dict)) nil ) ); always nil ((and (stringp dict); is dict a dictionary name? (setq alst (dictsearch (namedobjdict) dict)) nil ) ); always nil; get name and entities from alst ((setq lst (mapcar (function cdr) (member (assoc 3 alst) alst) ) ) (mapcar (function (lambda (a b) (cons a b) ) ); build alist (std-remove-if-not (function stringp) lst) (std-remove-if (function stringp) lst) ) ) ));;; -------------------------------------------------------------------73;;; (dict-names dict);;; return a dictionary name strlst or nil;;; 'dict' may be a dictionary entity or valid name;;; -------------------------------------------------------------------73(defun dict-names (_dict) (mapcar (function car) (dict-list _dict) ));;; -------------------------------------------------------------------73;;; by reini urban;;; status: not tested yet.;;; (dict-get dict key);;; similar to vladimir's version.;;; see http://members.tripod.com/~vnestr/savedata.lsp;;; decode xdata-alike, dwg-friendly alist data from xrecords in;;; a dictionary.;;; 'dict' may be a dictionary entity or valid name(defun dict-get(dict key / x) (setq x (cdr (member '(100 . "AcDbXrecord") (dict-search dict key)))); r; emove group 280 in r15 (dict-xdata->list (if(= (caar x) 280) (cdr x) x ) ));;; (dict-put dict key value);;; similar to vladimir's version. encode arbitrary data into;;; xdata-alike, dwg-friendly xrecords.;;; the dictionary (a string then) is created automatically if not;;; existing. dict may be a dictionary entity or valid name(defun dict-put(dict key value) (if (dict-search dict key) (dictremove (dict-entity dict) key) ) (if (and(stringp dict)(not (dict-entity dict)) ) (setq dict; create new dict (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY")(100 . "AcDbDictionary") ) ) ) ) ) (dictadd (dict-entity dict) key (entmakex; maybe use std-entmake-xrecord (append (list '(0 . "XRECORD") ' (100 . "AcDbXrecord") ) (if (std-ver-r2000-p) '((280 . 1)) ); keep existing (dict-list->xdata value t) ) ) ));;; encode < 1000;;; eed-get/eed-put are similar methods for entity specific data.;;; non-nil <1000 encodes to dxf keys < 1000 for xrecords in dictionaries,;;; nil to xdata values > 1000 for extended entity data.;;; no nested lists so far, no recursion into () besides numbers;;; (dict-list->xdata '(20 "data") t);;; => ((2 . "{")(40 . 20) (0 . "data")(2 . "}"));;; (dict-list->xdata '(20 "data") nil);;; => ((1002 . "{")(1070 . 20) (1000 . "data")(1002 . "}"))(defun dict-list->xdata(xdata <1000) (apply 'append (list (if <1000 '((2 . "{")) '((1002 . "{")) ); no recursion here (if <1000 (mapcar 'dict-%xdata-encode<1000 xdata ) (mapcar 'dict-%xdata-encode xdata ) ) (if <1000 '((2 . "}")) '((1002 . "}")) ) ) ));;; (dict->xdata->list '((2 . "{")(40 . 20) (0 . "data")(2 . "}")));;; => (20 "data");;; only flat, no nested lists! no recursion into "{" yet.(defun dict-xdata->list(xdata) (cond ((and (equal (car xdata) '(2 . "{")) (equal (last xdata) '(2 . "}")) ) (if (member '(2 . "{") (cdr xdata)) (std-warn "nested xdata lists not yet supported") ) (mapcar (function dict-%xdata-decode<1000) (cdr (std-butlast xdata)) ) ) ((and (equal (car xdata) '(1002 . "{")) (equal (last xdata) '(1002 . "}")) ) (if (member '(1002 . "{") (cdr xdata)) (std-warn "nested xdata lists not yet supported") ) (mapcar (function dict-%xdata-decode) (cdr (std-butlast xdata)) ) ) ));;; todo: maybe improve fix for longint: 1041<=>1071(defun dict-%xdata-encode<1000 (x) (if (= (car (setq x (dict-%xdata-encode x))) 1005) (cons 2 (cdr x)); handle as string, but how to mark; as entity? (cons (- (car x) 1000) (cdr x)) ))(defun dict-%xdata-encode (x) (cond ((null x) '(1000 . "*NIL*") ); for easier debugging ((stringp x) (cons 1000 x) ) ((std-pointp x) (cons 1010 x) ) ((eq (type x) 'real) (cons 1040 x) ) ((and (numberp x) (< -32768 x 32767) ) (cons 1070 x) ) ((numberp x) (cons 1041 (float x)) ); instead of (1071 . (fix x)); handles, not decodable! (for nice; to have in xdata) ((eq (type x) 'ename) (cons 1005 (std-gethandle x)) ) ((listp x) (dict-list->xdata x <1000) ) (t (std-error (list "unsupported xdata type: " x)) ) ))(defun dict-%xdata-decode (x) (cond ((null x) nil ) ((equal x '(1000 . "*NIL*")) nil ) ((= (car x) 1041) (fix (cdr x)) ); how to detect handles? (t (cdr x) ) ))(defun dict-%xdata-decode<1000 (x) (cond ((null x) nil ) ((equal x '(0 . "*NIL*")) nil ) ((= (car x) 41) (fix (cdr x)) ); how to detect handles? (t (cdr x) ) ));;; recursive version(defun dict-xdata->list-rec (xdata / tok) (cond ((and (equal (car xdata) '(2 . "{")) (equal (last xdata) '(2 . "}")) ) (car (dict-%xdata-decode-rec)) ) ((and (equal (car xdata) '(1002 . "{")) (equal (last xdata) '(1002 . "}")) ) (car (dict-%xdata-decode-rec)) ) ))(defun dict-%xdata-decode-rec (/ tok) (if (atom xdata) xdata (if(not (equal (setq tok (std-pop 'xdata)) '(1002 . "}") )) (cons (if(equal tok '(1002 . "{")) (dict-%xdata-decode-rec) (dict-%xdata-decode tok) ) (dict-%xdata-decode-rec) ) ) ))(defun dict-%xdata-decode-rec<1000 (/ tok) (if (atom xdata) xdata (if(not (equal (setq tok (std-pop 'xdata)) '(2 . "}") )) (cons (if(equal tok '(2 . "{")) (dict-%xdata-decode-rec) (dict-%xdata-decode<1000 tok) ) (dict-%xdata-decode-rec) ) ) ));;; -------------------------------------------------------------------73(if std-%protect-assign (std-%protect-assign '(dict-version dict-pdict-entity dict-search dict-valdict-list dict-names dict-getdict-put dict-list->xdata dict->xdata->list ) ));;; module dependencies:(if std-provide (progn (std-provide "DICT"); at first provide it. but before; you may; call it, be sure to have all; supporting; functions. (std-require "STDLIST") (std-require "STDENT") ));;; >>cut here ---------------------------------------------- <<cut here;;; $id: stdlib.lsp 0.5006 2000/12/31 10:59:00 rurban rel $ -*-autolisp-*-;;; time-stamp: <2000-12-31 11:32:50 rurban>;;; copyright (c) 1998,99 by reini urban;;; available for free at http://xarch.tu-graz.ac.at/autocad/stdlib/;;; see disclaimer for permissions;;; --------------------------------------------------------------------;;; handy loader for the main stdlib functions;;; status:;;; not complete yet!;;; see stdlib.hlp for the complete documentation;;; logical layout for the stdlib;;; ===================================================================73;;; $log: stdlib.lsp $;;; revision 0.5006 2000/12/31 10:59:00 rurban;;; release, see changes;;;;;; revision 0.5004 2000/09/20 12:50:35 rurban;;; 0.5004 release, see changes;;;;;; revision 0.5003 2000/07/11 15:59:52 rurban;;; 0.5003 release, see changes;;;;;; revision 0.5002 2000/06/19 08:31:18 rurban;;; 0.5002 release, see changes;;;;;; revision 0.5000 2000/05/14 17:41:36 rurban;;; 0.5 release;;;;;; -------------------------------------------------------------------73;;; dealing with projects;;; this code is needed for closing a project definition.;;; last file of a project or first file or dynamic module loading.;;; this is for the project part:;;; now we may safely call our top-level stuff.;;; remove std-require delaying for further stdlib calls.;;; we may do this here because with projects this will be the last file.;;; without packaged projects this will be the first file.(if *std:%project* (progn (stdlib-project-init); stdinit2; print the list if delayed modules; (for debugging only) (if(and *load-verbose* *std:modules-delayed*) (std-princ(list (std-msg "\nLoaded Modules: ") (std-modules) "\n") ) ) (setq *std:%project* nil) ));;; better put this to your acad.lsp;;; must be customized, may be set by the calling application.;;; best is first defining the stdlib location.;;; here we need only the stdlib path anyway, with \\ at the end,;;; the full definition can be given after having loaded all modules;;; (if (not (boundp '*module-path*));;; (setq *module-path* '("l:\\src\\stdlib\\")));;; -------------------------------------------------------------------73;;; load the first required module(if (not std-%simple-require) (load (strcat (car *module-path*) "STDINIT") 'error));;; loading scheme:;;; we first load all with std-%simple-require;;; after loaded stdlisp and stdfile we can savely use std-require.;;; a faster method is obviously to define *module-path* and just load;;; the fas or vlx(std-%simple-require "STDSTR")(std-%simple-require "STDLIST")(std-%simple-require "STDLISP")(std-%simple-require "STDMATH");;; load it before stdfile for same flag;;; checking on errors(std-%simple-require "STDFILE")(std-%simple-require "STDPOINT")(std-%simple-require "STDINIT2")(setq *print-length* 25; don't print long lists to the; console *print-level* 4)(if (std-acad-connection-p) (progn (std-require "STDINPUT") (std-require "STDTBL") (std-require "STDENT") (std-require "STDMISC") (std-require "STDERROR") (std-require "ENTMAKE") ))(std-require "STDTIME");;; so far acad independent(std-provide "STDLIB");;; include this also? only for vl provided so far(if (and (std-vl-p) (>= (std-ver-num) 12) ) (progn; (std-require "binio"); (std-require "inifile") (std-require "REGISTRY") ));;; here we need load to force redefinitions(if (not (std-acad-connection-p)) (std-load "STANDALONE"));;; (if (std-vlide-p);;; (progn;;; (std-require "stdinit-ide");;; (std-%protect-allsyms);;; ));;; add customized paths, these are searched with std-load;;; before the acad library path;;; >>cut here ---------------------------------------------- <<cut here
