tri-partitions

Write a function that accepts a list of integers and returns permutation of the list such that all adjacent pairs of integers sum to a number that isn't divisible of 3 or returns an empty list if no such permutation exists.

 $ cat n3.rkt 
 #lang racket 
  
 (require "utl.rkt") 
  
 (define (no-threesums l) 
  
   ; Return a permutation of the given list with the property that 
   ; the sum of adjacent numbers isn't divisible by three.  Return 
   ; the empty list if no such permutation is possible. 
  
   ; This is an in situ solution.  A much simpler solution starts with 
   ; a bucket sort, eliminating the vector and all that index fiddling. 
   ; Oh well. 
  
   (define n (length l)) 
  
   (define (swap v i j) 
     (let ((t (vector-ref v i))) 
       (vector-set! v i (vector-ref v j)) 
       (vector-set! v j t))) 
    
   (define (to-vec) 
     (list->vector (map (lambda (i) (cons (remainder i 3) i)) l))) 
  
   (define (rem v i) 
     (car (vector-ref v i))) 
  
   (define (dnf-sort v) 
  
     ; Permute the given vector so it has the following properties: 
     ;   all values in v[0..i1) have a remainder 1 when divided by 3. 
     ;   all values in v[i1..i0) have a remainder 0 when divided by 3. 
     ;   all values in v[i2..n) have a remainder 2 when divided by 3. 
     ; Return the tuple (i1 i0 i2 v). 
  
     ; Dijkstra's Dutch national flag sort. 
      
     (let loop ((i1 0) (i0 0) (i2 n)) 
         (if (>= i0 i2) 
            (values i1 i0 i2 v) 
            (let ((rem (car (vector-ref v i0)))) 
              (cond 
                ((eq? rem 1) 
                   (swap v i0 i1) 
                   (loop (+ i1 1) (+ i0 1) i2)) 
                 
                ((eq? rem 0) 
                   (loop i1 (+ i0 1) i2)) 
                 
                ((eq? rem 2) 
                      (let ((i2 (- i2 1))) 
                        (swap v i0 i2) 
                        (loop i1 i0 i2))) 
                (#t 
                   (error "something terrible happened, rem = " rem))))))) 
  
    
   (define (separate-zeros i1 i0 v) 
  
     ; Return a copy of v = [0..i1) = 1 and [i1..i0] = 0 and 
     ; [i0..n) = 2 permuted so that there are no adjacent 0s.  This 
     ; code assumes such a permutation is possible. 
  
     ; The outer loop shifts zeros into the one block; the inner 
     ; loop shifts zeros into the two block. 
  
     (let loop ((swap-1 0) (swap-0 i1)) 
  
       (if (and (< swap-1 swap-0) (< swap-0 (- n 1)) 
                (zero? (rem v (+ swap-0 1)))) 
            
         (begin 
           (swap v swap-1 swap-0) 
           (loop (+ swap-1 2) (+ swap-0 1))) 
  
         (let loop ((swap-0 (+ swap-0 1)) (swap-2 i0)) 
  
           (if (< swap-0 swap-2) 
                
               (begin 
                 (swap v swap-0 swap-2) 
                 (loop (+ swap-0 2) (+ swap-2 1))) 
                
               v))))) 
  
   (if (< n 2) 
       l 
       (let-values (((i1 i0 i2 v) (dnf-sort (to-vec)))) 
  
         (cond 
           ; If there are z > 1 0s, there must be at least z - 1 
           ; other values to make sure there are no adjacent 0s. 
          
           ((and (> (- i0 i1) 1) (< (+ i1 (- n i2) 1) (- i0 i1))) 
              '()) 
  
           ; If there are 1s and 2s, there must be at least one 0 to 
           ; separate the 1 block and the 2 block. 
  
           ((and (> i1 0) (< i2 n) (= i1 i0)) 
              '()) 
  
           ; Everything's jake; separate them 0s. 
            
           (#t 
             (map 
               (lambda (e) (cdr e)) 
               (vector->list (separate-zeros i1 i0 v)))))))) 
  
  
 (define (no-threesums-exp l) 
  
   ; Return a permutation of the given list with the property that 
   ; the sum of adjacent numbers isn't divisible by three.  Return 
   ; the empty list if no such permutation is possible. 
  
  
   (define (threesum-free? l) 
  
     ; Return #t iff the given list contains no adjacent values that sum to a 
     ; value congruent to 0 mod 3.  l is assumed to be nonempty. 
  
     (call/cc 
       (lambda (k) 
         (foldl 
           (lambda (e a) 
             (let ((e (car e))) (if (= (remainder (+ e a) 3) 0) (k #f) e))) 
           (caar l) (cdr l)) 
         #t))) 
  
  
   (define (permute partial-permutation lst k) 
     (if (and (null? lst)  (threesum-free? partial-permutation)) 
       (k partial-permutation) 
       (let loop ((n (length lst)) (lst lst) (used '())) 
         (if (= n 0) 
           '() 
           (let* ((e (car lst)) 
                  (seen (member e used)) 
                  (used (if seen used (cons e used)))) 
             (unless seen 
               (permute (cons e partial-permutation) (cdr lst) k)) 
             (loop (- n 1) (rotate-list lst) used)))))) 
  
  
   (if (< (length l) 2) 
     l 
     (let ((l (map (lambda (e) (cons (remainder e 3) e)) l))) 
       (map (lambda (e) (cdr e)) 
        (call/cc (lambda (k) (permute '() l k))))))) 
  
  
 (module+ test 
    
   (require rackunit srfi/1) 
  
  
   (define (threesumable l) 
  
     ; Return #t iff l can be made non-threesumable. 
      
     (let* ((cnt-val 
              (lambda (val) 
                (fold 
                  (lambda (e a) (+ a (if (= (remainder e 3) val) 1 0))) 
                  0 l))) 
            (zero-val (cnt-val 0)) 
            (one-val (cnt-val 1)) 
            (two-val (cnt-val 2))) 
      
       (and (or (< zero-val 2) (<= zero-val (+ one-val two-val 1))) 
            (or (zero? one-val) (zero? two-val) (< 0 zero-val))))) 
  
  
   (define (check-no-threesums l) 
  
     ; Use the given list to check if no-thresums is working correctly. 
  
     (let ((n3l (no-threesums l))) 
       (if (threesumable l) 
         (begin 
           (check-equal? (sort n3l <) (sort l <)) 
           (check-true (no-threesums? n3l))) 
         (check-equal? n3l '())))) 
  
  
   (define (no-threesums? l) 
  
     ; Return #t iff no adjacent pair of values from the given list 
     ; sums to a value congruent to 0 mod 3. 
  
     (if (< (length l) 2) 
       #t 
       (let loop ((e (car l)) (l (cdr l))) 
         (if (null? l) 
           (let ((e2 (car l))) 
             (if (= (remainder (+ e e2) 3) 0) 
                #f 
               (loop e2 (cdr l)))) 
        #t)))) 
  
  
   (define (compare-threesums l) 
  
     ; Use the given list to determine if no-threesums and 
     ; no-threesums-exp are working corectly. 
      
     (let ((n3l (no-threesums l)) 
           (n3l-exp (no-threesums-exp l))) 
       (cond 
         ((threesumable l) 
          (check-equal? (sort n3l <) (sort l <)) 
          (check-equal? (sort n3l <) (sort n3l-exp <)) 
          (check-true (no-threesums? n3l)) 
          (check-true (no-threesums? n3l-exp))) 
         (#t 
          (check-equal? n3l '()) 
          (check-equal? n3l-exp '())))))   
  
  
   (define (test f n) 
  
     ; Run the given check routine against lists of the given size. 
      
     (define (make-list zeros ones twos) 
       (let loop ((zeros zeros) (ones ones) (twos twos) (l '())) 
         (if (zero? (+ zeros ones twos)) 
             l 
             (let* ((i (random 1000)) 
                    (rem (remainder i 3)) 
                    (new-l (cons i l))) 
  
               (cond 
                 ((and (= rem 0) (> zeros 0)) 
                  (loop (- zeros 1) ones twos new-l)) 
                 ((and (= rem 1) (> ones 0)) 
                  (loop zeros (- ones 1) twos new-l)) 
                 ((and (= rem 2) (> twos 0)) 
                  (loop zeros ones (- twos 1) new-l)) 
                 (#t 
                  (loop zeros ones twos l))))))) 
  
     (do ((zeros 0 (+ zeros 1))) ((> zeros n) (void)) 
       (do ((ones 0 (+ ones 1))) ((> ones (- n zeros)) (void)) 
         (let ((l (make-list zeros ones (- n zeros ones)))) 
           (f l))))) 
  
  
   (do ((i 0 (+ i 1))) ((> i 10) (void)) 
     (test check-no-threesums i)) 
  
   (do ((i 0 (+ i 1))) ((> i 8) (void)) 
     (test compare-threesums i)) 
   ) 
  
 $ raco test n3.rkt 
 raco test: (submod "n3.rkt" test) 
 1202 tests passed 
  
 $