Topic: - SIMPLE AUTOLISP (NON COMMAND) FUNCTIONS (HELPER-SUBFUNCTIONS) - STUDY TOPIC -

[ribarm]

So, I am starting this topic regarding research (solving problems) in area of writing short and simple, but useful non command functions that may/colud be used in occasional process of writing more complex and longer code structures regarding solving more difficult programming tasks that may occur if one is interested in using computational power of software that supports usage of AutoLISP programming language (for ex. AutoCAD, BricsCAD, ...) ...

 

SIMPLE "RECURSION" EXAMPLES BY M.R. involving none, one or more arguments, none, one or more variables, none, one or more helper sub functions :


OPERATING WITH NUMBER(S) :

;;; we start with simple reducing recursion which outputs list of numbers - array generated from starting input positive number grater than 0

(defun f ( n )
  (if (> n 0) ;;; main condition and at the same time, terminator of reducing down number recursion
    (cons n (f (1- n)))
  )
)

;;; evaluation :

: (f 5)
(5 4 3 2 1)

;;; now from 1 to 5 - adding up recursion

1. simple reverse output of reducing recurion described initially; recursive reducing down number function was used as helper function and result is reversed

(defun f ( n / ff )
  (defun ff ( k )
    (if (> k 0)
      (cons k (ff (1- k)))
    )
  )
  (reverse (ff n))
)

;;; evaluation :

: (f 5)
(1 2 3 4 5)
: !ff
nil

2. transforming - operand to + by supplying negative starting number (- n) [in other words (k) looked through helper function] as first argument to similar helper function now with 2 arguments : second argument was added (m); (1- becomes 1+ : [(1- n) becomes (1+ k)]); main condition (> n 0) bocomes opposite (< k 0) - now refering to negative values that are increasing; and with each pass recursion is cons'-ing positive number by addition (1+ n) [in other words (1+ m) looked through helper function]; second argument is just here for confirmation of the same adding value with each pass - its value is n [m through (ff)]

(defun f ( n / ff )
  (defun ff ( k m )
    (if (< k 0)
      (cons (+ 1 m k) (ff (1+ k) m))
    )
  )
  (ff (- n) n)
)

;;; evaluation :

: (f 5)
(1 2 3 4 5)
: !ff
nil

3. helper dummy variable (k) initially set to 1 is used in adding up number recursion that calls itself exactly the same way [(f n)] until main condition { [(< k (1+ n))] involving increasing variable (k) [(1+ k)] and initially called value (n) which always remains the same unchanged } fails, terminating process

(defun f ( n )
  (setq k (if k (1+ k) 1))
  (if (< k (1+ n))
    (cons k (f n))
    (setq k nil)
  )
)

;;; evaluation :

: (f 5)
(1 2 3 4 5)
: !k
nil

4. helper dummy function with 2 arguments (ff k n) is used, but it's recursing by adding up number - first argument is increasing and second stays the same - comparison value always remains the same

(defun f ( n / ff )
  (defun ff ( k n )
    (if (< k (1+ n))
      (cons k (ff (1+ k) n))
    )
  )
  (ff 1 n)
)

;;; evaluation :

: (f 5)
(1 2 3 4 5)
: !ff
nil


OPERATING WITH LIST(S) :

;;; we start with simple list length reducing recursion which outputs result the same as input

(defun f ( l )
  (if l ;;; there is still 1 element present in l [ optional (> (length l) 0) ]
    (cons (car l) (f (cdr l))) ;;; (f (cdr l)) - simple list length reducing recursion
  )
)

;;; evaluation :

: (f '(a1 a2 a3 a4))
(A1 A2 A3 A4)

;;; now consider this example with just normal recursion - list length stays the same each pass - we only reverse list each time

(defun ff ( l )
  (if (> (length l) 1) ;;; there are still 2 elements present in list (l); if list (l) is defined such as (equal l '(a1 a2)), this condition is always T if we don't reduce list length in next statements/expressions that follows (then) condition of (if) function
    (cons (car l) (ff (reverse l))) ;;; this recursion will loop endlessly - there is no reducing factor in evaluation of recursion
  )
)

;;; so we need condition to terminate ff function ; for ex. this is how it works without terminator :
;;; if (equal l '(a1)) , when starting (ff l) , in processing return would be nil as initial condition (> (length '(a1)) 1) is not true, so nil would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2)) , when starting (ff l) , in processing return would be '(a1 a2 a1 a2 a1 a2 ... ) without termination - nothing would be printed as result and return of evaluation couldn't be passed in meaningful form...
;;; if (equal l '(a1 a2 a3)) , when starting (ff l) , in processing return would be '(a1 a3 a1 a3 a1 a3 ... ) without termination - nothing would be printed as result and return of evaluation couldn't be passed in meaningful form...

;;; evaluation (output in BricsCAD) :

; error : LISP - lisp recursion stack limit exceeded

;;; lets try to implement termination condition

(defun ff ( l )
  (if
    (and
      (> (length l) 1) ;;; first condition from previous example (this is used as terminator in reducing recursion when main list length is lesser with each pass - something like : (ff (cdr l)), or (ff (cddr l)), or (ff (vl-remove [(car l)/(last l)] l)) - note here that if l had multiple [(car l)/(last l)] occurences, all of them would be trimmed in next pass, or more strict - removing duplicates not allowed (ff (butlast l)), where (defun butlast ( l ) (reverse (cdr (reverse l))) )
      (< (setq n (if n (1+ n) 1)) 4) ;;; termination condition (this is used in building - cons'ing recursion)
    )
    (cons (car l) (ff (reverse l)))
    (setq n nil)
  )
)

;;; if (equal l '(a1)) , when starting (ff l) , in processing return would be nil as initial condition (> (length '(a1)) 1) is not true, so nil would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2)) , when starting (ff l) , in processing return would be (a1 a2 a1), but some processing happened : '(a1) - first pass, '(a1 a2) - second pass, '(a1 a2 a1) - third pass, and when reaching '(a1 a2 a1 a2) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a2 a1) would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2 a3)) , when starting (ff l) , in processing return would be nil, but some processing happened : '(a1) - first pass, '(a1 a3) - second pass, '(a1 a3 a1) - third pass, and when reaching '(a1 a3 a1 a3) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a3 a1) would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2 a3 a4)) , when starting (ff l) , in processing return would be nil, but some processing happened : '(a1) - first pass, '(a1 a4) - second pass, '(a1 a4 a1) - third pass, and when reaching '(a1 a4 a1 a4) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a4 a1) would be printed as result and return of evaluation can be passed in meaningful form...

;;; now lets try something different (to achieve different result) - we will use SHIFTING procedure instead of sucessive REVESING of list while recursion processes
;;; technique : just replace [ (reverse l) ] with [ (append (cdr l) (list (car l))) ] - normal shifting; [ (append (cddr l) (list (car l) (cadr l))) ] - shifting by 2 elements; generaly SHIFTING : (defun shift ( l n ) (repeat n (setq l (append (cdr l) (list (car l))))) ) / or in opposite direction : (defun shift ( l n ) (repeat n (setq l (cons (last l) (butlast l)))) ) : usage (shift l 3)

