Topic: List of numbers to compacted string?

[Jeff_M]

I like the recursive approach, but it looks like it has problems....

(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68)
_$ (test testlist)
"1,5-6,53-64,67-68"
 

[T.Willey]

Okay, here is my new entry.  I think it will work better.  Inspiration from Michael's. 

Code: [Select]

(defun NumList->String (NumList AddFactor / StrList Str)

(foreach Num NumList
 (cond
  ((not StrList)
   (setq StrList (list (list Num)))
  )
  ((equal (caar StrList) (- Num AddFactor) (* AddFactor 0.25))
   (setq StrList (subst (cons Num (car StrList)) (car StrList) StrList))
  )
  (T
   (setq StrList (cons (list Num) StrList))
  )
 )
)
(setq Str "")
(foreach Lst (reverse StrList)
 (cond
  ((equal (length Lst) 1)
   (setq Str (strcat Str (vl-princ-to-string (car Lst)) ","))
  )
  ((equal (length Lst) 2)
   (setq Str (strcat Str (vl-princ-to-string (cadr Lst)) "," (vl-princ-to-string (car Lst)) ","))
  )
  (T
   (setq Str (strcat Str (vl-princ-to-string (last Lst)) "-" (vl-princ-to-string (car Lst)) ","))
  )
 )
)
(substr Str 1 (1- (strlen Str)))
)
Return

