Greetings...
I took some of my free hours to arrange posted sub functions that could be useful for this challenge task...
I was playing more with user friendly ways of aquiring desirable data input, than working on specific task - solving problem... Either way, if you want, you can use my LISP template to do testings with your own codes/functions...
I'd tried to cobble everything needed that is available for normal/usual usage of CAD software to make desired master routine useful for this specific task...
Used : Express Tools - acet-xxx functions , DCL - Dialog Control Language, just a little Visual Lisp functions (built-in), (Robert McNeel) DosLib addon functions, and almost everything else predominantly used by standard AutoLisp functions (built-in)...
;;; USED GENERAL NON COMMAND FUNCTIONS ;;;
;;; pattern matching between 2 strings ;;;
;;; https://www.cadtutor.net/forum/topic/74031-matching-pattern-of-two-strings/
(defun str1mchstr2 ( str1 str2 / unique* l1 l2 l2o a r q )
(defun unique* ( l / a r )
(while (setq a (car l))
(if (and (= a 42) (vl-position 42 (cdr l)))
(setq r (cons a r)
l (member (vl-some (function (lambda ( x ) (if (/= x 42) x))) l) l)
)
(setq r (cons a r)
l (cdr l)
)
)
)
(reverse r)
)
(setq l1 (vl-string->list str1))
(setq l2 (vl-string->list str2))
(setq l2o l2)
(while (setq a (car l1))
(setq l1 (cdr l1))
(if (= a (car l2))
(setq r (cons a r)
l2 (cdr l2)
)
(setq r (cons 42 r)
l2 (if (= (car l1) (car l2))
l2
(if (vl-position (car l1) l2)
(if (vl-position (car l1) r)
(progn
(setq q l2o)
(repeat (1+ (- (length r) (length (vl-remove (car l1) r))))
(setq q (cdr (member (car l1) q)))
)
(setq q (cons (car l1) q))
)
(cdr l2)
)
(cdr l2)
)
)
)
)
)
(vl-list->string (unique* (reverse r)))
)
;;;
;;; (defun c:ttt1 nil (str1mchstr2 "Drawing_12_1297-2241079-LEVEL 50 - PRESSURE SERVICES - ZONE 3" "Drawing_6_1303-2241073-LEVEL 50 - PRESSURE SERVICES - ZONE 3"))
;;; (defun c:ttt2 nil (str1mchstr2 "Drawing_6_1303-2241073-LEVEL 50 - PRESSURE SERVICES - ZONE 3" "Drawing_12_1297-2241079-LEVEL 50 - PRESSURE SERVICES - ZONE 3"))
;;;
;;; "Drawing_*_1*-224107*-LEVEL 50 - PRESSURE SERVICES - ZONE 3" ;;;
;;; process list with filenames-patterns by collecting each matching pattern (each string pair matching) and finally removing duplicates - used method : iteration ;;;
;;; filenameslist-patternslist - list with strings
;;; return - list with common matching pattern(s) string(s)
(defun process ( filenameslist-patternslist / unique resultpatterns )
(defun unique ( l / a r )
(while (setq a (car l))
(if (vl-some (function (lambda ( x ) (equal a x))) (cdr l))
(setq r (cons a r)
l (vl-remove-if (function (lambda ( x ) (equal a x))) (cdr l))
)
(setq r (cons a r)
l (cdr l)
)
)
)
(reverse r)
)
(foreach filename-pattern1 filenameslist-patternslist
(setq filenameslist-patternslist (cdr filenameslist-patternslist))
(foreach filename-pattern2 filenameslist-patternslist
(setq resultpatterns (cons (str1mchstr2 filename-pattern1 filename-pattern2) resultpatterns))
)
)
(unique resultpatterns)
)
;;; process list with filenames strings until matched pattern(s) become sinlge common matching pattern string - used method : recursion ;;;
;;; filenameslist-patternslist - list with strings representing filenames specifications
;;; return - common matching pattern string
(defun mainprocess ( filenameslist-patternslist )
(if (> (length filenameslist-patternslist) 1)
(mainprocess (process filenameslist-patternslist))
(car filenameslist-patternslist)
)
)
;;; collect list of filenames of all specific files residing in main/parent folder and all its sub/child folders ;;;
;;; libraryrootprefix - main/parent folder string
;;; filenamepattern - pattern describing specific non fungible characteristic to be used for processing/collecting filenames / nil ("*.*")
;;; return - list with filenames strings (full paths included) collected in specific folder tree that satisfy custom specific filter if it was provided and passed to evaluation
(defun _findfiles ( libraryrootprefix filenamepattern / subs processsubfolders folders fl r ) ;;; (_findfiles "F:\\ACAD ADDONS-NEW\\" "profile*.lsp")
(defun subs ( folder )
(vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
)
(defun processsubfolders ( rootfolder / subfolders )
(setq subfolders (subs rootfolder))
(foreach sub subfolders
(if (= (substr rootfolder (strlen rootfolder)) "\\")
(setq r (cons (strcat rootfolder sub) (processsubfolders (strcat rootfolder sub))))
(setq r (cons (strcat rootfolder "\\" sub) (processsubfolders (strcat rootfolder "\\" sub))))
)
)
r
)
(setq folders (append (list libraryrootprefix) (processsubfolders libraryrootprefix)))
(foreach folder folders
(foreach x (vl-directory-files folder filenamepattern 1)
(setq fl (cons (strcat folder "\\" x) fl))
)
)
(reverse fl)
)
;; Directory Files - Lee Mac
;; Retrieves all files of a specified filetype residing in a directory (and subdirectories)
;; dir - [str] Root directory for which to return filenames
;; typ - [str] Optional filetype filter (DOS pattern)
;; sub - [bol] If T, subdirectories of the root directory are included
;; Returns: [lst] List of files matching the filetype criteria, else nil if none are found
(defun LM:directoryfiles-main ( dir typ sub / LM:directoryfiles l ) ;;; why main function ? - purpose : clearing "l" variable (globals are not desirable in any case...)
(defun LM:directoryfiles ( dir typ sub )
(setq dir (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir)))
(mapcar
(function
(lambda ( x )
(setq l (append l (list (strcat dir "\\" x))))
)
) (vl-directory-files dir typ 1)
)
(if sub
(mapcar
(function
(lambda ( x )
(if (not (wcmatch x "`.,`.`."))
(LM:directoryfiles (strcat dir "\\" x) typ sub)
)
)
)
(vl-directory-files dir nil -1)
)
)
)
(LM:directoryfiles dir typ sub)
l
)
;;; MAIN ROUTINE ;;;
;;;------------------------------------------------------------------------------------------------------------------------;;;
;;; ;;;
;;; FIND COMMON MATCHING PATTERN STRING OF ALL SPECIFIC FILES RESIDING IN MAIN/PARENT FOLDER AND ALL ITS SUB/CHILD FOLDERS ;;;
;;; ;;;
;;; By Marko Ribar, d.i.a. (architect) : 20.02.2022. ;;;
;;; ;;;
;;;------------------------------------------------------------------------------------------------------------------------;;;
(defun c:folder_wcmatch_pattern ( / *error* LM:str->lst LM:editbox editbox_makedcl run_editbox_dcl tmp_dcl_filename dcl_id han filter folder fullfilenames filenames )
(vl-load-com) ;;; load AciveX extensions (VLA-functions)...
;;; HELPER SUB FUNCTIONS...
(defun *error* ( m )
(vl-catch-all-apply 'term_dialog nil)
(if m
(prompt m)
)
(princ)
)
;; String to List - Lee Mac
;; Separates a string using a given delimiter
;; str - [str] String to process
;; del - [str] Delimiter by which to separate the string
;; Returns: [lst] List of strings
(defun LM:str->lst ( str del / len lst pos )
(setq len (1+ (strlen del)))
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos len))
)
)
(reverse (cons str lst))
)
;; Edit Box - Lee Mac
;; Displays a DCL Edit Box to obtain a string from the user
;; str - [str] Initial value to display ("" for none)
;; Returns: [str] Edit box contents if user pressed OK, else nil
(defun LM:editbox ( str han )
(if (new_dialog "acad_txtedit" han)
(progn
(set_tile "text_edit" str)
(action_tile "text_edit" "(setq str $value)")
(if (zerop (start_dialog))
(setq str nil)
)
(if (and han (< 0 han))
(unload_dialog han)
)
str
)
)
)
(defun editbox_makedcl ( fullfilename / fn )
(setq fn (open fullfilename "w"))
(write-line "EditBox : dialog { key = \"Title\"; label = \"\"; initial_focus = \"Edit\"; spacer; : row { fixed_width = true; : column { width = 100; fixed_width = true; spacer; : text { key = \"Text\"; label = \"\"; }} : edit_box { key = \"Edit\"; edit_width = 20; fixed_width = true; is_default = true; }} spacer; ok_cancel; }" fn)
(close fn)
t
)
(defun run_editbox_dcl ( dcl_id / r )
(if (new_dialog "EditBox" dcl_id)
(progn
(set_tile "Title" "Specific non fungible characteristic of filenames to be processed - considered in pattern matching search")
(set_tile "Text" "Specify pattern describing specific non fungible characteristic to be used for processing/collecting filenames - ENTER FOR ALL (\"*.*\")")
(set_tile "Edit" "*.*")
(action_tile "Edit" "(setq filter $value)") ;;; storing dialog input in variable "filter"...
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(if (setq r (start_dialog))
(progn
(unload_dialog dcl_id)
(if (zerop r)
(setq filter nil)
filter
)
)
)
)
)
)
;;; MAIN ROUTINE...
;;; INPUT DATA...
(or
(and
(setq tmp_dcl_filename (vl-filename-mktemp "e_box" (car (LM:str->lst (vla-get-supportpath (vla-get-files (vla-get-preferences (vlax-get-acad-object)))) ";")) ".dcl"))
(editbox_makedcl tmp_dcl_filename)
(> (setq dcl_id (load_dialog tmp_dcl_filename)) 0)
(or (setq filter (run_editbox_dcl dcl_id)) t)
(or
(if (findfile tmp_dcl_filename)
(vl-file-delete tmp_dcl_filename)
)
t
)
filter
)
(and
(> (setq han (load_dialog "acad")) 0)
(setq filter (LM:editbox "Specify pattern describing specific non fungible characteristic to be used for processing/collecting filenames - ENTER FOR ALL (\"*.*\")" han))
)
(setq filter (dos_editbox "Specific non fungible characteristic of filenames to be processed - considered in pattern matching search" "Specify pattern for processing/collecting filenames - ENTER FOR ALL (\"*.*\")" "*.dwg"))
(setq filter (getstring t "\nSpecify pattern describing specific non fungible characteristic to be used for processing/collecting filenames - ENTER FOR ALL (\"*.*\")\n\t:"))
)
(if (= "" filter)
(setq filter "*.*")
)
(or
(not filter)
(setq folder (strcat (acet-ui-pickdir "Select folder tree to process wcmatch_pattern files matching...") "\\"))
(if (setq folder (getfiled "Select folder tree to process wcmatch_pattern files matching... Then just pick one of files and press OPEN button" "\\" filter 16))
(setq folder (car (fnsplitl folder)))
)
(setq folder (dos_getdir "Browse for folder" "\\" "Select folder tree to process wcmatch_pattern files matching..."))
(if (setq folder (dos_getfiled "Browse for folder - Select folder tree to process wcmatch_pattern files matching..." "\\" ""))
(setq folder (car (fnsplitl folder)))
)
(setq folder (car (dos_getfilenav "Browse for folder - Select folder tree to process wcmatch_pattern files matching..." "\\" filter 4096))) ;;; 4096 (bit 12) - multiple file seletion enabled
)
;;; MAIN PROCESSING ...
(if (and folder filter (or (setq fullfilenames (_findfiles folder filter)) (setq fullfilenames (LM:directoryfiles-main folder filter t))))
(progn
(setq filenames (mapcar (function (lambda ( x / y ) (setq y (fnsplitl x)) (strcat (cadr y) (caddr y)))) fullfilenames))
(setq *pattern* (mainprocess filenames))
(prompt "\nSpecified pattern that was used for processing : \"") (prompt filter) (prompt "\"")
(prompt "\nSpecified folder that was used for processing : \"") (prompt folder) (prompt "\"")
(prompt "\n")
(prompt "\nProcessed total : ") (princ (if filenames (length filenames) 0)) (prompt " filenames...")
(prompt "\n")
(prompt "\nCOMMON WCMATCH PATTERN / MATCHING STRINGS FILTER SPECIFICATION : \"") (prompt *pattern*) (prompt "\"")
(prompt "\n")
(prompt "\nPattern is stored in global variable : \"*pattern*\"... You can call it with : !*pattern*...")
)
(cond
( (and folder filter)
(prompt "\nSorry, you picked empty folder tree - there are no files matching specified pattern that was used for processing...")
(prompt "\nSpecified pattern that was used for processing : \"") (prompt filter) (prompt "\"")
(prompt "\nSpecified folder that was used for processing : \"") (prompt folder) (prompt "\"")
(prompt "\n\nPossible problem : invalid filenames - used bad code page in naming them (collecting of files not processed - (vl-directory-files) bug...\nEither use differnt pattern, or pick diferent folder tree next time...")
)
( folder
(prompt "\nSpecified folder that was used for processing : \"") (prompt folder) (prompt "\"")
(prompt "\n")
(prompt "\nInvalid input - pattern that is to be used for processing havent been defined sucessfully...")
(prompt "\n\nTry to fix problem of not invoking DCL dialog box by debugging (load_dialog) function on specified string at beginning of temporary DCL file... \nIf value is positive number, then you should look for next issue that causes not starting edit box input...")
(prompt "\nAlternatively you can try some differnt method of invoking edit box input : DosLib function (dos_editbox)...")
)
( filter
(prompt "\nSpecified pattern that was used for processing : \"") (prompt filter) (prompt "\"")
(prompt "\n")
(prompt "\nEither (acet-ui-pickdir) haven't initialized properly, or you pressed CANCEL button when dialog box for selecting folder appeared, or you terminated proper way of routine execution...")
(prompt "\n\nTry to replace (acet-ui-pickdir) method of invoking dialog box for folder selection with some different approach : (getfiled) function; DosLib function (dos_getdir)...")
)
( t
(prompt "\nNothing processed... And no valid input data...")
(prompt "\n\nTry to fix problem of not invoking DCL dialog box by debugging (load_dialog) function on specified string at beginning of temporary DCL file... \nIf value is positive number, then you should look for next issue that causes not starting edit box input...")
(prompt "\nEither (acet-ui-pickdir) haven't initialized properly, or you pressed CANCEL button when dialog box for selecting folder appeared, or you terminated proper way of routine execution...")
(prompt "\n\nTry to replace (acet-ui-pickdir) method of invoking dialog box for folder selection with some different approach : (getfiled) function; DosLib function (dos_getdir)...")
)
)
)
(textscr)
(princ)
)
;;; THIS EXAMPLES THAT FOLLOW COULD BE USEFUL FOR RESEARCH/STUDY TOO; THEY ARE ALSO SOMEHOW RELATED TO THIS TOPIC - (wcmatch) PATTERNS AND (wcmatch) FUNCTION ;;;
(defun LM-MR:wcmatchx ( str pat / MR:wcmatchx LM:wcmatchx )
(defun MR:wcmatchx ( str pat / k )
(setq k 0)
(while (and (wcmatch (substr str 1 (setq k (1+ k))) pat) (/= k (strlen str))))
(cond
( (and (wcmatch (substr str k) pat) (= k 1) (/= (substr pat 1 1) "~"))
str
)
( (and (= (substr str (1+ k)) "") (= (substr pat 1 1) "~") (= str (substr pat 2)))
nil
)
( (= (substr str (1+ k)) "")
str
)
( (wcmatch (substr str (1+ k)) pat)
(substr str (1+ k))
)
)
)
(defun LM:wcmatchx ( str pat )
(if (and (wcmatch str pat) (/= "" str))
(cond
( (LM:wcmatchx (substr str 2) pat))
( (LM:wcmatchx (substr str 1 (1- (strlen str))) pat))
( str )
)
)
)
(cond
( (= pat "*")
str
)
( (or (= (substr pat 1 1) "*") (= (substr pat (strlen pat)) "*"))
(LM:wcmatchx str pat)
)
( t
(MR:wcmatchx str pat)
)
)
)
(print (LM-MR:wcmatchx "abc123def" "*")) ;;; "abc123def"
(print (LM-MR:wcmatchx "abc123def" "*123*")) ;;; "123"
(print (LM-MR:wcmatchx "abc123def" "~abc")) ;;; "123def"
(print (LM-MR:wcmatchx "abc123def" "~123")) ;;; "abc123def"
(print (LM-MR:wcmatchx "abc123def" "*###*")) ;;; "123"
(print (LM-MR:wcmatchx "abc123def" "*123def")) ;;; "123def"
(print (LM-MR:wcmatchx "abc123def" "abc123*")) ;;; "abc123"
(print (LM-MR:wcmatchx "abc123def" "Jonathan")) ;;; nil
(princ)
But, still, when I do testings with my main (str1mchstr2) function, when processed main routine, almost always I get matching pattern result as : "*"...
Now I don't know what is the problem, but I am guessing that when list of matched patterns, match with each other (through recursion), result is reducing all the ways - finally producing : "*" as a result... Perhaps, the problem is that "*" character that occurs after first matching pass is treated like all other normal characters - not wild card - probably that causes shrinking of results; and when shrinked pass results/patterns recursive pass all to termination - (list with single pattern resulting string was processed) - result is "*" almost always...
Well, that's all from me till now...
We'll see how will progress further researching...
Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
