fork download
copy 
  1. ; tri-partitions
  2.  
  3. (define (f xs)
  4.   (let loop ((xs xs) (zeroes (list)) (ones (list)) (twos (list)))
  5.     ; (display "loop1 ") (display xs) (display " ") (display zeroes)
  6.     ; (display " ") (display ones) (display " ") (display twos) (newline)
  7.     (if (pair? xs)
  8.         (cond ((= (modulo (car xs) 3) 0)
  9.                 (loop (cdr xs) (cons (car xs) zeroes) ones twos))
  10.               ((= (modulo (car xs) 3) 1)
  11.                 (loop (cdr xs) zeroes (cons (car xs) ones) twos))
  12.               (else (loop (cdr xs) zeroes ones (cons (car xs) twos))))
  13.         (if (and (null? zeroes) (pair? ones) (pair? twos)) #f ; no zero separator
  14.           (if (null? zeroes) (append ones twos)
  15.             (let loop ((saved (car zeroes)) (zeroes (cdr zeroes))
  16.                        (ones ones) (twos twos) (zs (list)))
  17.               ; (display "loop2 ") (display saved) (display " ")
  18.               ; (display zeroes) (display " ") (display ones) (display " ")
  19.               ; (display twos) (display " ") (display zs) (newline)
  20.               (cond ((and (null? zeroes) (null? ones) (null? twos))
  21.                       (if saved (cons saved zs) zs))
  22.                     ((and (pair? zeroes) (pair? ones))
  23.                       (loop saved (cdr zeroes) (cdr ones) twos
  24.                             (cons (car ones) (cons (car zeroes) zs))))
  25.                     ((pair? ones)
  26.                       (loop saved zeroes (cdr ones) twos (cons (car ones) zs)))
  27.                     (saved (loop #f zeroes ones twos (cons saved zs)))
  28.                     ((and (pair? twos) (pair? zeroes))
  29.                       (loop saved (cdr zeroes) ones (cdr twos)
  30.                             (cons (car zeroes) (cons (car twos) zs))))
  31.                     ((pair? twos)
  32.                       (loop saved zeroes ones (cdr twos) (cons (car twos) zs)))
  33.                     (else #f)))))))) ; leftover zeroes
  34.  
  35. (display (f '(0 0 0))) (newline)
  36. (display (f '(0 0 1))) (newline)
  37. (display (f '(0 0 2))) (newline)
  38. (display (f '(0 1 1))) (newline)
  39. (display (f '(0 2 2))) (newline)
  40. (display (f '(1 1 1))) (newline)
  41. (display (f '(2 2 2))) (newline)
  42. (display (f '(1 1 2))) (newline)
  43. (display (f '(0 1 2))) (newline)
  44. (define xs '(2 67 65 71 86 83 12 17 9 30 42 61 33 68 57 30 74 42 41 51))
  45. (display (f xs)) (newline)
  46. (display (map (lambda (x) (modulo x 3)) (f xs))) (newline)
Success #stdin #stdout 0.01s 7892KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#f
(0 1 0)
(0 2 0)
(0 1 1)
(2 2 0)
(1 1 1)
(2 2 2)
#f
(2 0 1)
(2 65 71 12 86 9 83 30 17 42 68 33 74 57 41 51 67 30 61 42)
(2 2 2 0 2 0 2 0 2 0 2 0 2 0 2 0 1 0 1 0)
https://ideone.com/v6b63R
language:
Scheme (chicken 4.13)
created:
4 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!