;; ATNs: Augmented Transition Networks (OnLisp, chp 23)
(require 'stdlib)

;; see also: SICP 4.3

;; prerequisite:
;; section 22.3: Scheme implementation of choose and fail
(define paths nil)
(define failsym '@)

;; NOTE this version of choose will run into trouble when fed cyclic
;; graphs. A truely non-deterministic version `true-choose' is on
;; pp 304, fig 22.14.
(define (choose choices)
  (if (null choices)
      (fail)
    (call-with-current-continuation
     (lambda (cc)
       (setq paths
             (cons (lambda ()
                     (cc (choose (rest choices))))
                   paths))
       (first choices)))))

(define fail)

(call-with-current-continuation
 (lambda (cc)
   (setq fail
         (lambda ()
           (if (null paths)
               (cc failsym)
             (let ((p1 (first paths)))
               (setq paths (rest paths))
               (p1)))))))

;; on-lisp example, fig 22.3, pp 291
(define (two-numbers)
  (list (choose '(0 1 2 3 4 5))
        (choose '(0 1 2 3 4 5))))

(define (parlor-trick sum)
  (let ((nums (two-numbers)))
    (if (= (apply + nums) sum)
        `(the sum of ,@nums)
      (fail))))

;;(puts (parlor-trick 7))

;; Common Lisp implementation of choose/fail without real
;; continuations, but using continuation-passing macro's instead
(define mpaths nil)
(define mfailsym '@)

(defmacro mchoose (#!rest choices)
  (if choices
      `(progn ,@(mapcar (lambda (c)
                          (push (lambda () c) mpaths))
                        (reverse (cdr choices)))
              ,(car choices))
    '(mfail)))

(define (mfail)
  (if mpaths
      (funcall (pop mpaths))
    mfailsym))

;; interactive:
;; > (choose '(a b c))
;; a
;; > (fail)
;; b
;; > (fail)
;; c
;; > (fail)
;; @

;; ----------------------------------------------------------------------
;; SICP 4.3.2
;; The following puzzle (taken from Dinesman 1968) is typical of a
;; large class of simple logic puzzles:
;;
;; Baker, Cooper, Fletcher, Miller, and Smith live on different floors
;; of an apartment house that contains only five floors. Baker does
;; not live on the top floor. Cooper does not live on the bottom
;; floor. Fletcher does not live on either the top or the bottom
;; floor. Miller lives on a higher floor than does Cooper. Smith does
;; not live on a floor adjacent to Fletcher's. Fletcher does not live
;; on a floor adjacent to Cooper's. Where does everyone live?

(define (require. p)
  (unless p (fail)))

(define (distinct? seq)
  (cond ((null seq) t)
        ((memq (first seq) (rest seq)) nil)
        (t (distinct? (rest seq)))))

(define (multiple-dwelling)
  (let ((baker (choose '(1 2 3 4 5)))
        (cooper (choose '(1 2 3 4 5)))
        (fletcher (choose '(1 2 3 4 5)))
        (miller (choose '(1 2 3 4 5)))
        (smith (choose '(1 2 3 4 5))))
    (require.
     (distinct? (list baker cooper fletcher miller smith)))
    (require. (not (= baker 5)))
    (require. (not (= cooper 1)))
    (require. (not (= fletcher 5)))
    (require. (not (= fletcher 1)))
    (require. (> miller cooper))
    (require. (not (= (abs (- smith fletcher)) 1)))
    (require. (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

;;(puts (multiple-dwelling))

;; ----------------------------------------------------------------------
;; parsing natural language
(define nouns '(noun student professor cat class))
(define verbs '(verb studies lectures eats sleeps))
(define articles '(article the a))
(define prepositions '(prep for to in by with))

(define (parse-sentence)
  (list 'sentence
        (parse-noun-phrase)
        (parse-verb-phrase)))

(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(define (parse-noun-phrase)
  (define (maybe-extend noun-phrase)
    (choose noun-phrase
            (maybe-extend (list 'noun-phrase
                                noun-phrase
                                (parse-prepositional-phrase)))))
  (maybe-extend (parse-simple-noun-phrase)))

(define (parse-prepositional-phrase)
  (list 'prep-phrase
        (parse-word prepositions)
        (parse-noun-phrase)))

(define (parse-verb-phrase)
  (define (maybe-extend verb-phrase)
    (choose verb-phrase
            (maybe-extend (list 'verb-phrase
                                verb-phrase
                                (parse-prepositional-phrase)))))
  (maybe-extend (parse-word verbs)))

(define (parse-word word-list)
  (require. (not (null *unparsed*)))
  (require. (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (car *unparsed*)))
    (setq *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

(define *unparsed* '())
(define (parse input)
  (setq *unparsed* input)
  (let ((sent (parse-sentence)))
    (require. (null *unparsed*))
    sent))

;; ----------------------------------------------------------------------
;; infinite lists (SICP 4.3.1): FIXME
;;(define (choose #!rest choices)
;;  (if (null choices)
;;      (fail)
;;    (call-with-current-continuation
;;     (lambda (cc)
;;       (setq paths
;;             (cons (lambda ()
;;                     (cc (choose (rest choices))))
;;                   paths))
;;       (first choices)))))

;;(define (an-integer-starting-from n)
;;  (choose n (an-integer-starting-from (1+ n))))

;;(let ((num1 (an-integer-starting-from 1))
;;      (num2 (an-integer-starting-from 1)))
;;  (if (= (apply + num1 num2) 10)
;;      (printf "%s + %s = 10\n" num1 num2)
;;    (fail)))

;; ----------------------------------------------------------------------
;; ATN

;; TODO