(defun ff ( l )
  (if
    (and
      (> (length l) 1) ;;; first condition from previous example (this is used as terminator in reducing recursion when main list length is lesser with each pass - something like : (ff (cdr l)), or (ff (cddr l)), or (ff (vl-remove [(car l)/(last l)] l)) - note here that if l had multiple [(car l)/(last l)] occurences, all of them would be trimmed in next pass
      (< (setq n (if n (1+ n) 1)) 4) ;;; termination condition (this is used in building - cons'ing recursion)
    )
    (cons (car l) (ff (append (cdr l) (list (car l)))))
    (setq n nil)
  )
)

;;; if (equal l '(a1)) , when starting (ff l) , in processing return would be nil as initial condition (> (length '(a1)) 1) is not true, so nil would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2)) , when starting (ff l) , in processing return would be (a1 a2 a1), but some processing happened : '(a1) - first pass, '(a1 a2) - second pass, '(a1 a2 a1) - third pass, and when reaching '(a1 a2 a1 a2) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a2 a1) would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2 a3)) , when starting (ff l) , in processing return would be (a1 a2 a3), as some processing happened : '(a1) - first pass, '(a1 a2) - second pass, '(a1 a2 a3) - third pass, and when reaching '(a1 a2 a3 a1) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a2 a3) would be printed as result and return of evaluation can be passed in meaningful form...
;;; if (equal l '(a1 a2 a3 a4)) , when starting (ff l) , in processing return would be (a1 a2 a3), as some processing happened : '(a1) - first pass, '(a1 a2) - second pass, '(a1 a2 a3) - third pass, and when reaching '(a1 a2 a3 a4) , termination condition (< (setq n (if n (1+ n) 1)) 4) would not be true, so (a1 a2 a3s) would be printed as result and return of evaluation can be passed in meaningful form...

;;; now lets add more obvious scheme for recursion that combines building cons'ing result and at the same time operates with list in background that is used for aquireing data ; we are now using 2 arguments - to avoid possible needness for localizing and nil-ing normal variables that could be used inside function upon processed execution (arguments always have better practical usage than variables - [arguments - they serve for passing data to the function that is called with passing values at explicite position of corresponding arguments array definition in reference function; variables - they serve for passing data to specified symbol inside reference function (they can built expressions that function uses to return resulting value upon execution))

(defun ff ( l r )
  (if
    (and
      (> (length l) 1) ;;; first condition - in case we are reducing list length through processing...
      (< (length r) 4) ;;; second condition - terminator - it is now referenced on list length of resulting output
    )
    (progn
      (setq r (cons (car l) r)) ;;; cons-ing - building result with data from helper list
      (ff (reverse l) r) ;;; recursing with changed helper list and specified 2nd argument for correct recurse call
    )
    (reverse r) ;;; if conditions aren't met - output resulting list in correct array by reversing built variable... Note : here "r" variable was used in (setq)-ing and buiding list, but as name of variable and initial 2nd argument of (ff) function is the same - there is no need for nil-ing it at the end : every argument of function is evaluated upon execution as nil, despite result-ing output which has valuable data
  )
)

;;; evaluation - (you must supply starting value of argument "r" for resulting list as : "nil" - empty starting list) :

: (ff '(a1) nil)
nil
: !r
nil
: (ff '(a1 a2) nil)
(A1 A2 A1 A2)
: !r
nil
: (ff '(a1 a2 a3) nil)
(A1 A3 A1 A3)
: !r
nil
: (ff '(a1 a2 a3 a4) nil)
(A1 A4 A1 A4)
: !r
nil
: (ff '(a1 a2 a3 a4 a5) nil)
(A1 A5 A1 A5)
: !r
nil

;;; now lets do it more suitable in terms of input/output relations (one list - input; one list - output) :

(defun ff ( l / fff )
  (defun fff ( ll r )
    (if (and (> (length ll) 1) (< (length r) 4)) ;;; this second expression of (and) function [(< (length r) 4)] could be replaced with maybe more suitable expression [(< (length r) (length ll))] involving comparison of lengths of resulting list and initial list - termination occurs when resulting list length matches initial input list length
      (progn (setq r (cons (car ll) r)) (fff (reverse ll) r))
      (reverse r)
    )
  )
  (fff l nil)
)

;;; evaluation :

: (ff '(a1 a2 a3 a4 a5))
(A1 A5 A1 A5)
: !fff
nil



SIMPLE "NON RECURSION" EXAMPLES BY M.R. involving none, one or more arguments, none, one or more variables, none, one or more helper sub functions :


;;; here is the most basic one with building list of numbers in ascending order from 1 upwards :

(defun f ( n / k r )
  (repeat n
    (setq r (cons (setq k (if k (1+ k) 1)) r))
  )
  (reverse r)
)

;;; evaluation :

: (f 5)
(1 2 3 4 5)
: !k
nil
: !r
nil

NOW, YOU MAY CONTINUE WITH YOUR : STUDY EXAMPLES / QUESTIONS / SOLUTIONS / PROBLEMS-TASKS TO BE SOLVED / OPINIONS / COMMENTS / SUGGESTIONS / LINKS (FOR REVISION) / ADVICES ... (AND SO ON, SO ON ...)

IT BEGINS WITH SIMPLE EXAMPLES, BUT TOPIC SHOULD CONTINUE TO GROW - IT SHOULD INCREASE RESEARCH DIFFICULTY ASPECTS IN ALL SPHERES : PROVIDED APPROACHES TO SPECIFIC PROBLEMS, PROVIDED EXAMPLES/SOLUTIONS, PROVIDED NOT SOLVED PROBLEMS/DIFFICULTIES THAT PROVED TO BE IMPORTANT/RELEVANT TASKS TO BE APPLIED IN PROGRAMMING/STUDIED IN THE FUTURE...

[ribarm]

I've pulled this example from library - Alan J. Thompson :

Code - Auto/Visual Lisp: [Select]

1. (defun Intersections ( obj1 obj2 mode )
2.   ;; Return list of intersection(s) between two objects
3.   ;; obj1 - first VLA-Object
4.   ;; obj2 - second VLA-Object
5.   ;; mode - intersection mode (acExtendNone acExtendThisEntity acExtendOtherEntity acExtendBoth)
6.   ;; Alan J. Thompson, 12.13.10
7.   ( (lambda ( foo ) (foo (vlax-invoke obj1 'IntersectWith obj2 mode)))
8.     (lambda ( l )
9.       (if (cddr l)
10.         (cons (list (car l) (cadr l) (caddr l)) (foo (cdddr l)))
11.       )
12.     )
13.   )
14. )
15.  

But I am wondering and having hesitations to decide which variant of my 2 versions is better (pros and cons )

Code - Auto/Visual Lisp: [Select]

1. (defun Intersections ( obj1 obj2 mode / f )
2.   ;; Return list of intersection(s) between two objects
3.   ;; obj1 - first VLA-Object
4.   ;; obj2 - second VLA-Object
5.   ;; mode - intersection mode (acExtendNone acExtendThisEntity acExtendOtherEntity acExtendBoth)
6.   ;; Alan J. Thompson, 12.13.10
7.   ;; M.R. version - slightly different, 24.02.2022.
8.   ( (lambda ( foo l ) (foo l))
9.     (setq f (lambda ( l ) (if (cddr l) (cons (list (car l) (cadr l) (caddr l)) (f (cdddr l)))))) ;;; recursive function - this line is different : (setq f (lambda ( l ) ... ))
10.     (vlax-invoke obj1 'IntersectWith obj2 mode)
11.   )
12. )
13.  
14. ;;; or this one :
15.  
16. (defun Intersections ( obj1 obj2 mode / f )
17.   ;; Return list of intersection(s) between two objects
18.   ;; obj1 - first VLA-Object
19.   ;; obj2 - second VLA-Object
20.   ;; mode - intersection mode (acExtendNone acExtendThisEntity acExtendOtherEntity acExtendBoth)
21.   ;; Alan J. Thompson, 12.13.10
22.   ;; M.R. version - slightly different, 24.02.2022.
23.   ( (lambda ( foo l ) (foo l))
24.     (defun f ( l ) (if (cddr l) (cons (list (car l) (cadr l) (caddr l)) (f (cdddr l))))) ;;; recursive function - this line is different (defun f ( l ) ... )
25.     (vlax-invoke obj1 'IntersectWith obj2 mode)
26.   )
27. )
28.  

[ribarm]

Code - Auto/Visual Lisp: [Select]

1. ;; source link :
2. ;; http://lee-mac.com/columnreference.html#incalpha
3.  
4. ;; Column to Number  -  Lee Mac
5. ;; Converts a column reference into an integer, e.g. AA -> 27
6. ;; c - [str] upper-case string representing column reference
7.  
8. (defun LM:col->num ( c )
9.     (   (lambda ( f ) (f (reverse (vl-string->list c))))
10.         (lambda ( l ) (if l (+ (* 26 (f (cdr l))) (- (car l) 64)) 0))
11.     )
12. )
13.  

;;; evaluation :

: (LM:col->num "ABC")
731

Code - Auto/Visual Lisp: [Select]

1. ;;; EXPLANATORY FORM OF THE SAME FUNCTION - mod. by M.R. for special purposes ;;;
2.  
3. (defun LM:col->num ( f v )
4.       ( (lambda ( ff vv f v ) (ff (reverse (vl-string->list v))))
5.             (lambda ( l ) (if l (+ (* 26 (ff (cdr l))) (- (car l) 64)) 0))
6.             t
7.             f
8.             v
9.       )
10. )
11.  

Code - Auto/Visual Lisp: [Select]

1. ;;; ANALYZE ;;;
2.  
3. (defun LM:col->num ( f v )
4.       ( (lambda ( ff vv f v ) (ff (reverse (vl-string->list v))))
5.         ;;; first (lambda) - arguments are symbols representing : passing functions [ ff ] - any possible expression - , or passing variables [ vv ] - any possible data (lists, numbers, strings, symbols) - , or even passing functions [ f ] - argument of (LM:col->num) main function - , or even passing variables [ v ] - argument of (LM:col->num) main function - next to (lambda)
6.         ;;; expression consists of alisp functions [ (reverse) ], passed functions [ ff ], passed variables [ vv ] , or passing functions [ f ] , or passing variables [ v ] to evaluate on the fly
7.             (lambda ( l ) (if l (+ (* 26 (ff (cdr l))) (- (car l) 64)) 0))
8.             ;;; second (lambda) - here first passing function [ references first argument of parent (lambda) - [ ff ] ] - can be just expression like here, but it can be also evaluating expression like main - first (lambda), for ex.
9.             ;;; colud be written like ( (lambda ( flag ) (if flag (lambda ( l ) (if l (+ (* 26 (ff (cdr l))) (- (car l) 64)) 0)))) T ) ;;; here - flag = T, so evaluation just yields simple expression [ (lambda ( l ) (if l (+ (* 26 (ff (cdr l))) (- (car l) 64)) 0)) ] like original example...
10.             ;;; *** note : can you notice that here (lambda) expression [ expressing [ ff ] function of main (lambda) ] is using passing function [ ff ] - itself - to operate on implemented statements making itself recursive on reduced evaluation of main argument [ l ] - [ (ff (cdr l)) ] - here main argument [ l ] is functional variable explicit only to this expression describing recursive operation it performs, so not to confuse things - it is NOT passing variable - it is NOT similar to [ vv ] of main (lambda), although data it uses here is list of integers that are recursively reducing until (eq l nil) - thus (if l (...) 0), just similar like data bounded to [ vv ] (lists, numbers, strings, symbols)... [ that is similarity with [ vv ], but [ vv ] wasn't used inside main (lambda) as a factor for expressing recursion on itself like [ l ] in second (lambda) - it's merely argument that has feeding purpose to main expression provided by following supplying passing statements for parent - main (lambda)...
11.             t
12.             ;;; first passing variable [ references second argument of parent (lambda) - [ vv ] ]
13.             ;;; as defined expresion of parent - main (lambda) don't uses it - you can put any value you want : t, nil, 1, "s", q, 'a, 1.0, '(a b c), '(1 . 2)
14.             ;;; it could have been omitted in all appearances - compare this explanatory example form with originaly provided form from author...
15.             f
16.             ;;; here we are providing pointer for feeding main (lambda) expression with passing function [ f ] defined by (LM:col->num) main function [ references third argument of parent (lambda) - [ f ] ]
17.             ;;; as defined expresion of parent - main (lambda) and simulatneously - of (LM:col->num) main function , main (lambda) don't uses it - you can put any value you want : t, nil, 1, "s", q, 'a, 1.0, '(a b c), '(1 . 2) and also, because description [ f ] guide us that it should have been expression in form of function, anything could have been expressed (lambda ( %% ) %%), ( (lambda ( $$ ) $$) t )
18.             ;;; it could have been omitted in all appearances - compare this explanatory example form with originaly provided form from author...
19.             v
20.             ;;; similar explanation for passing pointer variable [ references fourth argument of parent (lambda) - compare this explanatory example form with originaly provided form from author - it corresponds exactly to the same like [ c ] in original form... - [ v ] ]
21.       )
22. )
23.  

;;; evaluation - with explanatory example - we must supply all feeding values that are to be passed to evaluation of (LM:col->num) function - you can put any value you want at second feeding value : t, nil, 1, "s", q, 'a, 1.0, '(a b c), '(1 . 2) and also, because description [ f ] guide us that it should have been expression in form of function, anything could have been expressed (lambda ( %% ) %%), ( (lambda ( $$ ) $$) t ) - thus nil - at second place of calling expression :

: (LM:col->num nil "ABC")
731

[ribarm]

In some free time - let's share anyway...

Practice syntax snippets can be useful in some coding occaisons :


: (apply '+ '(1 2 3 4)) = (+ 1 (+ 2 (+ 3 (+ 4))))
10


: (mapcar 'eval (mapcar 'cons (list 'apply 'apply 'apply 'apply) (mapcar 'cons (list '+ '+ '+ '+) (list (list (cons 'list (list 1 2 3 4))) (list (cons 'list (list 2 3 4 5))) (list (cons 'list (list 3 4 5 6))) (list (cons 'list (list 4 5 6 7)))))))
(10 14 18 22)
: (mapcar 'eval (mapcar 'cons (list 'apply 'apply 'apply 'apply) (mapcar 'cons (list '+ '+ '+ '+) (mapcar 'list (mapcar 'cons (list 'list 'list 'list 'list) (list '(1 2 3 4) '(2 3 4 5) '(3 4 5 6) '(4 5 6 7)))))))
(10 14 18 22)
: (mapcar 'eval (mapcar '((x) (cons 'apply x)) (mapcar '((x) (cons '+ x)) (mapcar 'list (mapcar '((x) (cons 'list x)) (list '(1 2 3 4) '(2 3 4 5) '(3 4 5 6) '(4 5 6 7)))))))
(10 14 18 22)


: (apply 'mapcar (cons 'list '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4)))) = (apply 'mapcar (list 'list '(4 5 6 7) '(3 4 5 6) '(2 3 4 5) '(1 2 3 4))) = (mapcar '((a b c d) (list a b c d)) '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) = (list (mapcar 'car '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar 'cadr '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar 'caddr '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar 'cadddr '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4)))) = (list (mapcar '((x) (nth 0 x)) '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar '((x) (nth 1 x)) '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar '((x) (nth 2 x)) '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))) (mapcar '((x) (nth 3 x)) '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))))
((4 3 2 1) (5 4 3 2) (6 5 4 3) (7 6 5 4))

;;; not exactly the same - result matches the sample maybe and only maybe if list length equals to length of each sublists ;;;
: (mapcar '((x) (setq n (if (not n) 0 (1+ n))) (mapcar '((y) (nth n y)) l)) (setq l '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))))
((4 3 2 1) (5 4 3 2) (6 5 4 3) (7 6 5 4))
;;; and here is the proof :
: (apply 'mapcar (list 'list '(5 6 7 '(4 5 6 7) '(3 4 5 6) '(2 3 4 5) '(1 2 3 4)))
((5 4 3 2 1) (6 5 4 3 2) (7 6 5 4 3) (8 7 6 5 4))
: (mapcar '((x) (setq n (if (not n) 0 (1+ n))) (mapcar '((y) (nth n y)) l)) (setq l '((5 6 7 (4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))))
((5 4 3 2 1) (6 5 4 3 2) (7 6 5 4 3) (8 7 6 5 4) (NIL NIL NIL NIL NIL))


[ THIS ONE WAS OUT OF CONTEXT - JUST FOR EXPERIMENTING ]
: (mapcar '((x) (if (equal x (cadr l)) (setq m t)) (mapcar '((y) (nth (setq n (if (not n) 0 (1+ n))) y)) (if (not m) l (setq l (append (cdr l) (list (car l))))))) (setq l '((4 5 6 7) (3 4 5 6) (2 3 4 5) (1 2 3 4))))
((4 3 2 1) (3 2 1 4) (2 1 4 3) (1 4 3 2))

[ribarm]

;;; - GENERAL EXPLANATION OF (APPLY) AUTOLISP FUNCTION - ;;;
;;; AVOID USING LAMBDA FUNCTION WITH MANY ARGUMENTS ;;;

;|
: (apply '+ (list 1 2 3))
6
: (apply '(lambda ( x y z ) (+ x (+ y (+ z)))) (list 1 2 3)) ;;; (+ x (+ y (+ z))) - this was my initial thought of how (apply) works, but it's wrong - should be actually from left to right - explained later
6
|;

;;; GENERAL FUNCTION - 4 ARGUMENTS : fc - operator/alisp function/lambda ( + , - , * , / , princ , prompt , ... ) ; s - main argument to which 'f is to be applied sucessively ( ancestor ) ; m - second main argument which is addend ( successor ) ; k - coefficient that works with both main arguments and operator...
(defun func (fc s m k / *s* *k*)
  (setq ss (if *s* *s* s)
        mm m
        *k* k
        kk (if *k* *k* k)
        *s* (fc ss mm kk)
  )
)
;;; HELPER FUNCTIONS : PROCESSFUNC, F AND FF ;;;
(defun processfunc nil
  (if (vl-catch-all-error-p (vl-catch-all-apply 'func (list fc s m (if **k** **k** k))))
    (cond
      ( (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list s m))))
        (fc s m)
      )
      ( (and (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list s)))) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list m)))) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list k)))))
        (cond
          ( (and (eq (type s) 'list) (eq (type m) 'list) (eq (type k) 'list) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (append s m k))))))
            (fc (append s m k))
          )
          ( (and (eq (type s) 'sym) (eq (type m) 'sym) (eq (type k) 'sym) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (and s m k))))))
            (fc (and s m k))
          )
          ( (and (eq (type s) 'str) (eq (type m) 'str) (eq (type k) 'str) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (strcat s m k))))))
            (fc (strcat s m k))
          )
          ( (and (eq (type s) 'int) (eq (type m) 'int) (eq (type k) 'int) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (+ s m k))))))
            (fc (+ s m k))
          )
          ( (and (eq (type s) 'int) (eq (type m) 'int) (eq (type k) 'int) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (logand (logand s m) k))))))
            (fc (logand s m k))
          )
          ( (and (numberp s) (numberp m) (numberp k) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (+ s m k))))))
            (fc (+ s m k))
          )
        )
      )
      ( (and (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list s)))) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list m)))))
        (cond
          ( (and (eq (type s) 'list) (eq (type m) 'list) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (append s m))))))
            (fc (append s m))
          )
          ( (and (eq (type s) 'sym) (eq (type m) 'sym) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (and s m))))))
            (fc (and s m))
          )
          ( (and (eq (type s) 'str) (eq (type m) 'str) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (strcat s m))))))
            (fc (strcat s m))
          )
          ( (and (eq (type s) 'int) (eq (type m) 'int) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (+ s m))))))
            (fc (+ s m))
          )
          ( (and (eq (type s) 'int) (eq (type m) 'int) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (logand s m))))))
            (fc (logand s m))
          )
          ( (and (numberp s) (numberp m) (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list (+ s m))))))
            (fc (+ s m))
          )
        )
      )
      ( (not (vl-catch-all-error-p (vl-catch-all-apply 'fc (list s))))
        (fc s)
      )
    )
    (func fc s m (if **k** **k** k))
  )
)
(defun f (s / m)
  (if **k** (setq k **k**))
  (cond
    ((eq (type s) 'list) (setq m (list))) ((eq (type s) 'sym) (setq m 'm)) ((eq (type s) 'str) (setq m "")) ((numberp s)
      (setq m
        (cond
          ((and (not (zerop k)) (equal s (* (apply 'ff (list s 1.0)) k) 1e-6)) 1.0) ((and (not (zerop k)) (equal s (/ (apply 'ff (list s 1.0)) k) 1e-6)) 1.0) ((equal s (+ (apply 'ff (list s 0.0)) k) 1e-6) 0.0) ((equal s (- (apply 'ff (list s 0.0)) k) 1e-6) 0.0)
        )
      )
    )
  )
  (processfunc)
) ;;; F - single argument
(defun ff (s m)
  (processfunc)
) ;;; FF - double argument
;;; INDEPENDENT HELPER FUNCTION ;;;
(defun boundfunc (boundlst / r)
  (progn
    (setq r (mapcar (function read) (mapcar (function (lambda (x) (setq *n* (if (not *n*) 1 (1+ *n*))) (strcat "***" (itoa *n*) "***"))) boundlst))) (setq *n* nil) r
  )
)

