# 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

\$
```