fork download
  1. ; partitioning the telephone book
  2.  
  3. (define (split n xs)
  4. (let loop ((n n) (xs xs) (zs '()))
  5. (if (or (zero? n) (null? xs))
  6. (values (reverse zs) xs)
  7. (loop (- n 1) (cdr xs) (cons (car xs) zs)))))
  8.  
  9. (define (sum xs) (apply + xs))
  10.  
  11. (define phone (list 16 4 17 10 15 4 4 6 7 14 9 17 27 6 1 9 0 12 20 8 0 3 4 0 3 4))
  12.  
  13. (define (parts stars bars)
  14. (if (= bars 1) (list (list stars))
  15. (let loop ((i 0) (ps (parts stars (- bars 1))) (zs (list)))
  16. (if (< stars i) zs
  17. (if (null? ps)
  18. (loop (+ i 1) (parts (- stars i 1) (- bars 1)) zs)
  19. (loop i (cdr ps) (cons (cons i (car ps)) zs)))))))
  20.  
  21. (define (score xs part ideal)
  22. (let loop ((xs xs) (part part) (zs (list)))
  23. (if (pair? part)
  24. (call-with-values
  25. (lambda () (split (car part) xs))
  26. (lambda (first rest)
  27. (loop rest (cdr part) (cons first zs))))
  28. (let loop ((zs (map sum (reverse zs))) (tot 0))
  29. (if (null? zs) tot
  30. (loop (cdr zs) (+ tot (abs (- (car zs) ideal)))))))))
  31.  
  32. (define (phone-book xs k)
  33. (let ((min-part '()) (min-diff 10000000))
  34. (do ((ps (parts (length xs) k) (cdr ps)))
  35. ((null? ps) (values min-part min-diff))
  36. (let ((s (score xs (car ps) (quotient (sum xs) k))))
  37. (when (< s min-diff)
  38. (set! min-part (car ps))
  39. (set! min-diff s))))))
  40.  
  41. (call-with-values
  42. (lambda () (phone-book phone 4))
  43. (lambda (part score)
  44. (display part) (newline)
  45. (display score) (newline)))
Success #stdin #stdout 0.51s 7368KB
stdin
Standard input is empty
stdout
(4 7 6 9)
18