;;; MAIN SUB FUNCTIONS ;;;

(defun applylst-desc (func fc k lst / argl **k** r)
  (setq argl (boundfunc lst) **k** k)
  (read (vl-prin1-to-string (append (cons 'lambda (list argl)) (list
                                      (progn
                                        (mapcar '(lambda (***q*** / a)
                                                   (progn
                                                     (setq a (read ***q***)) (if (not r)
                                                       (setq r
                                                             (append (list (if (numberp (car lst)) '+ 'f)) (if (vl-catch-all-error-p (vl-catch-all-apply (if (numberp (car lst)) '+ 'f) (list a))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a nil))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a t))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a ""))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a " "))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a 1))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a 0))) (list a) (list a 0)) (list a 1)) (list a " ")) (list a "")) (list a t)) (list a nil)) (list a))) r (append (list 'ff) (list r) (list
                                                                       (cond
                                                                         ((eq (type (car lst)) 'list)
                                                                           (cond
                                                                             ((equal (car lst) (apply 'ff (list (car lst) (list))) 1e-6) (list)) ((equal (car lst) (apply 'ff (list (car lst) nil)) 1e-6) nil)
                                                                           )
                                                                         )
                                                                         ((eq (type (car lst)) 'sym)
                                                                           (cond
                                                                             ((equal (car lst) (apply 'ff (list (car lst) t))) t) ((equal (car lst) (apply 'ff (list (car lst) nil))) nil)
                                                                           )
                                                                         )
                                                                         ((eq (type (car lst)) 'str)
                                                                           (cond
                                                                             ((equal (car lst) (apply 'ff (list (car lst) ""))) "") ((equal (car lst) (apply 'ff (list (car lst) " "))) " ")
                                                                           )
                                                                         )
                                                                         ((numberp (car lst))
                                                                           (cond
                                                                             ((and (not (zerop k)) (equal (car lst) (* (apply 'ff (list (car lst) 1.0)) k) 1e-6)) 1.0) ((and (not (zerop k)) (equal (car lst) (/ (apply 'ff (list (car lst) 1.0)) k) 1e-6)) 1.0) ((equal (car lst) (+ (apply 'ff (list (car lst) 0.0)) k) 1e-6) 0.0) ((equal (car lst) (- (apply 'ff (list (car lst) 0.0)) k) 1e-6) 0.0)
                                                                           )
                                                                         )
                                                                       )
                                                                     )
                                                             )
                                                       )
                                                       (setq r (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list r a))) (cons 'ff (list (list 'f r) (list 'f a))) (append (list 'ff) (list r) (list a))))
                                                     )
                                                     nil
                                                   )
                                                 )
                                                (mapcar 'vl-symbol-name argl)
                                        )
                                        r
                                      )
                                    )
                            )
        )
  )
)  ;;; Preview version (desc) ;;;

