;; see On Lisp, section 6.
(use srfi-1)

(define (setup-nodes)
  (defnode 'people "Is the person a man?" 'male 'female)
  (defnode 'male "Is he living?" 'liveman 'deadman)
  (defnode 'female 'Babette)
  (defnode 'liveman 'Sjaak)
  (defnode 'deadman 'Lincoln))

;; ----------------------------------------------------------------------
;; representation with data structure and code (interpreter)
(define nodes (make-hash-table))

(define (defnode name contents . args)
  (let-optionals* args ((yes #f) (no #f))
    (hash-table-put! nodes name (list contents yes no))))

(define (node-contents node) (first node))
(define (node-yes node) (second node))
(define (node-no node) (third node))

(define (run-node name)
  (let ((node (hash-table-get nodes name)))
    (cond ((node-yes node)
           (print (node-contents node))
           (case (read)
             ((yes) (run-node (node-yes node)))
             (else (run-node (node-no node)))))
          (else (node-contents node)))))

(setup-nodes)
(print (run-node 'people))

;; ----------------------------------------------------------------------
;; representation with closures
(define nodes (make-hash-table))

(define (defnode name contents . args)
  (let-optionals* args ((yes #f) (no #f))
    (hash-table-put! nodes name
                     (if yes
                         (lambda ()
                           (print contents)
                           (case (read)
                             ((yes)
                              ((hash-table-get nodes yes)))
                             (else
                              ((hash-table-get nodes no)))))
                         (lambda () contents)))))

(setup-nodes)
(print ((hash-table-get nodes 'people)))

;; ----------------------------------------------------------------------
;; compiled network
(define nodes '())

(define (defnode . args)
  (set! nodes (cons args nodes)))

(define (compile-net root)
  (let ((node (assoc root nodes)))
    (if (null? node)
        '()
        (let-optionals* node (name contents (yes #f) (no #f))
          (print (list name contents yes no))
          (if yes
              (let ((yes-fn (compile-net yes))
                    (no-fn (compile-net no)))
                (lambda ()
                  (print contents)
                  (flush-all-ports)
                  (if (eq? (read) 'yes)
                      (yes-fn)
                      (no-fn))))
              (lambda () contents))))))

(setup-nodes)
(define net (compile-net 'people))
(print "compilation done.")

;; After compile-net has run we can dump the nodes list, because
;; *everything* was compiled into code -- the tell-tale sign of a
;; compiler. The first two implementations don't allow this.
;; (define nodes nil)

(print (net))

;; ----------------------------------------------------------------------
;; Note that compile-net compiles in both senses. It compiles in the
;; general sense, by translating the abstract representation of the
;; network into code. Moreover, if compile-net itself is compiled, it
;; will return compiled functions. (see pp 25) (*)

;; (*) pp 25: Later chapters will depend on another effect of
;; compilation: when one function occurs within another function, and
;; the containing function is compiled, the inner function will also
;; get compiled. CLTL2 does not seem to say explicitly that this will
;; happen, but in a decent implementation you can count on it.  The
;; compiling of inner functions becomes evident in functions which
;; return functions. When make-adder (page 18) is compiled, it will
;; return compiled functions:
;;
;; > (compile 'make-adder)
;; MAKE-ADDER
;; > (compiled-function-p (make-adder 2))
;; T
;; 
;; As later chapters will show, this fact is of great importance in
;; the implementation of embedded languages. If a new language is
;; implemented by transformation, and the transformation code is
;; compiled, then it yields compiled output -- and so becomes in
;; effect a compiler for the new language.