fork download
copy 
  1. ; collect sets of ranges
  2.  
  3. (define (ranges . xs)
  4.   (let loop ((xs xs) (in-run #f) (prev #f))
  5.     (cond ((null? xs)
  6.             (when (and in-run prev)
  7.               (display "-")
  8.               (display prev))
  9.             (newline))
  10.           (in-run
  11.             (if (= (car xs) (+ 1 prev))
  12.                 (loop (cdr xs) #t (car xs))
  13.                 (begin (display "-")
  14.                        (display prev)
  15.                        (display ", ")
  16.                        (display (car xs))
  17.                        (loop (cdr xs) #f (car xs)))))
  18.           ((and prev (= (car xs) (+ 1 prev)))
  19.             (loop (cdr xs) #t (car xs)))
  20.           (else (when prev (display ", "))
  21.                 (display (car xs))
  22.                 (loop (cdr xs) #f (car xs))))))
  23.  
  24. (display (ranges 0 1 2 7 21 22 108 109)) (newline)
  25.  
  26. (define (collect . xs)
  27.   (if (null? xs) (list)
  28.     (let loop ((xs (cdr xs))
  29.                (start (car xs))
  30.                (prev (car xs))
  31.                (zs (list)))
  32.       (cond ((null? xs) ; end of input
  33.               (if (= start prev)
  34.                   (reverse (cons prev zs))
  35.                   (reverse (cons (cons start prev) zs))))
  36.             ((= (car xs) (+ prev 1)) ; continue run
  37.               (loop (cdr xs) start (car xs) zs))
  38.             (else ; end run, start new run
  39.               (if (= start prev)
  40.                   (loop (cdr xs) (car xs) (car xs)
  41.                         (cons prev zs))
  42.                   (loop (cdr xs) (car xs) (car xs)
  43.                         (cons (cons start prev) zs))))))))
  44.  
  45. (display (collect 0 1 2 7 21 22 108 109)) (newline)
  46.  
  47. (define (display-ranges xs)
  48.   (cond ((pair? (car xs))
  49.           (display (caar xs))
  50.           (display "-")
  51.           (display (cdar xs)))
  52.   (else (display (car xs))))
  53.   (when (pair? (cdr xs))
  54.     (display ", ")
  55.     (display-ranges (cdr xs))))
  56.  
  57. (display (display-ranges (collect 0 1 2 7 21 22 108 109))) (newline)
  58.  
  59. (define (collect-by break? . xs)
  60.   (if (null? xs) (list)
  61.     (let loop ((xs (cdr xs))
  62.                (start (car xs))
  63.                (prev (car xs))
  64.                (zs (list)))
  65.       (cond ((null? xs) ; end of input
  66.               (if (equal? start prev)
  67.                   (reverse (cons prev zs))
  68.                   (reverse (cons (cons start prev) zs))))
  69.             ((break? prev (car xs)) ; continue run
  70.               (loop (cdr xs) start (car xs) zs))
  71.             (else ; end run, start new run
  72.               (if (equal? start prev)
  73.                   (loop (cdr xs) (car xs) (car xs)
  74.                         (cons prev zs))
  75.                   (loop (cdr xs) (car xs) (car xs)
  76.                         (cons (cons start prev) zs))))))))
  77.  
  78. (define (consecutive? a b) (= (+ a 1) b))
  79.  
  80. (display (display-ranges (collect-by consecutive? 0 1 2 7 21 22 108 109))) (newline)
  81.  
  82. (define (split-between pred? xs)
  83.   (let loop ((xs xs) (ys (list)) (xss (list)))
  84.     (cond ((null? xs) ; no input
  85.             (reverse (cons (reverse ys) xss)))
  86.           ((null? (cdr xs)) ; singleton input
  87.             (reverse (cons (reverse (cons (car xs) ys)) xss)))
  88.           ((pred? (car xs) (cadr xs)) ; start a new group
  89.             (loop (cons (cadr xs) (cddr xs)) (list)
  90.                   (cons (reverse (cons (car xs) ys)) xss)))
  91.           (else ; extend an existing group
  92.             (loop (cons (cadr xs) (cddr xs))
  93.                   (cons (car xs) ys) xss)))))
  94.  
  95. (define (display-ranges . xs)
  96.   (let loop ((xss (split-between (complement consecutive?) xs)))
  97.     (cond ((and (pair? (car xss)) (pair? (cdar xss)))
  98.             (display (caar xss))
  99.             (display "-")
  100.             (display (car (reverse (car xss)))))
  101.     (else (display (caar xss))))
  102.     (when (pair? (cdr xss))
  103.       (display ", ")
  104.       (loop (cdr xss))))
  105.   (newline))
  106.  
  107. (display (display-ranges (split-between consecutive? '(0 1 2 7 21 22 108 109)))) (newline)
Success #stdin #stdout 0s 7268KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
0-2, 7, 21-22, 108-109
#<unspecified>
((0 . 2) 7 (21 . 22) (108 . 109))
0-2, 7, 21-22, 108-109#<unspecified>
0-2, 7, 21-22, 108-109#<unspecified>
((0) (1) (2 7 21) (22 108) (109))
#<unspecified>
https://ideone.com/DxR3Xp
language:
Scheme (chicken 4.13)
created:
9 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!