(defun applylst (func fc k lst / argl **k** r)
  (setq argl (boundfunc lst) **k** k)
  (apply (eval (append (cons 'lambda (list argl)) (list
                         (progn
                           (mapcar '(lambda (***q*** / a)
                                      (progn
                                        (setq a (read ***q***)) (if (not r)
                                          (setq r
                                                (append (list (if (numberp (car lst)) '+ 'f)) (if (vl-catch-all-error-p (vl-catch-all-apply (if (numberp (car lst)) '+ 'f) (list a))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a nil))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a t))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a ""))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a " "))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a 1))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list a 0))) (list a) (list a 0)) (list a 1)) (list a " ")) (list a "")) (list a t)) (list a nil)) (list a))) r (append (list 'ff) (list r) (list
                                                          (cond
                                                            ((eq (type (car lst)) 'list)
                                                              (cond
                                                                ((equal (car lst) (apply 'ff (list (car lst) (list))) 1e-6) (list)) ((equal (car lst) (apply 'ff (list (car lst) nil)) 1e-6) nil)
                                                              )
                                                            )
                                                            ((eq (type (car lst)) 'sym)
                                                              (cond
                                                                ((equal (car lst) (apply 'ff (list (car lst) t))) t) ((equal (car lst) (apply 'ff (list (car lst) nil))) nil)
                                                              )
                                                            )
                                                            ((eq (type (car lst)) 'str)
                                                              (cond
                                                                ((equal (car lst) (apply 'ff (list (car lst) ""))) "") ((equal (car lst) (apply 'ff (list (car lst) " "))) " ")
                                                              )
                                                            )
                                                            ((numberp (car lst))
                                                              (cond
                                                                ((and (not (zerop k)) (equal (car lst) (* (apply 'ff (list (car lst) 1.0)) k) 1e-6)) 1.0) ((and (not (zerop k)) (equal (car lst) (/ (apply 'ff (list (car lst) 1.0)) k) 1e-6)) 1.0) ((equal (car lst) (+ (apply 'ff (list (car lst) 0.0)) k) 1e-6) 0.0) ((equal (car lst) (- (apply 'ff (list (car lst) 0.0)) k) 1e-6) 0.0)
                                                              )
                                                            )
                                                          )
                                                        )
                                                )
                                          )
                                          (setq r (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list r a))) (cons 'ff (list (list 'f r) (list 'f a))) (append (list 'ff) (list r) (list a))))
                                        )
                                        nil
                                      )
                                    )
                                   (mapcar 'vl-symbol-name argl)
                           )
                           r
                         )
                       )
               )
         )
         lst
  )
)  ;;; Main function ;;;