Command: (NumList->String '(1 2 4 5 6  8 10 11 12) 1)
"1,2,4-6,8,10-12"

Command: (NumList->String '(1.0 2 4 5 6  8 10 11 12) 0.1)
"1.0,2,4,5,6,8,10,11,12"

Command: (NumList->String '(1.0 1.1 1.2 2 2.1 2.2 2.5) 0.1)
"1.0-1.2,2-2.2,2.5"

Command: (NumList->String '(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68) 1)
"1,3,5,6,8,53-64,66-68"

[CAB]

OK late to the party again.
Took my wife out to dinner, first time in 8 weeks. Big points. 

This code will handle reals but not like Tim's, no AddFactor

Code: [Select]

(defun intstorangedstring (ints / sorted result x y )
  (setq sorted (vl-sort ints '>)
        x      (car sorted)
        sorted (cdr sorted)
        result (list (vl-princ-to-string x))
  )
  (while (setq y (car sorted))
    (setq sorted (cdr sorted))
    (cond
      ((and (= (1+ y) x) (= (1- y) (car sorted)))
       (if (/= (car result) "-") (setq result (cons "-" result)))
      )
      ((= (car result) "-")
       (setq result (cons (vl-princ-to-string y) result))
       )
      ((setq result (cons (vl-princ-to-string y) (cons "," result))))
    )
    (setq x y)
  )
 (apply 'strcat result)
)

Code: [Select]

(defun c:test ()
  (print (intstorangedstring '(1 3 4 5 8 10 11 14 15 16)))
  ;; "1,3-5,8,10,11,14-16"
  (print (intstorangedstring '(1 2 4 5 6  8 10 11 12)))
  ;;  "1,2,4-6,8,10-12"
  (print (intstorangedstring '(1.0 2 4 5 6  8 10 11 12)))
  ;; "1.0,2,4,5,6,8,10,11,12"
  (print (intstorangedstring '(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68)))
  ;;  "1,3,5,6,8,53-64,66-68"
 (princ)
)

[ElpanovEvgeniy]

I like the recursive approach, but it looks like it has problems....

(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68)
_$ (test testlist)
"1,5-6,53-64,67-68"
 

Excuse, I have hastened and have badly checked up...

Code: [Select]

(defun test (lst)
  (if (and lst (listp (car lst)))
    (cond
      ((not (cadr lst))
       (strcat (itoa (caar lst)) "-" (itoa (cadar lst)))
      )
      ((equal (1+ (cadar lst)) (cadr lst) 1e-8)
       (test (cons (list (caar lst) (cadr lst)) (cddr lst)))
      )
      (t (strcat (itoa (caar lst)) "-" (itoa (cadar lst)) "," (test (cdr lst))))
    ) ;_  cond
    (cond
      ((null lst) "")
      ((not (cadr lst)) (itoa (car lst)))
      ((equal (1+ (car lst)) (cadr lst) 1e-8)
       (test (cons (list (car lst) (cadr lst)) (cddr lst)))
      )
      (t (strcat (itoa (car lst)) "," (test (cdr lst))))
    ) ;_  cond
  ) ;_  if
)
(test  '(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68))
=>>
"1,3,5-6,8,53-64,66-68"

[ElpanovEvgeniy]

Has deleted superfluous checks...

Code: [Select]

(defun test (lst)
  (if lst
    (if (listp (car lst))
      (if (cadr lst)
        (if (equal (1+ (cadar lst)) (cadr lst) 1e-8)
          (test (cons (list (caar lst) (cadr lst)) (cddr lst)))
          (strcat (itoa (caar lst)) "-" (itoa (cadar lst)) "," (test (cdr lst)))
        ) ;_  if
        (strcat (itoa (caar lst)) "-" (itoa (cadar lst)))
      ) ;_  if
      (if (cadr lst)
        (if (equal (1+ (car lst)) (cadr lst) 1e-8)
          (test (cons (list (car lst) (cadr lst)) (cddr lst)))
          (strcat (itoa (car lst)) "," (test (cdr lst)))
        ) ;_  if
        (itoa (car lst))
      ) ;_  if
    ) ;_  if
    ""
  ) ;_  if
)

[Kerry]

Evgeniy,
very nice ..

Could you show how you would expand the list ?

ie
(setq x "1,3,5-6,8,53-64,66-68" )
(test_expand x) ;; ->>
(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68)

[ElpanovEvgeniy]

Evgeniy,
very nice ..

Could you show how you would expand the list ?

ie
(setq x "1,3,5-6,8,53-64,66-68" )
(test_expand x) ;; ->>
(1 3 5 6 8 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68)

Code: [Select]

(defun test1 (s)
  (if s
    (if (listp s)
      (if (and (cadar s)(< (caar s) (cadar s)))
          (cons (caar s) (test1 (cons (list (1+ (caar s)) (cadar s)) (cdr s))))
          (cons (caar s)(test1 (cdr s)))
        )
      (test1
        (read
          (strcat
            "(("
            (apply
              (function strcat)
              (mapcar
                (function
                  (lambda (x)
                    (cond
                      ((< 47 x 58) (chr x))
                      ((= 44 x) ")(")
                      ((= 45 x) " ")
                    ) ;_  cond
                  ) ;_  lambda
                ) ;_  function
                (vl-string->list s)
              ) ;_  mapcar
            ) ;_  apply
            "))"
          ) ;_  strcat
        ) ;_  read
      ) ;_  test
    ) ;_  if
  ) ;_  if
)

[Kerry]

Evgeniy,

(test1 "1,3,5-6,8,53-64,66-68")

; error: too many arguments

edit : piccy

[ElpanovEvgeniy]

Whence it (T)??

[Kerry]

 ahhhhh ,  My bad ..   


Thanks !

[Kerry]

I think I must have left the t when I removed the closing_comments ..

            "))"
          ) ;_  strcat

clumsy !

[Andrea]

and mine...

Code: [Select]


[code(setq mainlist (vl-sort '(1 3 4 5 8 10 11 14 15 16) '<) Flist "")
(foreach n mainlist
  (setq i1 (car mainlist) i2 (cadr mainlist))
  (if i2
    (progn
      (if (eq (+ i1 1) i2)
(setq Flist (strcat Flist (rtos i1 2 0) ","))
(setq Flist (strcat Flist (rtos i1 2 0) "-")))
      (setq mainlist (cdr mainlist))
    )(setq Flist (strcat Flist (rtos i1 2 0)))
))(alert (strcat "Ther it is: " Flist))

[Kerry]

Andrea, you may need to test that.

[Andrea]

Andrea, you may need to test that.

test result....

[Kerry]

Andrea, you may need to test that.

test result.... "1-3,4,5-8-10,11-14,15,16"

I believe it should return "1,3-5,8,10-11,14-16"  or "1,3-5,8,10,11,14-16" depending on how you read the specifications.