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 $