Backup

(define-library (sudoku printing)
  (import (scheme base)
    (only (scheme write) display)
    (only (srfi 1) count))
  (export print display-stat print-sudoku)
  (begin (define (print str) (display str) (newline))
    (define (display-stat str n)
      (display
        (string-append str ": " (number->string n) ".\n")))
    (define delim
      (list->string
        (cons #\newline (make-list #\_ 19))))
    (define (print-sudoku grid)
      (display
        (string-append delim
          (let f ([i 0] [str ""])
            (unless (> i 80)
              (f (+ i 1)
                (string-append str
                  (when (= (modulo i 9) 0) "|")
                  (number->string
                    (vector-ref grid i))
                  "|"
                  (when (= (modulo i 9) 8)
                    delim)))))
          "\n"))
      (display-stat "Number of clues"
        (count (lambda (x) (> x 0))
          (vector-list grid))))))

(define-library (sudoku grid)
  (import (scheme base)
    (only (srfi 1) break concatenate iota lset= take zip)
    (only (srfi 27) default-random-source
      random-source-randomize!)
    (only (gauche sequence) permute shuffle shuffle!)
    (only (util combinations) permutations)
    (only (util list) slices)
    (sudoku printing))
  (export solution)

  (begin (random-source-randomize! default-random-source)
    (define-syntax receive
      (syntax-rules ()
        [(_ formals expr body ...)
         (call-with-values (lambda () expr)
           (lambda formals body ...))]))

    (define (compose f . g)
      (if (null? g) f
          (let ([g (apply compose g)])
            (lambda (x) (f (g x))))))

    (define (split3 ls) (slices ls 3))

    (define (transpose ls) (apply zip ls))

    (define (cube->rows ls)
      (map concatenate (concatenate ls)))

    (define (cube->blocks ls) (map transpose (split3 ls)))

    (define (triplets f ls)
      (map f (transpose (map split3 ls))))

    (define (rotations ls)
      (let ([n (length ls)])
        (do ([i 0 (+ i 1)]
               [ls (append ls ls) (cdr ls)]
               [y (list) (cons (take ls n) y)])
              ((= i n) (reverse y)))))

    (define all-3*3-latin-squares
      (shuffle
        (cube->rows
          (map (compose permutations rotations)
            (list (list 0 1 2) (list 0 2 1))))))

   (define (randomize-third ls)
     (let f ([ls ls] [xs (shuffle ls)] [y (list)])
       (if (null? ls) (reverse y)
           (receive (a b)
             (break
               (let ([x (car ls)])
                 (lambda (y) (lset= = x y)))
               xs)
             (f (cdr ls) (append a (cdr b))
               (cons (car b) y))))))

    (define (randomize-vertically grid)
      (concatenate
        (triplets transpose
          (map randomize-third
            (triplets concatenate (cube->blocks grid))))))

   (define (randomize-triplets grid)
     (concatenate
       (concatenate
         (randomize-vertically
           (transpose
             (map concatenate
               (randomize-vertically grid)))))))

    (define (swap-occurences grid)
      (map (let ([indexes
                  (list->vector (shuffle (iota 9 1)))])
             (lambda (x) (vector-ref indexes (- x 1))))
        grid))

    (define solution
      (list->vector
        (swap-occurences
          (randomize-triplets
            (permute
              (cube->rows
                (cube->blocks
                  (map
                    (lambda (xs i)
                      (split3
                        (map (lambda (x) (+ x (* i 3) 1))
                          xs)))
                    (cdr all-3*3-latin-squares)
                    (car all-3*3-latin-squares))))
              (list 0 3 6 1 4 7 2 5 8))))))))

(define-library (sudoku solver)
  (import (scheme base)) (export solve)
  (begin (define (incr! n) (set! n (+ n 1)))

    (define (push! x stack) (set! stack (cons x stack)))

    (define (pop! y stack)
      (set! y (car stack))
      (set! stack (cdr stack)))

    (define (vector->possibilities v)
      (let f ([i 0] [j 0] [ls (vector->list v)] [y (list)])
        (cond [(> j 8) (f (+ i 1) 0 ls y)]
          [(> i 8) (reverse y)]
          [else
           (let ([k (car ls)])
             (if (> k 0)
                 (f i (+ j 1) (cdr ls)
                   (cons (list i j (- k 1)) y))
                 (let g ([k 0] [y y])
                   (if (> k 8)
                       (f i (+ j 1) (cdr ls) y)
                       (g (+ k 1)
                         (cons (list i j k) y))))))])))

    (define-record-type <node>
      (node h l u i j k r d s) #f
      (h header set-header!) (l left set-left!)
      (u up set-up!) (i ival) (j jval) (k kval)
      (r right set-right!) (d down set-down!)
      (s size set-size!))

    (define (update-size! update constraint)
      (let ([constraint (header constraint)])
        (set-size! constraint
          (update (size constraint) 1))))

    (define (horizontal-restore! entry)
      (set-right! (left entry) entry)
      (set-left! (right entry) entry))

    (define (vertical-restore! entry)
      (update-size! + entry)
      (set-down! (up entry) entry)
      (set-up! (down entry) entry))

    (define (horizontal-delete! entry)
      (set-right! (left entry) (right entry))
      (set-left! (right entry) (left entry)))

    (define (vertical-delete! entry)
      (set-down! (up entry) (down entry))
      (set-up! (down entry) (up entry))
      (update-size! - entry))

    (define (make-headers)
      (let ([root (node #f #f #f #f #f #f #f #f #f)])
        (set-left! root root)
        (set-right! root root)
        (do ([i 0 (+ i 1)]) ((> i 3))
          (do ([j 0 (+ j 1)]) ((> j 8))
            (do ([k 0 (+ k 1)]) ((> k 8))
              (let ([constraint
                     (node #f (left root)
                       #f i j k root #f 0)])
                (set-header! constraint constraint)
                (set-up! constraint constraint)
                (set-down! constraint constraint)
                (horizontal-restore! constraint)))))
        root))

    (define (make-row! sudoku possibility)
      (apply
        (lambda (row column value)
          (let ([rule 0] [rules (make-vector 4 #f)]
                 [constraints
                  (vector
                    (lambda (i j)
                      (and (= i row) (= j column)))
                    (lambda (i j)
                      (and (= i row) (= j value)))
                    (lambda (i j)
                      (and (= i column) (= j value)))
                    (lambda (i j)
                      (and (= j value)
                        (= i (+ (* (floor-quotient row 3)
                                   3)
                                (floor-quotient
                                  column 3))))))])
            (do ([constraint (right sudoku)
                    (right constraint)])
                  ((vector-ref rules 3)
                   (vector->list rules))
              (and (= (ival constraint) rule)
                ((vector-ref constraints rule)
                   (jval constraint) (kval constraint))
                (vector-set! rules rule
                  (let ([hint
                          (node constraint #f
                            (up constraint) row
                            column value #f
                            constraint #f)])
                    (vertical-restore! hint)
                    hint))
                (incr! rule)))))
        possibility))

    (define (make-grid ls)
      (let ([grid (make-headers)])
        (for-each
          (lambda (possibilities)
            (apply
              (lambda (row-column row-value column-value
                        block-value)
                (set-left! row-column block-column)
                (set-right! row-column row-value)
                (set-left! row-value row-column)
                (set-right! row-value column-value)
                (set-left! column-value row-value)
                (set-right! column-value block-value)
                (set-left! block-value column-value)
                (set-right! block-value row-column))
              (make-row! grid possibilities)))
          (vector->possibilities ls))
        grid))

    (define (grid-for-each direction root f)
      (do ([x (direction root) (direction x)])
            ((eq? x root)) (f x)))

    (define (vertical-cover! constraint)
      (let ([constraint (header constraint)])
        (grid-for-each down constraint
          (lambda (possibility)
            (grid-for-each right possibility
              vertical-delete!)))
        (horizontal-delete! constraint)))

    (define (vertical-uncover! constraint)
      (let ([constraint (header constraint)])
        (grid-for-each up constraint
          (lambda (possibility)
            (grid-for-each right possibility
              vertical-restore!)))
        (horizontal-restore! constraint)))

    (define (horizontal-cover! possibility)
      (grid-for-each right possibility vertical-cover!))

    (define (horizontal-uncover! possibility)
      (grid-for-each left possibility vertical-uncover!))

    (define (optimal-branch sudoku)
      (let compare ([constraint sudoku] [minimum 9]
                    [ls (list)])
        (if (eq? constraint sudoku) (list minimum ls)
            (let ([n (size constraint)])
              (cond
                [(< minimum n)
                 (compare (right constraint) minimum ls)]
                [(= n minimum)
                 (compare (right constraint) minimum
                   (cons constraint ls))]
                [else (compare (right constraint)
                        n (list constraint))])))))

    (define (try! constraint clues search! cycles guesses
              undo?)
      (vertical-cover! constraint)
      (grid-for-each down constraint
        (lambda (possibility)
          (push! possibility clues)
          (horizontal-cover! possibility)
          (when undo?
            (search! cycles (+ guesses 1))
            (pop! possibility clues)
            (set! constraint (header possibility))
            (horizontal-uncover! possibility)))
      (when undo? (vertical-uncover! constraint)))

    (define (solve sudoku max-solutions)
      (let ([clues (list)] [solutions 0]
            [guesses 0] [cycles 0])
        (call-with-current-continuation
          (lambda (return)
            (let search! ([c 0] [g 0])
              (set! cycles c)
              (set! guesses g)
              (cond
                [(< max-solutions solutions)
                 (return (list solutions guesses cycles))]
                [(eq? (right sudoku) sudoku)
                 (incr! solutions)]
                [else
                 (let ([constraint
                        (optimal-branch sudoku)])
                   (cond
                     [(= (car constraint) 1)
                      (for-each
                        (lambda (hint)
                          (try! hint clues search! c g #f))
                        (cdr constraint))
                      (search! (+ c 1) g)]
                     [else (try! (car (cdr constraint))
                             clues search! c g #t)]))]))
            (return (list solutions guesses cycles))))))))

(define-library (sudoku generator)
  (import (scheme base) (srfi 1)
    (only (srfi 27) default-random-source
      random-source-randomize!)
    (only (gauche sequence) shuffle)
    (sudoku solver) (sudoku printing) (sudoku grid))
  (export get-args display-greetings rate-sudoku
    initial-prune! remove-useless! add-useful!)
  (begin (define sudoku)

    (random-source-randomize!default-random-source)

    (define (get-args args)
      (if (< (length args) 3) (initial-prune! 23 800)
          (apply initial-prune! (cdr args))))

    (define (display-greetings)
      (display
        (string-append
          "SamDoku-Generator.ss\n\n"
          "This program is 3-clause BSD-licensed!\n\n"
          "Author: Samuel Duclos\n"
          "\tJanuary 2017\n\n"
          "No warranties, no responsibilities!\n\n")))

    (define (rate-sudoku)
      (let ([rating (cdr (solve sudoku 1))])
        (display-stat "Guesses" (car rating))
        (display-stat "Cycles" (cadr rating))))

    (define (initial-prune! initial-clues max-solutions)
      (print "Solution:")
      (print-sudoku solution)
      (display-stat "Maximum solutions per try"
        max-solutions)
      (print "Randomly pruning...")
      (let ([v (make-vector 81 0)])
        (for-each
          (lambda (i)
            (vector-set! v i (vector-ref solution i)))
          (take (shuffle (iota 81)) initial-clues))
        (let ([n (car (solve v max-solutions))])
          (cond [(< n max-solutions)
                 (print-sudoku v)
                 (display-stat "Solutions" n)
                 (set! sudoku v)]
            [else (initial-prune initial-clues
                    max-solutions)]))))

    (define (make-updater eq update)
      (lambda (grid)
        (filter-map
          (lambda (i)
            (and (eq (vector-ref grid i) 0)
              (let ([g (vector-copy grid)])
                (vector-set! g i (update i))))
                g)))
          (iota 81))))

    (define prunes (make-updater > (lambda (i) 0)))

    (define adds
      (make-updater =
        (lambda (i) (vector-ref solution i))))

    (define (unique-solutions grids)
      (filter (lambda (x) (= (car (solve x 1)) 1)) grids))

    (define (not-useless grids)
      (filter (lambda (x) (> (car (solve x 1)) 0)) grids))

    (define (add-useful!)
      (print "Adding clues until only one solution remains…")
      (let f ([grids (list sudoku)])
        (let ([ls (unique-solutions grids)])
          (if (null? ls) (f (concatenate (map adds grids)))
              (set! sudoku ls))))
      (display-stat "Possible solution(s) to optimize"
        (length sudoku))
      (print-sudoku (car sudoku)))

    (define (remove-useless!)
      (print "Removing useless clues…")
      (let f ([grids sudoku])
        (let ([ls (not-useless grids)])
          (if (null? ls)
              (set! sudoku (car (unique-solutions grids)))
              (f (concatenate (map prunes ls))))))
      (print-sudoku sudoku))))

(import (scheme base) (sudoku generator))
(display-greetings)
(get-args (command-line))
(add-useful!)
(remove-useless!)
(rate-sudoku)