;;; Derived from Paul Graham's "On Lisp"

(define make-context (lambda () (box (list final-path))))
(define set-paths! (lambda (context v) (set-box! context v)))
(define paths (lambda (context) (unbox context)))
(define push-path!
  (lambda (v)
    (set-paths! *context*
      (cons v (paths *context*)))))
(define pop-path!
  (lambda ()
    (let ([t (car (paths *context*))])
      (set-paths! *context* (cdr (paths *context*)))
      t)))
(define initialize-paths!
  (lambda ()
    (push-path! final-path)))

(define final-path
  (lambda ()
    (initialize-paths!)
    (abort 'abort)))

(define abort
  (lambda (v)
    (display v)
    (newline)
    (#%reset)))

(define *context* (make-context))

(define reset-paths!
  (lambda ()
    (set-paths! *context* '())
    (initialize-paths!)))

(define fail
  (lambda ()
    (let ((t (pop-path!)))
      (if (or (number? t) (symbol? t))
	  (fail)
	  (t)))))

(define choose
  (lambda (choose-list)
    (call/cc
      (lambda (return)
        (letrec
          ((loop 
             (lambda (choose-list)
               (cond
                 ((null? choose-list) (fail))
                 (else (push-path! (lambda () (loop (cdr choose-list))))
		   (return (car choose-list)))))))
          (loop choose-list))))))
                                                  
(define mark
  (lambda (sym)
    (push-path! sym)))

(define cut
  (lambda (sym)
    (let ((path (pop-path!)))
      (if (not (eq? path sym)) (cut sym)))))

;;;  Test programs start here.
(define displayln
  (lambda args
    (for-each (lambda (x) (display x) (display " ")) args) (newline)))

(define simple-test
  (lambda ()
    (initialize-paths!)
    (write (choose '(1 2 3 4 5 6 7 8 9))) 
    (newline) 
    (fail)))

(define easy-test
  (lambda ()
    (initialize-paths!)
    (let ((x (choose '(1 2 3))))
      (let ((y (choose '(a b c d e))))
	(displayLn x y)
	(fail)))))

(define subtle-test
  (lambda ()
    (initialize-paths!)
    (write 
      ((choose (list (lambda () 5)  (lambda () (/ 30 0))  (lambda () 17)))))
    (newline)
    (fail)))

(define driver
  (lambda ()
    (initialize-paths!)
    (find-boxes '(paris nice nancy))))

(define find-boxes
  (lambda (cities)
    (let ((random-store-numbers (gen-random-list 5)))
      (let ((city (choose cities)))
        (displayLn city)
        (mark 'foo)
        (let ((store (choose random-store-numbers)))
          (displayLn "     Store Number: " store)
          (let ((box (choose '(1 2 3 4  5 6 7))))
            (displayLn "          Box Number: " box)
            (if (coin? city store box)
              (begin
               (cut 'foo)
               (displayLn  "- - - - - - - - - ->>>> found")))
            (fail)))))))

(define coin?
  (lambda  (city store box)
    (member (list city store box)
            '((paris 1 2) (nice 1 3) (nancy 4 2)))))

(define gen-random-list
  (lambda (x)
    (let loop ((n (+ (random  x) 1))  (acc '()))
         (cond
           ((zero? n)  acc)
           (else (let ((new-random (+ (random x) 1)))
                   (if (member new-random acc)
                     (loop n acc)
                     (loop (- n 1) (cons  new-random acc)))))))))

(define queens
  (lambda (n)
    (initialize-paths!)
    (let ((board  (iota n)))
      (let ((answer (map (lambda (q) (choose board)) board)))
        (if (legal-board? answer) (displayLn answer))
        (fail)))))

(define legal-board?
  (lambda (answer)
    (let loop  ((rboard  (reverse answer)) (so-far '()))
      (cond
        ((null? rboard) #t)
        (else 
          (and
            (legal? (car rboard) so-far)
            (loop (cdr rboard) (cons (car rboard) so-far))))))))

(define legal?
   (lambda (try answer)
    (let loop ((new-pl answer) (up (+ try 1)) (down (- try 1)))
      (cond
        ((null? new-pl) #t)
        (else (let ((next-pos (car new-pl)))
                (and
                  (not (= next-pos try))
                  (not (= next-pos up))
                  (not (= next-pos down))
                  (loop (cdr new-pl) (+ up 1) (- down 1)))))))))

(define iota
  (lambda (n)
    (cond
      ((zero? n) '())
      (else (cons n (iota (- n 1)))))))

;;;  Efficient algorithm for queens:

(define an-answer
  (lambda (size length)
    (cond
      ((zero? length) '())
      (else (cons? size size (an-answer size (- length 1)))))))

(define cons?
  (lambda (size try answer)
    (cond
      ((zero? try) (cond
                     ((null? answer) (abort 'not-an-answer))
                     (else (cons? size size 
                             (cons? size (- (car answer)  1) (cdr answer))))))
      ((legal? try answer) (cons try answer))
      (else (cons? size (- try 1) answer)))))

(define all-answers
  (lambda (i size an-answer)
    (displayLn i ": " an-answer)
    (all-answers (+ i 1) size 
      (cons? size (- (car an-answer) 1) (cdr an-answer)))))

(define quick-queens
  (lambda (size)
    (all-answers 1 size (an-answer size size))))

(define test-all
  (lambda ()
    (call/cc
      (lambda (k)
	(set! abort k)
	(simple-test)))
    (call/cc
      (lambda (k)
	(set! abort k)
	(easy-test)))
    (call/cc
      (lambda (k)
	(set! abort k)
        (driver)))
    (call/cc
      (lambda (k)
	(set! abort k)
        (driver)))
    (call/cc
      (lambda (k)
	(set! abort k)
        (quick-queens 8)))
    (call/cc
      (lambda (k)
	(set! abort k)
        (queens 5)))
    (call/cc
      (lambda (k)
	(set! abort k)
	(subtle-test)))))

;> (test-all)
;1
;2
;3
;4
;5
;6
;7
;8
;9
;1 a 
;1 b 
;1 c 
;1 d 
;1 e 
;2 a 
;2 b 
;2 c 
;2 d 
;2 e 
;3 a 
;3 b 
;3 c 
;3 d 
;3 e 
;paris 
;     Store Number:  2 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 Box Number:  7 
;     Store Number:  4 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 
;          Box Number:  7
;      Store Number:  5
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 
;          Box Number:  7
;      Store Number:  1 
;          Box Number:  1 Box Number:  2 
;- - - - - - - - - ->>>> found 
;nice 
;     Store Number:  2 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 Box Number:  7 
;     Store Number:  4 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6  Box Number:  7 
;     Store Number:  5 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 Box Number:  7 
;     Store Number:  1 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;- - - - - - - - - ->>>> found 
;nancy 
;     Store Number:  2 
;          Box Number:  1 Box Number:  2 Box Number:  3 
;          Box Number:  4 Box Number:  5 Box Number:  6 Box Number:  7 
;     Store Number:  4 
;          Box Number:  1 Box Number:  2 
;- - - - - - - - - ->>>> found

;1 :  (5 7 2 6 3 1 4 8) ;2 :  (4 7 5 2 6 1 3 8) ;3 :  (6 4 7 1 3 5 2 8) 
;4 :  (6 3 5 7 1 4 2 8) ;5 :  (4 2 8 6 1 3 5 7) ;6 :  (5 3 1 6 8 2 4 7) 
;7 :  (6 3 1 8 5 2 4 7) ;8 :  (4 6 1 5 2 8 3 7) ;9 :  (4 2 5 8 6 1 3 7) 
;10 :  (5 8 4 1 3 6 2 7) ;11 :  (6 3 5 8 1 4 2 7) ;12 :  (5 2 4 6 8 3 1 7) 
;13 :  (3 5 7 1 4 2 8 6) ;14 :  (3 5 2 8 1 7 4 6) ;15 :  (8 2 5 3 1 7 4 6) 
;16 :  (3 1 7 5 8 2 4 6) ;17 :  (3 7 2 8 5 1 4 6) ;18 :  (5 2 8 1 4 7 3 6) 
;19 :  (4 1 5 8 2 7 3 6) ;20 :  (5 1 8 4 2 7 3 6) ;21 :  (7 2 4 1 8 5 3 6) 
;22 :  (8 2 4 1 7 5 3 6) ;23 :  (7 4 2 5 8 1 3 6) ;24 :  (5 7 2 4 8 1 3 6) 
;25 :  (4 2 8 5 7 1 3 6) ;26 :  (3 5 8 4 1 7 2 6) ;27 :  (4 8 5 3 1 7 2 6) 
;28 :  (4 7 3 8 2 5 1 6) ;29 :  (3 6 2 7 1 4 8 5) ;30 :  (7 2 6 3 1 4 8 5) 
;31 :  (2 6 8 3 1 4 7 5) ;32 :  (4 8 1 3 6 2 7 5) ;33 :  (8 4 1 3 6 2 7 5) 
;34 :  (6 3 1 8 4 2 7 5) ;35 :  (3 6 8 2 4 1 7 5) ;36 :  (2 4 6 8 3 1 7 5) 
;37 :  (2 6 1 7 4 8 3 5) ;38 :  (4 6 8 2 7 1 3 5) ;39 :  (7 4 2 8 6 1 3 5) 
;40 :  (6 3 7 4 1 8 2 5) ;41 :  (3 8 4 7 1 6 2 5) ;42 :  (1 6 8 3 7 4 2 5) 
;43 :  (7 1 3 8 6 4 2 5) ;44 :  (4 2 7 3 6 8 1 5) ;45 :  (6 3 7 2 4 8 1 5) 
;46 :  (3 7 2 8 6 4 1 5) ;47 :  (6 2 7 1 3 5 8 4) ;48 :  (3 6 2 7 5 1 8 4) 
;49 :  (5 7 2 6 3 1 8 4) ;50 :  (2 8 6 1 3 5 7 4) ;51 :  (8 3 1 6 2 5 7 4) 
;52 :  (6 1 5 2 8 3 7 4) ;53 :  (3 6 2 5 8 1 7 4) ;54 :  (2 5 7 1 3 8 6 4) 
;55 :  (5 3 1 7 2 8 6 4) ;56 :  (7 3 8 2 5 1 6 4) ;57 :  (7 5 3 1 6 8 2 4) 
;58 :  (6 3 1 7 5 8 2 4) ;59 :  (3 6 8 1 5 7 2 4) ;60 :  (1 5 8 6 3 7 2 4) 
;61 :  (5 1 8 6 3 7 2 4) ;62 :  (7 3 1 6 8 5 2 4) ;63 :  (2 7 3 6 8 5 1 4) 
;64 :  (6 3 7 2 8 5 1 4) ;65 :  (5 2 6 1 7 4 8 3) ;66 :  (5 1 4 6 8 2 7 3) 
;67 :  (6 4 1 5 8 2 7 3) ;68 :  (5 7 1 4 2 8 6 3) ;69 :  (4 2 7 5 1 8 6 3) 
;70 :  (2 5 7 4 1 8 6 3) ;71 :  (1 7 5 8 2 4 6 3) ;72 :  (2 7 5 8 1 4 6 3) 
;73 :  (4 8 1 5 7 2 6 3) ;74 :  (5 8 4 1 7 2 6 3) ;75 :  (4 7 1 8 5 2 6 3) 
;76 :  (6 2 7 1 4 8 5 3) ;77 :  (6 8 2 4 1 7 5 3) ;78 :  (1 7 4 6 8 2 5 3) 
;79 :  (6 4 7 1 8 2 5 3) ;80 :  (6 4 2 8 5 7 1 3) ;81 :  (4 7 5 3 1 6 8 2) 
;82 :  (3 6 4 1 8 5 7 2) ;83 :  (4 1 5 8 6 3 7 2) ;84 :  (5 7 4 1 3 8 6 2) 
;85 :  (5 3 8 4 7 1 6 2) ;86 :  (3 6 8 1 4 7 5 2) ;87 :  (4 6 8 3 1 7 5 2) 
;88 :  (5 7 1 3 8 6 4 2) ;89 :  (3 6 4 2 8 5 7 1) ;90 :  (3 5 2 8 6 4 7 1) 
;91 :  (5 2 4 7 3 8 6 1) ;92 :  (4 2 7 3 6 8 5 1)

;(3 5 2 4 1) ;(2 5 3 1 4) ;(1 4 2 5 3) ;(2 4 1 3 5) ;(5 3 1 4 2) ;(1 3 5 2 4) 
;(4 2 5 3 1) ;(5 2 4 1 3) ;(4 1 3 5 2) ;(3 1 4 2 5)

;5

;Error in /: undefined for 0.
;Type (debug) to enter the debugger.