;|
;;; This is what should we get :
: (apply '* '(1 2 3 4 5))
120
: (apply '/ '(1 2 3 4 5))
0
: (apply '/ '(1.0 2.0 3.0 4.0 5.0))
0.00833333333333333
: (apply '+ '(1 2 3 4 5))
15
: (apply '- '(1 2 3 4 5))
-13
: (* (* (* (* (+ 1) 2) 3) 4) 5)
120
: (/ (/ (/ (/ (+ 1) 2) 3) 4) 5)
0
: (+ (+ (+ (+ (+ 1) 2) 3) 4) 5)
15
: (- (- (- (- (+ 1) 2) 3) 4) 5)
-13
: (applylst-desc func + 0.0 '(1 2 3 4 5))
(LAMBDA (***1*** ***2*** ***3*** ***4*** ***5***) (FF (FF (FF (FF (FF (+ ***1***) 0.0) ***2***) ***3***) ***4***) ***5***))
: (applylst-desc func - 0.0 '(1 2 3 4 5))
(LAMBDA (***1*** ***2*** ***3*** ***4*** ***5***) (FF (FF (FF (FF (FF (+ ***1***) 0.0) ***2***) ***3***) ***4***) ***5***))
: (applylst-desc func * 1.0 '(1 2 3 4 5))
(LAMBDA (***1*** ***2*** ***3*** ***4*** ***5***) (FF (FF (FF (FF (FF (+ ***1***) 1.0) ***2***) ***3***) ***4***) ***5***))
: (applylst-desc func / 1.0 '(1 2 3 4 5))
(LAMBDA (***1*** ***2*** ***3*** ***4*** ***5***) (FF (FF (FF (FF (FF (+ ***1***) 1.0) ***2***) ***3***) ***4***) ***5***))
: (applylst func * 1.0 '(1 2 3 4 5)) ;;; k = 1.0 - neutral coefficient for multiplication/division
120.0
: (applylst func / 1.0 '(1 2 3 4 5)) ;;; k = 1.0 - neutral coefficient for multiplication/division
0.00833333333333333
: (applylst func + 0.0 '(1 2 3 4 5)) ;;; k = 0.0 - neutral coefficient for addition/subtraction
15.0
: (applylst func - 0.0 '(1 2 3 4 5)) ;;; k = 0.0 - neutral coefficient for addition/subtraction
-13.0

: (applylst func * 0.5 '(1.0 2.0 3.0 4.0 5.0))
3.75
: (applylst func * 1.0 '(1.0 2.0 3.0 4.0 5.0)) ;;; which is correct - like (applylst '* '(1 2 3 4 5)) = 120
120.0

: (applylst-desc func strcat "" '("1" "2" "3" "4" "5"))
(LAMBDA (***1*** ***2*** ***3*** ***4*** ***5***) (FF (FF (FF (FF (FF (F ***1***) "") ***2***) ***3***) ***4***) ***5***))
: (applylst func strcat "" '("1" "2" "3" "4" "5"))
"12345"
: (applylst func princ "" '("1" "2" "3" "4" "5"))
***1***M111(FF (F ***1***) )***2***(FF (FF (F ***1***) ) ***2***)***3***(FF (FF (FF (F ***1***) ) ***2***) ***3***)***4***(FF (FF (FF (FF (F ***1***) ) ***2***) ***3***) ***4***)***5***111111121212123123123123412341234123451234512345"12345"
: (defun _princ ( s ) (setq fc princ) (if (vl-catch-all-error-p (vl-catch-all-apply 'f (list s))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list s m))) (progn (setq m "") (eval (f s))) (eval (ff s m))) (eval (f s))))
_PRINC
: (applylst func _princ "" '("1" "2" "3" "4" "5"))
***1***M***1***MM111(FF (F ***1***) )***2***(FF (FF (F ***1***) ) ***2***)***3***(FF (FF (FF (F ***1***) ) ***2***) ***3***)***4***(FF (FF (FF (FF (F ***1***) ) ***2***) ***3***) ***4***)***5***111111121212123123123123412341234123451234512345"12345"
: (applylst func prin1 "" '("1" "2" "3" "4" "5"))
***1***M"""1""""""1""1"(FF (F ***1***) "")***2***""(FF (FF (F ***1***) "") ***2***)***3***""(FF (FF (FF (F ***1***) "") ***2***) ***3***)***4***""(FF (FF (FF (FF (F ***1***) "") ***2***) ***3***) ***4***)***5***"""1""""""1""1""1""""""1""1""1""2""""12""12""12""3""""123""123""123""4""""1234""1234""1234""5""""12345""12345""12345"
: (defun _prin1 ( s ) (setq fc prin1) (if (vl-catch-all-error-p (vl-catch-all-apply 'f (list s))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list s m))) (progn (setq m "") (eval (f s))) (eval (ff s m))) (eval (f s))))
_PRIN1
: (applylst func _prin1 "" '("1" "2" "3" "4" "5"))
***1***M""***1***M""M"""1""""""1""1"(FF (F ***1***) "")***2***""(FF (FF (F ***1***) "") ***2***)***3***""(FF (FF (FF (F ***1***) "") ***2***) ***3***)***4***""(FF (FF (FF (FF (F ***1***) "") ***2***) ***3***) ***4***)***5***"""1""""""1""1""1""""""1""1""1""2""""12""12""12""3""""123""123""123""4""""1234""1234""1234""5""""12345""12345""12345"
: (applylst func print "" '("1" "2" "3" "4" "5"))
***1***M
***1***M
1
1
1
1
(FF (F ***1***) NIL)***2***
(FF (F ***1***) NIL)***2***
(FF (FF (F ***1***) NIL) ***2***)***3***
(FF (FF (F ***1***) NIL) ***2***)***3***
(FF (FF (FF (F ***1***) NIL) ***2***) ***3***)***4***
(FF (FF (FF (F ***1***) NIL) ***2***) ***3***)***4***
(FF (FF (FF (FF (F ***1***) NIL) ***2***) ***3***) ***4***)***5***
(FF (FF (FF (FF (F ***1***) NIL) ***2***) ***3***) ***4***)***5***
1
1
NIL
NIL
2
2
3
3
4
4
5
5
""
: (defun _print ( s ) (setq fc print) (if (vl-catch-all-error-p (vl-catch-all-apply 'f (list s))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list s m))) (progn (setq m "") (eval (f s))) (eval (ff s m))) (eval (f s))))
_PRINT
: (applylst func _print "" '("1" "2" "3" "4" "5"))
***1***M
***1***M
***1***M
***1***M

M
"" 1
1
1
1
(FF (F ***1***) NIL)***2***
(FF (F ***1***) NIL)***2***
(FF (FF (F ***1***) NIL) ***2***)***3***
(FF (FF (F ***1***) NIL) ***2***)***3***
(FF (FF (FF (F ***1***) NIL) ***2***) ***3***)***4***
(FF (FF (FF (F ***1***) NIL) ***2***) ***3***)***4***
(FF (FF (FF (FF (F ***1***) NIL) ***2***) ***3***) ***4***)***5***
(FF (FF (FF (FF (F ***1***) NIL) ***2***) ***3***) ***4***)***5***
1
1
NIL
NIL
2
2
3
3
4
4
5
5
""
: (applylst func prompt "" '("1" "2" "3" "4" "5"))
1111 1 1 111nil
: (defun _prompt ( s ) (setq fc prompt) (if (vl-catch-all-error-p (vl-catch-all-apply 'f (list s))) (if (vl-catch-all-error-p (vl-catch-all-apply 'ff (list s m))) (progn (setq m "") (eval (f s))) (eval (ff s m))) (eval (f s))))
_PROMPT
: (applylst func _prompt "" '("1" "2" "3" "4" "5"))
1111 1 1 111nil
|;

[ribarm]

Code - Auto/Visual Lisp: [Select]

1. (defun c:replacesyntaxinalllisps ( / *cad* *adoc* *error* *func* _  promptfunc _catch _findfiles _getDateLastModified _getCurrDate timefromfsofilename formattime SetfilenameLastModified process )
2.  
3.   (or *cad* (not (vl-catch-all-error-p (setq *cad* (vl-catch-all-apply (function vlax-get-acad-object) nil)))) (vl-load-com))
4.   (if (vl-catch-all-error-p *cad*) (setq *cad* (vlax-get-acad-object)))
5.   (or *adoc* (setq *adoc* (vla-get-activedocument *cad*)))
6.  
7.   (defun *error* ( m )
8.     (if (= 8 (logand 8 (getvar 'undoctl)))
9.       (vla-endundomark *adoc*)
10.     )
11.     (if m
12.       (if f
13.         (prompt (strcat "\nRoutine breaked at this file : " (vl-prin1-to-string f)))
14.         (prompt m)
15.       )
16.     )
17.     (princ)
18.   )
19.  
20.   (setq *func* (function (lambda ( b ) ((lambda ( a ) (eval a)) b))))
21.   (setq _ (lambda ( a ) (*func* a))) ;;; ((_ list) '(1 2 3)) => ((1 2 3)) ;;; ((_ list) 1 2 3) => (1 2 3)
22.   (defun promptfunc ( func / flg )
23.     (mapcar
24.       (lambda ( x )
25.         (prompt
26.           (if (not flg)
27.             (progn (setq flg t) (vl-symbol-name x))
28.             (strcat " " (vl-symbol-name x))
29.           )
30.         )
31.       )
32.       (read (strcat "(" (vl-prin1-to-string func) ")"))
33.     )
34.     (princ)
35.   )
36.   ;;; (promptfunc list) ;;; => #<<FUNCTION> #X4 @10006D48D6>
37.   ;;; (promptfunc (_ list)) ;;; => #<<FUNCTION> #X4 @10006D48D6> ;;; so conclusion - nothing was changed - original AutoLisp function (list) was built optimized
38.  
39.   (defun _catch ( fun arglst / chk flag ret )
40.     (while (and (or (setq chk (vl-catch-all-error-p (setq ret (vl-catch-all-apply fun arglst)))) (not ret)) (if chk (if (null flag) (princ (setq flag (strcat "\nCatched error with function : " (vl-princ-to-string fun))))))))
41.     (if chk
42.       (progn (*error* (strcat "\nCatched error with function : " (vl-princ-to-string fun))) (exit))
43.       ret
44.     )
45.   )
46.  
47.   (defun _findfiles ( libraryrootprefix filenamepattern subfoldersflag / subs processsubfolders folders fl r ) ;;; (_findfiles "F:\\ACAD ADDONS-NEW" "profile*.lsp" t)
48.  
49.     (defun subs ( folder )
50.       (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
51.     )
52.  
53.     (defun processsubfolders ( rootfolder / subfolders )
54.       (setq subfolders (subs rootfolder))
55.       (foreach sub subfolders
56.         (if (= (substr rootfolder (strlen rootfolder)) "\\")
57.           (setq r (cons (strcat rootfolder sub) (processsubfolders (strcat rootfolder sub))))
58.           (setq r (cons (strcat rootfolder "\\" sub) (processsubfolders (strcat rootfolder "\\" sub))))
59.         )
60.       )
61.       r
62.     )
63.  
64.     (setq folders (append (list libraryrootprefix) (if subfoldersflag (processsubfolders libraryrootprefix) folders)))
65.     (foreach folder folders
66.       (foreach x (vl-directory-files folder filenamepattern 1)
67.         (setq fl (append fl (list (strcat folder "\\" x))))
68.       )
69.     )
70.     fl
71.   )
72.  
73.   (defun _getDateLastModified ( filename / fso vla-obj )
74.  
75.     (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))
76.  
77.     (setq fso (_catch 'vlax-get-or-create-object (list "Scripting.FileSystemObject")))
78.     (setq vla-obj (_catch 'vlax-invoke (list fso 'getfile filename)))
79.     (vlax-release-object fso)
80.     (_catch 'vlax-get (list vla-obj 'DateLastModified))
81.   )
82.  
83.   (defun _getCurrDate ( / tmpfile fn fso vla-obj rtn )
84.  
85.     (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))
86.  
87.     (setq tmpfile (vl-filename-mktemp "" "" ""))
88.     (setq fn (open tmpfile "w"))
89.     (write-line "" fn)
90.     (close fn)
91.     (setq fso (_catch 'vlax-get-or-create-object (list "Scripting.FileSystemObject")))
92.     (setq vla-obj (_catch 'vlax-invoke (list fso 'getfile tmpfile)))
93.     (vlax-release-object fso)
94.     (setq rtn (_catch 'vlax-get (list vla-obj 'DateLastModified)))
95.     (if (findfile tmpfile)
96.       (vl-file-delete tmpfile)
97.     )
98.     rtn
99.   )
100.  
101. ;|
102. : (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list -1.0 2 20)) ",D M YYYY HH MM SS)"))))
103. "1 1 1990 00 00 00"
104. : (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list 0.0 2 20)) ",D M YYYY HH MM SS)"))))
105. "10 4 2022 14 28 37"
106. : (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",D M YYYY HH MM SS)"))))
107. "10 4 2022 14 28 47" ;;; 10 sec. after first check ;;; => 2415019 days difference between 01.01.1900. and today's date -- correct -- ;;;
108. |;
109.  
110.   (defun timefromfsofilename ( ti / string l ) ;;; 2415019 = difference between 01.01.1900 - Windows time and Julian date
111.     (if ti
112.       (setq string (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ ti 2415019) 2 20)) ",M D YYYY HH MM SS)")))))
113.       (setq string (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",M D YYYY HH MM SS)")))))
114.     )
115.     (setq l (mapcar (function (lambda ( x ) (atoi (chr x)))) (vl-remove 32 (vl-string->list string))))
116.     (cond
117.       ( (= (length l) 12)
118.         (setq l (list (strcat "0" (itoa (car l))) (strcat "0" (itoa (cadr l))) (strcat (itoa (nth 2 l)) (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l))) (strcat (itoa (nth 6 l)) (itoa (nth 7 l))) (strcat (itoa (nth 8 l)) (itoa (nth 9 l))) (strcat (itoa (nth 10 l)) (itoa (nth 11 l)))))
119.       )
120.       ( (= (length l) 13)
121.         (setq l
122.           (if (or (and ti (= (strlen (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ ti 2415019) 2 20)) ",D)"))))) 2)) (and (not ti) (= (strlen (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",D)"))))) 2)))
123.             (list (strcat "0" (itoa (car l))) (strcat (itoa (cadr l)) (itoa (caddr l))) (strcat (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l))) (strcat (itoa (nth 7 l)) (itoa (nth 8 l))) (strcat (itoa (nth 9 l)) (itoa (nth 10 l))) (strcat (itoa (nth 11 l)) (itoa (nth 12 l))))
124.             (list (strcat (itoa (car l)) (itoa (cadr l))) (strcat "0" (itoa (caddr l))) (strcat (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l))) (strcat (itoa (nth 7 l)) (itoa (nth 8 l))) (strcat (itoa (nth 9 l)) (itoa (nth 10 l))) (strcat (itoa (nth 11 l)) (itoa (nth 12 l))))
125.           )
126.         )
127.       )
128.       ( (= (length l) 14)
129.         (setq l (list (strcat (itoa (car l)) (itoa (cadr l))) (strcat (itoa (caddr l)) (itoa (cadddr l))) (strcat (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l)) (itoa (nth 7 l))) (strcat (itoa (nth 8 l)) (itoa (nth 9 l))) (strcat (itoa (nth 10 l)) (itoa (nth 11 l))) (strcat (itoa (nth 12 l)) (itoa (nth 13 l)))))
130.       )
131.     )
132.     l
133.   )
134.  
135.   (defun formattime ( lst )
136.     (apply (function strcat) (mapcar (function (lambda ( a b ) (strcat a b))) lst (list "/" "/" " " ":" ":" "")))
137.   )
138.  
139.   (defun SetfilenameLastModified ( filename timestring / sh oFolder ofilenames count i loop fItem filenamepath )
140.  
141.     (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))
142.  
143.     ;;;(setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application"))
144.     (setq sh (_catch 'vlax-get-or-create-object (list "Shell.Application")))
145.     (if (findfile filename)
146.       (progn
147.         (setq oFolder (_catch 'vlax-invoke (list sh 'NameSpace (_catch 'vl-filename-directory (list filename)))))
148.         (setq ofilenames (_catch 'vlax-invoke (list oFolder 'Items)))
149.         (setq count (_catch 'vlax-get (list ofilenames 'Count)))
150.         (setq i 0 loop t)
151.         (while (and loop (< i count))
152.           (setq fItem (_catch 'vlax-invoke (list ofilenames 'Item i)))
153.           (setq filenamepath (_catch 'vlax-get (list fItem 'path)))
154.           (if (= (_catch 'vl-filename-base (list filenamepath)) (_catch 'vl-filename-base (list filename)))
155.             (progn
156.               (_catch 'vlax-put (list fItem 'ModifyDate timestring))
157.               (setq loop nil)
158.             )
159.           )
160.           (setq i (+ i 1))
161.         )
162.       )
163.       (prompt (strcat "\nFilename not found : " filename))
164.     )
165.     (vlax-release-object sh)
166.   )
167.  
168.   (defun process ( oldsyntax newsyntax / oldtime ff fn l ti formatti ll )
169.     (if (or (not oldsyntax) (not newsyntax))
170.       (while
171.         (and
172.           (not (prompt "\n"))
173.           (/= (last (setq oldsyntax (append oldsyntax (list (getstring t "\nSpecify oldsyntax (add) [ ENTER - FINISH ] : "))))) "")
174.           (/= (last (setq newsyntax (append newsyntax (list (getstring t "\nSpecify newsyntax (add) [ ENTER - FINISH ] : "))))) "")
175.         )
176.       )
177.     )
178.     (foreach f (append (_findfiles "c:\\ACAD ADDONS-NEW" "*.lsp" t) (_findfiles "c:\\ACAD ADDONS-NEW-LATEST\\ACAD ADDONS-NEW" "*.lsp" t) (_findfiles "c:\\ACAD ADDONS-NEW-ROOT" "*.lsp" t)) ;;; HARDCODE SPECIFIC FOLDER ROOTS OF FILES YOU WANT TO ALTER ;;;
179.       (if (setq oldtime (_catch '_getDateLastModified (list f)))
180.         (progn
181.           (setq ll nil)
182.           (if (setq fn (open f "r"))
183.             (progn
184.               (while (setq l (read-line fn))
185.                 (while (and (/= n -2) (or n (setq n -1)) (/= (setq n (vl-some (function (lambda ( x ) (if (vl-string-search x l) (vl-position x oldsyntax)))) (member (nth (1+ n) oldsyntax) oldsyntax))) -1))
186.                   (if (and n (not (vl-some (function (lambda ( x ) (vl-string-search x l))) newsyntax)))
187.                     (setq ll (cons (vl-string-subst (nth n newsyntax) (nth n oldsyntax) l) ll))
188.                     (setq ll (cons l ll))
189.                   )
190.                   (and n (= n (1- (length oldsyntax))) (setq n -2))
191.                   (or n (setq n -2))
192.                 )
193.                 (setq n nil)
194.               )
195.               (close fn)
196.               (setq ll (reverse ll))
197.               (if (setq ff (open (strcat (car (fnsplitl f)) (cadr (fnsplitl f)) "_tmp.lsp") "w"))
198.                 (progn
199.                   (while (setq l (car ll))
200.                     (write-line l ff)
201.                     (setq ll (cdr ll))
202.                   )
203.                   (close ff)
204.                   (if (findfile f)
205.                     (while (findfile f)
206.                       (vl-file-delete f)
207.                     )
208.                   )
209.                   (vl-file-copy (strcat (substr f 1 (- (strlen f) 4)) "_tmp.lsp") f)
210.                   (setq ti (_catch 'timefromfsofilename (list oldtime)))
211.                   (setq formatti (_catch 'formattime (list ti)))
212.                   (_catch 'SetfilenameLastModified (list f formatti))
213.                   (if (findfile (strcat (substr f 1 (- (strlen f) 4)) "_tmp.lsp"))
214.                     (while (findfile (strcat (substr f 1 (- (strlen f) 4)) "_tmp.lsp"))
215.                       (vl-file-delete (strcat (substr f 1 (- (strlen f) 4)) "_tmp.lsp"))
216.                     )
217.                   )
218.                 )
219.               )
220.             )
221.           )
222.         )
223.         (if f
224.           (progn
225.             (prompt (strcat "\nUnable to get oldtime from file : " (vl-prin1-to-string f) " ... Quitting..."))
226.             (exit)
227.           )
228.           (progn
229.             (prompt "\nFile recoginition error... Quitting...")
230.             (exit)
231.           )
232.         )
233.       )
234.     )
235.   )
236.  
237.   (if (= 8 (logand 8 (getvar 'undoctl)))
238.     (vla-endundomark *adoc*)
239.   )
240.   (vla-startundomark *adoc*)
241.  
242.   ;;; HARD CODING - REPLACE GLOBALS (LISTS OF OLD-NEW STRINGS) ACCORDING TO NEED... ;;;
243.   (setq *oldsyntaxlst* (list "(vl-load-com)")
244.         *newsyntaxlst* (list "(or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))")
245.   )
246.  
247.   ;;; uncomment above paragraph if you want hardcoded syntaxes for autorun...
248.   (process (if *oldsyntaxlst* *oldsyntaxlst*) (if *newsyntaxlst* *newsyntaxlst*))
249.   (*error* nil)
250. )
251.  

[ribarm]

;;; DATE AND TIME HELPER FUNCTIONS ;;;

;;; PREFACE ;;;

(or *cad* (not (vl-catch-all-error-p (setq *cad* (vl-catch-all-apply (function vlax-get-acad-object) nil)))) (vl-load-com))
(if (vl-catch-all-error-p *cad*) (setq *cad* (vlax-get-acad-object)))
(or *adoc* (setq *adoc* (vla-get-activedocument *cad*)))

(setq *func* (function (lambda ( b ) ((lambda ( a ) (eval a)) b))))
(setq _ (lambda ( a ) (*func* a))) ;;; ((_ list) '(1 2 3)) => ((1 2 3)) ;;; ((_ list) 1 2 3) => (1 2 3)
(defun promptfunc ( func / flg )
  (mapcar
    (lambda ( x )
      (prompt
        (if (not flg)
          (progn (setq flg t) (vl-symbol-name x))
          (strcat " " (vl-symbol-name x))
        )
      )
    )
    (read (strcat "(" (vl-prin1-to-string func) ")"))
  )
  (princ)
)
;;; (promptfunc list) ;;; => #<<FUNCTION> #X4 @10006D48D6>
;;; (promptfunc (_ list)) ;;; => #<<FUNCTION> #X4 @10006D48D6> ;;; so conclusion - nothing was changed - original AutoLisp function (list) was built optimized

(defun _catch ( fun arglst / chk flag ret )
  (while (and (or (setq chk (vl-catch-all-error-p (setq ret (vl-catch-all-apply fun arglst)))) (not ret)) (if chk (if (null flag) (princ (setq flag (strcat "\nCatched error with function : " (vl-princ-to-string fun))))))))
  (if chk
    (progn (*error* (strcat "\nCatched error with function : " (vl-princ-to-string fun))) (exit))
    ret
  )
)

;;; END OF PREFACE ;;;

;;; MAIN HELPER FUNCTIONS ;;;

(defun currentdate ( / dstring date )
  (setq dstring (rtos (getvar 'cdate) 2 0))
  (setq date (strcat (substr dstring 1 4) "/" (substr dstring 5 2) "/" (substr dstring 7 2)))
)
;|
: (currentdate)
"2022/04/06"
|;

;;; Current Date - Sorting specification ;;;
(defun currentdate nil
  (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",YYYY M D HH MM SS)"))
)
;|
: (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",YYYY M D HH MM SS)"))
"2022 4 6 12 22 34"
|;

;;; Actually this string is for sorting :
;|
: (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",YYYYMDHHMMSS)"))
"202246122234"
|;

;;; Relation between 'cdate and 'date
;|
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758200484521"
: (menucmd (strcat "M=$(edtime," (rtos (/ (getvar 'cdate) 8.220758200484521) 2 20) ",YYYYMDHHMMSS)"))
"202246122234"
: (equal (* 8.220758200484521 (getvar 'date)) (getvar 'cdate) 0.031) ;;; fuzz tolerance = 0.031 - little above 0.03
T

: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184449526"
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184361529"
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184319697"
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184283717"
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184255887"
: (rtos (/ (getvar 'cdate) (getvar 'date)) 2 20)
"8.220758184225382"

;;; So we can assume average value K = 8.2207581843
;;; Now we doubled equality check fuzz tolerance
: (equal (* 8.2207581843 (getvar 'date)) (getvar 'cdate) 0.015) ;;; fuzz tolerance = 0.015 - little above 0.015
T

;;; But here we see that 'cdate is more reliable than 'date - difference is couple of hours...!!!
: (rtos (* 8.2207581843 (getvar 'date)) 2 20)
"20220406.16081328"
: (rtos (getvar 'cdate) 2 20)
"20220406.13174566" ;;; This time was good as it was almost the same as Windows : 13:18 was on Win 10
|;

;;; Current Date - System OS specification - Files Properties ;;;
(defun currentdate nil
  (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",M D YYYY HH MM SS)"))
)
;|
: (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",M D YYYY HH MM SS)"))
"4 6 2022 12 22 34"
|;

;|
;;; Current Date - Normal specification - My prefered style - notation in local envionment ;;;
(defun currentdate nil
  (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",D M YYYY HH MM SS)"))
)

: (menucmd (strcat "M=$(edtime," (rtos (getvar 'date) 2 20) ",D M YYYY HH MM SS)"))
"6 4 2022 12 22 34"
|;


;;; BEST APPROACH TO GET CURRENT TIME AND DATE ;;;


(defun currentdate ( / dstring date )
  (setq dstring (rtos (getvar 'cdate) 2 20))
  (setq date (strcat (substr dstring 5 2) " " (substr dstring 7 2) " " (substr dstring 1 4) " "  (substr dstring 10 2) " " (substr dstring 12 2) " " (substr dstring 14 2)))
)
;|
: (currentdate)
"04 06 2022 15 46 39"
|;

(defun _getCurrDate ( / tmpfile fn fso vla-obj rtn )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (setq tmpfile (vl-filename-mktemp "" "" ""))
  (setq fn (open tmpfile "w"))
  (write-line "" fn)
  (close fn)
  (setq fso (_catch 'vlax-get-or-create-object (list "Scripting.FileSystemObject")))
  (setq vla-obj (_catch 'vlax-invoke (list fso 'getfile tmpfile)))
  (vlax-release-object fso)
  (setq rtn (_catch 'vlax-get (list vla-obj 'DateLastModified)))
  (if (findfile tmpfile)
    (vl-file-delete tmpfile)
  )
  rtn
)

;|
: (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list -1.0 2 20)) ",D M YYYY HH MM SS)"))))
"1 1 1990 00 00 00"
: (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list 0.0 2 20)) ",D M YYYY HH MM SS)"))))
"10 4 2022 14 28 37"
: (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",D M YYYY HH MM SS)"))))
"10 4 2022 14 28 47" ;;; 10 sec. after first check ;;; => 2415019 days difference between 01.01.1900. and today's date -- correct -- ;;;
|;

(defun timefromfsofilename ( ti / string l ) ;;; 2415019 = difference between 01.01.1900 - Windows time and Julian date
  (if ti
    (setq string (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ ti 2415019) 2 20)) ",M D YYYY HH MM SS)")))))
    (setq string (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",M D YYYY HH MM SS)")))))
  )
  (setq l (mapcar (function (lambda ( x ) (atoi (chr x)))) (vl-remove 32 (vl-string->list string))))
  (cond
    ( (= (length l) 12)
      (setq l (list (strcat "0" (itoa (car l))) (strcat "0" (itoa (cadr l))) (strcat (itoa (nth 2 l)) (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l))) (strcat (itoa (nth 6 l)) (itoa (nth 7 l))) (strcat (itoa (nth 8 l)) (itoa (nth 9 l))) (strcat (itoa (nth 10 l)) (itoa (nth 11 l)))))
    )
    ( (= (length l) 13)
      (setq l
        (if (or (and ti (= (strlen (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ ti 2415019) 2 20)) ",D)"))))) 2)) (and (not ti) (= (strlen (_catch 'menucmd (list (_catch 'strcat (list "M=$(edtime," (_catch 'rtos (list (+ (_catch '_getCurrDate (list)) 2415019) 2 20)) ",D)"))))) 2)))
          (list (strcat "0" (itoa (car l))) (strcat (itoa (cadr l)) (itoa (caddr l))) (strcat (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l))) (strcat (itoa (nth 7 l)) (itoa (nth 8 l))) (strcat (itoa (nth 9 l)) (itoa (nth 10 l))) (strcat (itoa (nth 11 l)) (itoa (nth 12 l))))
          (list (strcat (itoa (car l)) (itoa (cadr l))) (strcat "0" (itoa (caddr l))) (strcat (itoa (nth 3 l)) (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l))) (strcat (itoa (nth 7 l)) (itoa (nth 8 l))) (strcat (itoa (nth 9 l)) (itoa (nth 10 l))) (strcat (itoa (nth 11 l)) (itoa (nth 12 l))))
        )
      )
    )
    ( (= (length l) 14)
      (setq l (list (strcat (itoa (car l)) (itoa (cadr l))) (strcat (itoa (caddr l)) (itoa (cadddr l))) (strcat (itoa (nth 4 l)) (itoa (nth 5 l)) (itoa (nth 6 l)) (itoa (nth 7 l))) (strcat (itoa (nth 8 l)) (itoa (nth 9 l))) (strcat (itoa (nth 10 l)) (itoa (nth 11 l))) (strcat (itoa (nth 12 l)) (itoa (nth 13 l)))))
    )
  )
  l
)

