chain.rkt
#lang racket/base
;;; chain.rkt -- A simple rule based expert system
;;; by Patrick King, 2009, Gnu LPGL.

;; forward-chain presents a "cond"-like syntax, but every predicate is evaluated at least once,
;; and each set of consequences is evaluated no more than once
(provide forward-chain)

(define-syntax try-rule
  (syntax-rules ()
    ((try-rule vfired ifired restart-chain (predicate consequence ...))
     (cond
       ((vector-ref vfired ifired)null)
       (predicate
        (vector-set! vfired ifired #t)
        consequence ...
        (restart-chain))))))

(define-syntax expand-rule
  (syntax-rules ()
    ((expand-rule vfired ifired restart-chain last-rule)
     (try-rule vfired ifired restart-chain last-rule))
    ((expand-rule vfired ifired restart-chain this-rule next-rule ...)
     (begin
       (try-rule vfired ifired restart-chain this-rule)
       (expand-rule vfired (add1 ifired) restart-chain next-rule ...)))))

(define-syntax-rule (forward-chain rule ...)
  (let ((vfired (make-vector (length '(rule ...)) #f)))
    (let/cc restart-chain
      (expand-rule vfired 0 restart-chain  rule ...))))

;;; Some test cases
;(forward-chain (#t (display "Hello, World!")
;                   (newline)))
;; A common idiom is to stop processing when some goal is reached
;(let ((red #t)
;      (white 'unknown)
;      (green #t)
;      (blue #t))
;  (let/ec break-chain
;    (forward-chain
;     ((and red white blue)
;      (display "All American")
;      (break-chain))
;     ((and red green blue)
;      (set! white #t))
;     (#t (display "Should never get here.")
;         (error)))))