Topic: -={ Challenge }=- Multi-Delimiter String Parsing

[Lee Mac]

The Challenge:

To separate elements of a string by a list of delimiters.

Example:

Code: [Select]

(MultiParse "This;is.a,Test;String" '(";" "." ","))

==>  ("This" "is" "a" "Test" "String")


Code: [Select]

(MultiParse "This&%is,5%" '("," "&%"))

==>  ("This" "is" "5%")


Code: [Select]

(MultiParse "&This,is,a&Test," '("&" ","))

==> ("This" "is" "a" "Test")

Enjoy!

Lee

[CAB]

Here is a quickie.

Code: [Select]

(defun sparserm (str delim / ptr lst)
  (while (setq ptr (vl-remove 'nil (mapcar (function (lambda(x) (vl-string-search x str))) delim)))
    (setq ptr (apply 'min ptr))
    (setq lst (cons (substr str 1 ptr) lst))
    (setq str (substr str (+ ptr 2)))
  )
  (reverse(cons str lst))
)

[Lee Mac]

Nice one Alan 

How about for delims of length > 1 

Code: [Select]

(sparserm "This&%is,5%" '("," "&%"))

[Lee Mac]

My first entry:

Code: [Select]

(defun LM:StringParserM ( str del / foo l )

  (defun foo ( str del )
    (if (setq pos (vl-string-search del str))
      (vl-remove ""
        (cons (substr str 1 pos)
          (foo
            (substr str (+ pos 1 (strlen del))) del
          )
        )
      )
      (list str)
    )
  )

  (setq l (foo str (car del)))
 
  (foreach x (cdr del)
    (setq l
      (apply (function append)
        (mapcar (function (lambda ( y ) (foo y x))) l)
      )
    )
  )
  l
)


[CAB]

How about for delims of length > 1 

Was that in the specifications? 

[hermanm]

Nice one, Lee.

Code: [Select]

Command: (LM:StringParserM "This;is.a,Test;\String" '(";" "." "," "\\"))
("This" "is" "a" "Test" "String")


Code: [Select]

Command: (LM:StringParserM "This\nis a test\n     " '(" " "\n"))
("This" "is" "a" "test")


[Lee Mac]

How about for delims of length > 1 

Was that in the specifications? 

I hadn't included an example, but it was my intention 

[Lee Mac]

Nice one, Lee.

Code: [Select]

Command: (LM:StringParserM "This;is.a,Test;\String" '(";" "." "," "\\"))
("This" "is" "a" "Test" "String")


Code: [Select]

Command: (LM:StringParserM "This\nis a test\n     " '(" " "\n"))
("This" "is" "a" "test")


Thanks Herman 

[LE3]

Code: [Select]

;;(mparser '(";" "." "," "\\") "This;is.a,Test;\String")
;;("This" "is" "a" "Test" "String")
;;(mparser '(";" "." ",") "This;is.a,Test;String")
;;("This" "is" "a" "Test" "String")
(defun mparser (pat str / pattern i j n lst)
  (setq p (car pat))
  (setq pattern (vl-remove p pat))
  (setq i 0)
  (repeat (length pattern)
    (setq str (vl-string-subst p (nth i pattern) str))
    (setq i (1+ i))
  )
  (cond
    ((/= (type str) (type p) 'STR))
    ((= str p) '(""))
    (T
     (setq i 0
  n (strlen p)
     )
     (while (setq j (vl-string-search p str i))
       (setq lst (cons (substr str (1+ i) (- j i)) lst)
    i (+ j n)
       )
     )
     (mapcar '(lambda (x) (vl-string-trim " " x))
    (reverse (cons (substr str (1+ i)) lst))
     )
    )
  )
)

[Lee Mac]

Another,

Code: [Select]

(defun LM:StringParserM2 ( str del / pos x )
  ;; © Lee Mac 2010
  (if (setq pos
        (car
          (setq x
            (car
              (vl-sort
                (vl-remove nil
                  (mapcar
                    (function
                      (lambda ( d / p )
                        (if (setq p (vl-string-search d str))
                          (cons p (strlen d))
                        )
                      )
                    )
                    del
                  )
                )
                (function
                  (lambda ( a b ) (< (car a) (car b)))
                )
              )
            )
          )
        )
      )
    (vl-remove ""
      (cons (substr str 1 pos)
        (LM:StringParserM2
          (substr str (+ pos 1 (cdr x))) del
        )
      )
    )
    (list str)
  )
)


[Lee Mac]

Perhaps a slightly more elegant version of my first one 

Code: [Select]

(defun LM:StringParserM ( str del / foo l )

  (defun foo ( str del )
    (if (setq pos (vl-string-search del str))
      (vl-remove ""
        (cons (substr str 1 pos)
          (foo
            (substr str (+ pos 1 (strlen del))) del
          )
        )
      )
      (list str)
    )
  )

  (if (cdr del)
    (apply (function append)
      (mapcar (function (lambda ( x ) (LM:StringParserM x (cdr del))))
        (foo str (car del))
      )
    )
    (foo str (car del))
  )
)


[LE3]

edited.-

Code: [Select]

;;parsermult uses a token character separator to replace
;;all the characters separators in the patterns list
;;will check if the token is not on the patterns or in the string
;;returns= a list of new strings or nil
;;usage:
;;(parsermult "this;is;;a,test\"\"" '(";" "," "\"") "|")
;;("this" "is" "a" "test")
(defun parsermult  (string patterns token / pattern pos lst)
  (if (and (not (vl-position token patterns))
   (not (vl-string-search token string)))
    (progn
      (while (setq pattern (car patterns))
(while (and pattern (vl-string-search pattern string))
  (setq string (vl-string-subst token pattern string)))
(setq patterns (cdr patterns)))
      (while (setq pos (vl-string-search token string))
(setq lst    (cons (substr string 1 pos) lst)
      string (substr string (+ pos 2))))
      (vl-remove "" (reverse lst)))))


[It's Alive!]

mine 

Code: [Select]

(defun MultiParse (string delims / dlist item llout tmpl)
  (setq tmpl '() llout '()  dlist (vl-string->list delims))
  (foreach item (vl-string->list (vl-string-right-trim delims string))
    (if (not (vl-position item dlist))
      (setq tmpl (cons item tmpl))
      (progn
        (setq llout (append llout (list(vl-list->string(reverse tmpl)))) tmpl '())
      )
    )
  )
  (append llout (list(vl-list->string(reverse tmpl))))
)

(MultiParse "This;is.a,Test;String" ";.,")


[Kerry]

Daniel, I have one with similar functionality :

However I think the expectation was that the delimiters be a list of strings, each of which shall be removed from the parent string if existing.

... this should allow the the removal of character patterns like " ex" and "'s " from the parent.

[It's Alive!]

ah ok, maybe something like

Code: [Select]

(defun MultiParse (string delims / item llout s tdlim tmpl tstr)
  (setq tstr "" tdlim "")
  (repeat (length delims)
    (setq tstr (strcat " " tstr)))
  (foreach s  delims
    (setq tdlim (strcat s tdlim)))
  (setq tmpl '() llout '())
  (foreach item (vl-string->list (vl-string-right-trim " "(vl-string-translate tdlim tstr string)))
    (if (/= item 32)
      (setq tmpl (cons item tmpl))
      (progn
        (setq llout (append llout (list(vl-list->string(reverse tmpl)))) tmpl '())
      )
    )
  )
  (append llout (list(vl-list->string(reverse tmpl))))
)

(MultiParse "This;is.a,Test;String " '(";" "." ","))


[qjchen]

my code, based on CAB and alanjt 's codes on one delim member

First is to subst all the other delims in the string to the first member of delim

Code: [Select]

;;;Thanks to alanjt and CAB's codes at : http://www.theswamp.org/index.php?topic=32845.0
;;;add a little by qjchen
(defun q:str:delim(str delimlst / l inc)
 (foreach x (cdr delimlst)
   (while (vl-string-search x str)
    (setq str (vl-string-subst (car delimlst) x str))))
 (while (setq inc (vl-string-search (car delimlst) str))
    (setq l (cons (substr str 1 inc) l)
          str (substr str (+ (strlen (car delimlst)) inc 1)))
 )
 (vl-remove "" (reverse (cons str l)))
)

(q:str:delim ";;;...This;is.a,Test;abStringab" '("ab" ";" "." ","))

To Daniel, when use (MultiParse ";;;...This;is.a,Test;abStringab" '("ab" ";" "." ","))
=> ("" "" "" "" "" "" "This" "is" "" "" "Test" "" "bString" "b")

[pkohut]

The dog ate my homework.   

[Kerry]

The dog ate my homework.   

[It's Alive!]

To Daniel, when use (MultiParse ";;;...This;is.a,Test;abStringab" '("ab" ";" "." ","))
=> ("" "" "" "" "" "" "This" "is" "" "" "Test" "" "bString" "b")

  sorry, I am very new at lisp 

[Kerry]

To Daniel, when use (MultiParse ";;;...This;is.a,Test;abStringab" '("ab" ";" "." ","))
=> ("" "" "" "" "" "" "This" "is" "" "" "Test" "" "bString" "b")

  sorry, I am very new at lisp  

It gets easier after 5 or 6 thousand lines of code ...


... oh, wait, you know that from one app don't you ??  

[It's Alive!]

ok hows this one?

Code: [Select]

(defun MultiParse (string delims / char cnt flag len lout s tdlim tstr)
  (setq tstr ""
        tdlim ""
        cnt 0
        len (strlen string)
        flag nil
        lout '()
  )
 
  (foreach s  delims
    (setq tdlim (strcat s tdlim)))
   
  (while (<= cnt len)
    (setq char (substr string (1+ cnt) 1))
    (if (vl-string-search   char tdlim)
      (progn
        (if flag
          (progn
            (setq lout (append lout (list tstr))
                  tstr ""
                  flag nil
            )
          )
        )
      )
      (progn
        (setq tstr (strcat tstr char)
              flag t
        )
      )
    )
    (setq cnt (1+ cnt))
  )
  lout
)

(MultiParse ";;;;;;;;;;;;;This;;;is.a,Test;String hi;,,,yes;;." '(";" "." ","))
(MultiParse "This&%is,5%" '("," "&%"))


[alanjt]

Code: [Select]

(defun Parse-AJT (s dLst / i l)
  (while (setq i (vl-remove nil
                            (mapcar
                              (function (lambda (x) (vl-string-search (strcase x) (strcase s))))
                              dLst
                            )
                 )
         )
    (setq l (cons (substr s 1 (setq i (apply (function min) i))) l)
          s (substr s (+ 2 i))
    )
  )
  (vl-remove "" (reverse (cons s l)))
)

Result:

Code: [Select]

(parse-ajt "1,2,3,4,5,6.7.8.9.10" (list "," "."))
("1" "2" "3" "4" "5" "6" "7" "8" "9" "10")

[It's Alive!]

Awseome, but fails here  (Parse-AJT "This&%is,5%" '("," "&%"))

[Kerry]

(parse-ajt "1,2,3,4,5,6.7.8.9.10" (list  "," "5" "10" "."))

;;=>> ("1" "2" "3" "4" "6" "7" "8" "9" "0")

oops, Dainiel beat me again.

[alanjt]

Oops, I forgot to account for strings being longer than one character.  :ugly:

[hermanm]

So far:

Code: [Select]

Command: (LM:STRINGPARSERM "This\nis a;; test\n" '("\n" " " ";"))
("This" "is" "a" "test")

Command: (LM:STRINGPARSERM "This\nis a;; test\n" '("\n" " " ";;"))
("This" "is" "a" "test")

Command: (mparser '("\n" " " ";") "This\nis a;; test\n")
("This" "is" "a" "; test" "")

Command: (mparser '("\n" " " ";;") "This\nis a;; test\n")
("This" "is" "a" "test" "")

Command: (multiparse "This\nis a;; test\n" '("\n" " " ";"))
("This" "is" "a" "" "" "test")

Command: (multiparse "This\nis a;; test\n" '("\n" " " ";;"))
("This\nis" "a" "" "" "test\n")



[hermanm]

Code: [Select]

Command: (parse-ajt "This\nis a;; test\n" '("\n" " " ";"))
("This" "is" "a" "test")

Command: (parse-ajt "This\nis a;; test\n" '("\n" " " ";;"))
("This" "is" "a" ";" "test")


[hermanm]

and Dan's update:

Code: [Select]


Command: (multiparse "This\nis a;; test\n" '("\n" " " ";"))
("This" "is" "a" "test")

Command: (multiparse "This\nis a;; test\n" '("\n" " " ";;"))
("This" "is" "a" "test")

Sorry I don't have time to play

[hermanm]

Code: [Select]

Command: (Q:STR:DELIM "This\nis a;; test\n" '("\n" " " ";"))
("This" "is" "a" "test")

Command: (Q:STR:DELIM "This\nis a;; test\n" '("\n" " " ";;"))
("This" "is" "a" "test")

(not claiming the test strings to be anything special, just what popped into my head)

[alanjt]

Code: [Select]

(defun Parse-AJT2 (s dLst / i n l)
  (while (setq i (vl-remove nil
                            (mapcar
                              (function (lambda (x / v)
                                          (if (setq v (vl-string-search (strcase x) (strcase s)))
                                            (cons v (1- (strlen x)))
                                          )
                                        )
                              )
                              dLst
                            )
                 )
         )
    (setq l (cons (substr s 1 (setq n (caar (vl-sort i '(lambda (a b) (< (car a) (car b))))))) l)
          s (substr s (+ 2 (cdr (assoc n i)) n))
    )
  )
  (vl-remove "" (reverse (cons s l)))
)

[alanjt]

Code: [Select]

(defun Parse-AJT3 (s dLst / i n l)
  (while (setq i (vl-remove nil
                            (mapcar
                              (function (lambda (x / v)
                                          (if (setq v (vl-string-search (strcase x) (strcase s)))
                                            (cons v (strlen x))
                                          )
                                        )
                              )
                              dLst
                            )
                 )
         )
    (setq l (cons (substr s 1 (setq n (caar (vl-sort i '(lambda (a b) (< (car a) (car b))))))) l)
          s (substr s (+ 1 (cdr (assoc n i)) n))
    )
  )
  (vl-remove "" (reverse (cons s l)))
)

[It's Alive!]

.

[alanjt]

qjchen, that's quite impressive.

[qjchen]

Thank you Daniel for your test. I am not sure whether there are still bugs in my codes.

And thank you alanjt, my codes are mainly based on yours and CAB's codes.  I changed the "2" in your code  to "(strlen delim)" to be applicable for multi-char delim

[VovKa]

i insist that a split function should work like this

Code: [Select]

(somesplit ";This;;is;a;test;" '(";"))
==>("" "This" "" "is" "a" "test" "")


[alanjt]

Thank you Daniel for your test. I am not sure whether there are still bugs in my codes.

And thank you alanjt, my codes are mainly based on yours and CAB's codes.  I changed the "2" in your code  to "(strlen delim)" to be applicable for multi-char delim

Well, I like it!

[It's Alive!]

a bit faster but not enough

Code: [Select]

(defun MultiParse2 (string delims / char cnt flag len lout s tstr)
  (setq tstr ""
        tdlim ""
        cnt 0
        flag n
        lout '()
        delim (car delims)
  )

  (foreach s delims
    (setq tdlim (strcat s tdlim))
  )
  (repeat (strlen tdlim)
    (setq tstr (strcat delim tstr))
  )

  (setq string (vl-string-trim " " (vl-string-translate tdlim tstr string))
        tstr ""
        len (strlen string)
  )

  (while (<= cnt len)
    (setq cnt (1+ cnt))
    (setq char (substr string cnt 1))
    (if (= char delim)
      (progn
        (if flag
          (progn
            (setq lout (append lout (list tstr))
                  tstr ""
                  flag nil
            )
          )
        )
      )
      (progn
        (setq tstr (strcat tstr char)
              flag t
        )
      )
    )
  )
  lout
)


[VovKa]

does anyone mind that mine doesn't work with "\"" ?

Code: [Select]

(defun msplit (str dList)
  (foreach d dList (setq str (vk_StringSubstPat "\" \"" d str nil)))
  (read (strcat "(\"" str "\")"))
)


[Lee Mac]

Damn I wish I had more time to play around with this 

[Lee Mac]

Minor attempt at optimisation of Chen's

Code: [Select]

(defun LM:StringParserM3 ( str del / x y z l p )

  (setq x (car del) y (1+ (strlen x)))
 
  (while (setq del (cdr del))
    (while (vl-string-search (setq z (car del)) str)
      (setq str (vl-string-subst x z str))
    )
  )

  (while (setq p (vl-string-search x str))
    (setq l (cons (substr str 1 p) l) str (substr str (+ p y)))
  )

  (vl-remove "" (reverse (cons str l)))
)


[ElpanovEvgeniy]

Code: [Select]

(defun f1 (s p / i l)
 (while (setq i (vl-string-search p s))
  (setq l (cons (substr s 1 i) l)
        s (substr s (+ 1 i (strlen p)))
  )
 )
 (reverse (cons s l))
)
(defun mpars (s d)
 (setq d1 ""
       d2 ""
       d3 '("\001")
 )
 (foreach p d
  (if (= (substr p 2) "")
   (setq d1 (strcat p d1)
         d2 (strcat "\001" d2)
   )
   (setq d3 (cons p d3))
  )
 )
 (setq s (list (vl-string-translate d1 d2 s)))
 (foreach p d3
  (setq s (apply (function append) (mapcar (function (lambda (a) (f1 a p))) s)))
 )
 (vl-remove "" s)
)

[It's Alive!]

and the results

Elapsed milliseconds / relative speed for 16384 iteration(s):
    (LM:STRINGPARSERM3 ";;;;;;;;;;;;;Thi...)......1529 / 6.84 <fastest>
    (Q:STR:DELIM ";;;;;;;;;;;;;This;;;is...)......1919 / 5.45
    (MPARS ";;;;;;;;;;;;;This;;;is.a,;.T...)......2168 / 4.82
    (MULTIPARSE2 ";;;;;;;;;;;;;This;;;is...)......2387 / 4.38
    (MULTIPARSE1 ";;;;;;;;;;;;;This;;;is...)......2808 / 3.72
    (LM:STRINGPARSERM ";;;;;;;;;;;;;This...)......4633 / 2.26
    (LM:STRINGPARSERM2 ";;;;;;;;;;;;;Thi...).....10452 / 1.00 <slowest>

[ElpanovEvgeniy]

and the results
...

Show the arguments of function calls to compare the speed ...

[It's Alive!]

and the results
...

Show the arguments of function calls to compare the speed ...

Right, yours is faster with longer strings

Code: [Select]

(setq _str (strcat "hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."))



(BenchMark
            '(
              (LM:StringParserM _str '("." "," ))
              (LM:StringParserM2 _str '("." "," ))
              (q:str:delim _str '("." "," ))
              (MultiParse2 _str '("." "," ))
              (MultiParse1 _str '("." "," ))
              (LM:StringParserM3 _str '("." ","))
              (mpars _str '("." ","))
             )
          )


Elapsed milliseconds / relative speed for 4096 iteration(s):
    (LM:STRINGPARSERM3 _STR (QUOTE ("." ...)......1841 / 6.89 <fastest>
    (MPARS _STR (QUOTE ("." ",")))................1872 / 6.78--------------------------------
    (Q:STR:DELIM _STR (QUOTE ("." ",")))..........2293 / 5.53
    (LM:STRINGPARSERM _STR (QUOTE ("." "...)......4883 / 2.60
    (MULTIPARSE2 _STR (QUOTE ("." ",")))..........8877 / 1.43
    (MULTIPARSE1 _STR (QUOTE ("." ","))).........10592 / 1.20
    (LM:STRINGPARSERM2 _STR (QUOTE ("." ...).....12683 / 1.00 <slowest>

[ElpanovEvgeniy]

I get the opposite results ... 

Code: [Select]

(setq _str (strcat "hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."
                  "the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you.welcome.to.the,swamp,hello.how.are.you."))
(BenchMark
            '(
              (q:str:delim _str '("." "," ))
              (LM:StringParserM3 _str '("." ","))
              (mpars _str '("." ","))
             )
          )

Code: [Select]

Benchmarking ..............Elapsed milliseconds / relative speed for 2048 iteration(s):

    (MPARS _STR (QUOTE ("." ",")))...............1155 / 1.28 <fastest>
    (LM:STRINGPARSERM3 _STR (QUOTE ("." ...).....1248 / 1.19
    (Q:STR:DELIM _STR (QUOTE ("." ","))).........1482 / 1 <slowest>

 
_$

[VovKa]

Code: [Select]

Benchmarking ..............Elapsed milliseconds / relative speed for 2048 iteration(s):

    (MSPLIT _STR (QUOTE ("." ",")))..............1500 / 1.66 <fastest>
    (MPARS _STR (QUOTE ("." ",")))...............2063 / 1.20
    (LM:STRINGPARSERM3 _STR (QUOTE ("." ...).....2484 / 1.00 <slowest>