;|
: (timefromfsofilename (_catch '_getCurrDate (list)))
("04" "10" "2022" "14" "33" "30")
|;

(defun filenametimeattribs ( filename / fso vla-obj dc dla dlm )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (setq fso (_catch 'vlax-get-or-create-object (list "Scripting.FileSystemObject")))
  (setq vla-obj (_catch 'vlax-invoke (list fso 'getfile filename)))
  (vlax-release-object fso)
  (setq dc (_catch 'vlax-get (list vla-obj 'DateCreated)))
  (setq dla (_catch 'vlax-get (list vla-obj 'DateLastAccessed)))
  (setq dlm (_catch 'vlax-get (list vla-obj 'DateLastModified)))
  (prompt "\nDateCreated : ") (princ (setq dc (timefromfsofilename dc)))
  (prompt "\nDateLastAccessed : ") (princ (setq dla (timefromfsofilename dla)))
  (prompt "\nDateLastModified : ") (princ (setq dlm (timefromfsofilename dlm)))
  (prompt "\n")
  (list dc dla dlm)
)

;|
: (filenametimeattribs "c:\\ACAD ADDONS-NEW\\bcaddoc-on_doc_load.lsp")

DateCreated : (04 06 2022 10 07 37)
DateLastAccessed : (04 06 2022 11 44 24)
DateLastModified : (04 06 2022 01 29 44)
(("04" "06" "2022" "10" "07" "37") ("04" "06" "2022" "11" "44" "24") ("04" "06" "2022" "01" "29" "44"))
|;

(defun formattime ( lst )
  (apply (function strcat) (mapcar (function (lambda ( a b ) (strcat a b))) lst (list "/" "/" " " ":" ":" "")))
)

;|
: (formattime (timefromfsofilename 44655.1737037037))
"04/04/2022 04:10:08"
|;

;; ------------------------<[** Set Last Modified [date] of [filename] **]>---------------------------
;; Created By: © PaNo 2021
;; patkai.norbi@gmail.com
;;
;; Example: (SetfilenameLastModified "c:\\ACAD ADDONS-NEW\\bcaddoc-on_doc_load.lsp" "01/01/2015 8:00:00 AM")

(defun SetfilenameLastModified ( filename timestring / sh oFolder ofilenames count i loop fItem filenamepath )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  ;;;(setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application"))
  (setq sh (_catch 'vlax-get-or-create-object (list "Shell.Application")))
  (if (findfile filename)
    (progn
      (setq oFolder (_catch 'vlax-invoke (list sh 'NameSpace (_catch 'vl-filename-directory (list filename)))))
      (setq ofilenames (_catch 'vlax-invoke (list oFolder 'Items)))
      (setq count (_catch 'vlax-get (list ofilenames 'Count)))
      (setq i 0 loop t)
      (while (and loop (< i count))
        (setq fItem (_catch 'vlax-invoke (list ofilenames 'Item i)))
        (setq filenamepath (_catch 'vlax-get (list fItem 'path)))
        (if (= (_catch 'vl-filename-base (list filenamepath)) (_catch 'vl-filename-base (list filename)))
          (progn
            (_catch 'vlax-put (list fItem 'ModifyDate timestring))
            (setq loop nil)
          )
        )
        (setq i (+ i 1))
      )
    )
    (prompt (strcat "\nFilename not found : " filename))
  )
  (vlax-release-object sh)
)

(defun _getDateLastModified ( filename / fso vla-obj )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (setq fso (_catch 'vlax-get-or-create-object (list "Scripting.FileSystemObject")))
  (setq vla-obj (_catch 'vlax-invoke (list fso 'getfile filename)))
  (vlax-release-object fso)
  (_catch 'vlax-get (list vla-obj 'DateLastModified))
)

(defun 10secdiff ( / ti1 ti2 filename )
  (setq ti1 "01/20/2000 00:00:00")
  (setq ti2 "01/20/2000 00:00:10")
  (setq filename (getfiled "Pick one dummy file" "\\" "*" 16))
  (_catch 'SetfilenameLastModified (list filename ti1))
  (setq ti1 (_catch '_getDateLastModified (list filename)))
  (_catch 'SetfilenameLastModified (list filename ti2))
  (setq ti2 (_catch '_getDateLastModified (list filename)))
  (rtos (- ti2 ti1) 2 20)
)

;|
: (10secdiff)
"0.0001157407386926934"
|;

;|
: (vl-file-systime "c:\\ACAD ADDONS-NEW\\bcaddoc-on_doc_load.lsp")
(2022 4 3 6 1 29 44 0) ;;; year; month; day of week; day of month; hours; minutes; seconds
|;

[ribarm]

;;; PROBLEM - GENERATING SUB ROUTINE THAT MAY ACCEPT OPTIONAL NUMBER OF ARGUMENTS LIKE SOME BUILT-IN ALISP FUNCTIONS : LIST, AND, OR, PROGN, ... ;;;


;;; SPECIFIC RESEARCHING SUB PROBLEM - CREATE CUSTOM (_OR) AND (_AND) FUNCTIONS THAT WILL RETUN LAST VALUE PROCESSED INSTEAD OF JUST : TRUE OR FLASE (T/NIL) COVERED BY NORMAL (OR)/(AND) ;;;
;;; FINAL GOAL - MAKE THOSE SUBS ACCEPT OPTIONAL NUMBER OF ARGUMENTS - I.E. - WHEN YOU HAVE OPERATIONAL LSP ROUTINE - REPLACING (OR) WITH (_OR) OR (AND) WITH (_AND) MAINLY WON'T RESULT IN FAILURE, (IF THERE WEREN'T EXPLICITLY USED T/NIL AS RETUN OF NOMAL (OR)/(AND) ;;;

;;; RESEARCHING PROGRESS - FIRST STEP ACHIEVED :
;;; FOR (_OR) => (_OR_) : WORK WITH SINGLE LIST AS ARGUMENT AND RETUNS DESIRED ELEMENT AS FINAL PROCESSING OF (OR) OPERAND - IF IT EXIST, ELSE => NIL...
;;; FOR (_AND) => (_AND_) : WORK WITH SINGLE LIST AS ARGUMENT AND RETUNS DESIRED ELEMENT AS FINAL PROCESSING OF (AND) OPERAND - IF IT EXIST, ELSE => NIL...

;;; PREFACE - SOME USEFUL SUBS FOR MAKING GENERAL ENVIRONMENT FOR WORK ;;;

  (setq *func* (function (lambda ( b ) ((lambda ( a ) (eval a)) b))))
  (setq _ (lambda ( a ) (*func* a))) ;;; ((_ list) '(1 2 3)) => ((1 2 3)) ;;; ((_ list) 1 2 3) => (1 2 3)
  (defun promptfunc ( func / flg )
    (mapcar
      (lambda ( x )
        (prompt
          (if (not flg)
            (progn (setq flg t) (vl-symbol-name x))
            (strcat " " (vl-symbol-name x))
          )
        )
      )
      (read (strcat "(" (vl-prin1-to-string func) ")"))
    )
    (princ)
  )
  ;;; (promptfunc list) ;;; => #<<FUNCTION> #X4 @10006D48D6>
  ;;; (promptfunc (_ list)) ;;; => #<<FUNCTION> #X4 @10006D48D6> ;;; so conclusion - nothing was changed - original AutoLisp function (list) was built optimized

  ;;; THIS MAY PROVE USEFUL - MONITORING SYSVAR CHANGE - STOLEN FROM MY "MAKEDEBUGGING.LSP" ;;;

  ;|
  (vl-load-com)
  (vlr-remove-all)
  (set 'reactor (vlr-sysvar-reactor nil '((:vlr-sysvarchanged . callback))))
  (defun callback ( reac data ) (if (and (wcmatch (strcase (car data)) "*USERS1") (not (equal (getvar (car data)) *users1o* 1e-6))) (progn (set '*users1o* (getvar (car data))) (alert *users1o*))))
  (defun users1 ( name var ) (setvar 'users1 (strcat (vl-symbol-name name) " = " (vl-princ-to-string var))))
  (defun f_a ( var ) (users1 'a var))
  |;

  ;;; THESE 2 DEFUNS ARE GLOBAL-GENERAL ONES FOR (_AND_OR-SUBS) ;;;

  (defun _and_or ( _and_or_flg boundlst / r )
    (progn (vl-some (function (lambda ( x ) (cond ( _and_or_flg (setq r x) (not r)) (t (setq r x) r)))) boundlst) r)
  )
  (defun boundfunc ( boundlst / r ) (progn (setq r (mapcar (function read) (mapcar (function (lambda ( x ) (setq *n* (if (not *n*) 1 (1+ *n*))) (strcat "***" (itoa *n*) "***"))) boundlst))) (setq *n* nil) r))

;;; END OF PREFACE ;;;

(defun _or-subs nil

;|
  (defun *error* ( m )
    (if (= (wcmatch m "; error : too few / too many arguments at [_OR]"))
      (progn
        (if (not ***n***) (setq ***n*** 0) (setq ***n*** (1+ ***n***)))
        (setq argl (cons (read (set (strcat "X" (itoa ***n***)))) argl))
        (eval (append (cons 'defun (cons '_or (list argl))) (list (list '_or_ (cons 'list argl)))))
        (if (not (vl-catch-all-error-p (setq r (vl-catch-all-apply (function _or) (list boundlst)))))
          r
          (*error* "; error : too few / too many arguments at [_OR]")
        )
      )
    )
  )
|;

  (defun _or_ ( boundlst ) (_and_or nil boundlst))
  (defun _or_lst ( x / y )
    (setq y ((lambda ( a ) (boundfunc a)) x))
    (eval (append (cons 'defun (cons '__or (list y))) (list (list '_or_ (cons 'list y)))))
  )
  (defun _chklen ( f r ) (if (vl-catch-all-error-p (vl-catch-all-apply (function _chklen) (list (setq f (eval (append (cons 'defun-q (cons 'f (list (setq r (cons 'x r))))) (list (list 'x))))) r))) (progn (defun-q-list-ref 'f) (_chklen f r)) (length r)))
  (defun _or_chk ( z / r ) (_or_lst z) (__or z))
  ;;;(setq _or list)
  ;;;(setq boundlst (_or boundlst))
  ;|
  (defun _or ( l / r ) (setq r (cons (car l) r)) (if (cdr l) (_or (cdr l)) (reverse r))) ;;; comment this line - something buggy...
  (defun _or ( q / r )
    (if (vl-catch-all-error-p (vl-catch-all-apply (function _or) (list q)))
      (if (setq r (_chklen _or_chk (list q)))
        (progn
          (_or_lst r)
          (eval (cons '__or r))
        )
      )
      (__or (list q))
    )
  )
  |;
  ;;;(setq _or ( (lambda ( f1 f2 ) (f1 f2)) (eval '_or_) (eval 'list)))


  (defun _or nil ( (lambda ( f1 f2 ) (f1 f2)) (eval '_or_) (eval 'list)))
  (setq _or (lambda ( ) ((eval '_or_) (eval 'list))))

)

(_or-subs) ;;; initializing ...
;;;(_or 1 2 3) ;;; THIS IS MY FINAL GOAL WHICH I CAN'T ACHIEVE AT THE MOMENT - (_or '(1 2 3)) IS EASY - THE SAME AS (_or_ '(1 2 3)) , BUT NOW WE ARE SEARCHING ON HOW TO MAKE FUNCTION WITH OPTIONAL NUMBER OF ARGUMENTS LIKE : (LIST), (OR), (AND), ...

(defun _and-subs nil

;|
  (defun *errand* ( m )
    (if (= (wcmatch m "; errand : too few / too many arguments at [_AND]"))
      (progn
        (if (not ***n***) (setq ***n*** 0) (setq ***n*** (1+ ***n***)))
        (setq argl (cons (read (set (strcat "X" (itoa ***n***)))) argl))
        (eval (append (cons 'defun (cons '_and (list argl))) (list (list '_and_ (cons 'list argl)))))
        (if (not (vl-catch-all-errand-p (setq r (vl-catch-all-apply (function _and) (list boundlst)))))
          r
          (*errand* "; errand : too few / too many arguments at [_AND]")
        )
      )
    )
  )
|;

  (defun _and_ ( boundlst ) (_and_or t boundlst))
  (defun _and_lst ( x / y )
    (setq y ((lambda ( a ) (boundfunc a)) x))
    (eval (append (cons 'defun (cons '__and (list y))) (list (list '_and_ (cons 'list y)))))
  )
  (defun _chklen ( f r ) (if (vl-catch-all-errand-p (vl-catch-all-apply (function _chklen) (list (setq f (eval (append (cons 'defun-q (cons 'f (list (setq r (cons 'x r))))) (list (list 'x))))) r))) (progn (defun-q-list-ref 'f) (_chklen f r)) (length r)))
  (defun _and_chk ( z / r ) (_and_lst z) (__and z))
  ;;;(setq _and list)
  ;;;(setq boundlst (_and boundlst))
  ;|
  (defun _and ( l / r ) (setq r (cons (car l) r)) (if (cdr l) (_and (cdr l)) (reverse r))) ;;; comment this line - something buggy...
  (defun _and ( q / r )
    (if (vl-catch-all-errand-p (vl-catch-all-apply (function _and) (list q)))
      (if (setq r (_chklen _and_chk (list q)))
        (progn
          (_and_lst r)
          (eval (cons '__and r))
        )
      )
      (__and (list q))
    )
  )
  |;
  ;;;(setq _and ( (lambda ( f1 f2 ) (f1 f2)) (eval '_and_) (eval 'list)))


  (defun _and nil ( (lambda ( f1 f2 ) (f1 f2)) (eval '_and_) (eval 'list)))
  (setq _and (lambda ( ) ((eval '_and_) (eval 'list))))

)

(_and-subs) ;;; initializing ...
;;;(_and 1 2 3) ;;; THIS IS MY FINAL GOAL WHICH I CAN'T ACHIEVE AT THE MOMENT - (_and '(1 2 3)) IS EASY - THE SAME AS (_and_ '(1 2 3)) , BUT NOW WE ARE SEARCHING ON HOW TO MAKE FUNCTION WITH OPTIONAL NUMBER OF ARGUMENTS LIKE : (LIST), (OR), (AND), ...

[ribarm]

I've updated all recent posts :

http://www.theswamp.org/index.php?topic=57388.msg609566#msg609566
http://www.theswamp.org/index.php?topic=57388.msg609578#msg609578
http://www.theswamp.org/index.php?topic=57388.msg609579#msg609579


I hope you'll find info/codes posted useful...
M.R.

[ribarm]

Not that I am bored, but half concerned am starting to have a feeling that things are becoming little slippery from a perspective of a Traveling Salesman around uncertainties either from west or east...

Challenges are also here, so...

https://www.theswamp.org/index.php?topic=39082.0
E.E. :
(M. Mcdonald : Anybody home?)

[ribarm]

Once upon a time in a universe near - far waya...

Da li vi znate Waya Con Dios ili Vam drugim recnikom pripoznato Vaja Description Del Monaco?

Naravno, u nekim elementima postojanost se ocekuje esalonski ili ti barjamanski...
Spasiba ili thank you, da ne spomenem tank Y...

To bi vam bilo to...
Nekada davno ili mozda i bajno... Nedostaje objasnjenje funkcije (f4) Evgeniy...
A osim toga, zgodno je videti pravog suhoja ponekad i u Moskvi i u Bill Gate-ici, uzgred budi receno B.G. tematici...

Sa stanovista LISP-a, ja bih rekao moze i ( f4 ), a mozda upali i ( f8 ), cisto na ne bude bas sve sa N.T. ili kako se to vec pretpostavlja T.N.

[ribarm]

Jel umete Vi da brojite, 13 ljudi je vise negoli 12 apostola...!!!