#lang scheme
;;; PLT Scheme Inference Collection
;;; inference.ss
;;; Copyright (c) 2006-2008 M. Douglas Williams
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA.
;;;
;;; Version Date     Comment
;;; 1.0.1   07/16/06 Added fields for next-assertion-id and
;;;                  assertion-index (Doug Williams)
;;; 1.0.2   07/19/06 Added trace field.  (Doug Williams)
;;; 1.0.3   07/22/06 Added agenda and rule fields.  (Doug Williams)
;;; 1.0.4   07/23/06 Added strategy field.  (Doug Williams)
;;; 1.0.5   07/24/06 Added hierarchical inference environments.
;;;                  (Doug Williams)
;;;
;;; To do:
;;; 1) Replace simple list form of agenda with a double linked form.

;;; inverence-environment: struct
;;;   0 data-index         hash-table?
;;;   1 goal-index         hash-table?
;;;   2 rule-nodes         list?
;;;   3 exit               continuation? or #f
;;;   4 next-assertion-id  natural-number
;;;   5 assertion-index    hash-table?
;;;   6 trace              boolean?
;;;   7 agenda             list?
;;;   8 rule               rule?
;;;   9 strategy           symbol?
;;;  10 parent             inference-environment? or #f
(define-values (struct:inference-environment
                inference-environment-constructor
                inference-environment?
                inference-environment-field-ref
                set-inference-environment-field!)
  (make-struct-type 'inference-environment #f 12 0))

;;; data-index field
(define inference-environment-data-index
  (make-struct-field-accessor
   inference-environment-field-ref 0 'data-index))

(define set-inference-environment-data-index!
  (make-struct-field-mutator
   set-inference-environment-field! 0 'data-index))

;;; goal-index field
(define inference-environment-goal-index
  (make-struct-field-accessor
   inference-environment-field-ref 1 'goal-index))

(define set-inference-environment-goal-index!
  (make-struct-field-mutator
   set-inference-environment-field! 1 'goal-index))

;;; rule-nodes field
(define inference-environment-rule-nodes
  (make-struct-field-accessor
   inference-environment-field-ref 2 'rule-nodes))

(define set-inference-environment-rule-nodes!
  (make-struct-field-mutator
   set-inference-environment-field! 2 'rule-nodes))

;;; exit field
(define inference-environment-exit
  (make-struct-field-accessor
   inference-environment-field-ref 3 'exit))

(define set-inference-environment-exit!
  (make-struct-field-mutator
   set-inference-environment-field! 3 'exit))

;;; next-assertion-id field
(define inference-environment-next-assertion-id
  (make-struct-field-accessor
   inference-environment-field-ref 4 'next-assertion-id))

(define set-inference-environment-next-assertion-id!
  (make-struct-field-mutator
   set-inference-environment-field! 4 'next-assertion-id))

;;; assertion-index field
(define inference-environment-assertion-index
  (make-struct-field-accessor
   inference-environment-field-ref 5 'assertion-index))

(define set-inference-environment-assertion-index!
  (make-struct-field-mutator
   set-inference-environment-field! 5 'assertion-index))

;;; trace field
(define inference-environment-trace
  (make-struct-field-accessor
   inference-environment-field-ref 6 'trace))

(define set-inference-environment-trace!
  (make-struct-field-mutator
   set-inference-environment-field! 6 'trace))

;;; agenda field
(define inference-environment-agenda
  (make-struct-field-accessor
   inference-environment-field-ref 7 'agenda))

(define set-inference-environment-agenda!
  (make-struct-field-mutator
   set-inference-environment-field! 7 'agenda))

;;; rule field
(define inference-environment-rule
  (make-struct-field-accessor
   inference-environment-field-ref 8 'rule))

(define set-inference-environment-rule!
  (make-struct-field-mutator
   set-inference-environment-field! 8 'rule))

;;; strategy field
(define inference-environment-strategy
  (make-struct-field-accessor
   inference-environment-field-ref 9 'strategy))

(define set-inference-environment-strategy!
  (make-struct-field-mutator
   set-inference-environment-field! 9 'strategy))

;;; parent field
(define inference-environment-parent
  (make-struct-field-accessor
   inference-environment-field-ref 10 'parent))

(define set-inference-environment-parent!
  (make-struct-field-mutator
   set-inference-environment-field! 10 'parent))

;;; rules-fired field
(define inference-environment-rules-fired
  (make-struct-field-accessor
   inference-environment-field-ref 11 'rules-fired))

(define set-inference-environment-rules-fired!
  (make-struct-field-mutator
   set-inference-environment-field! 11 'rules-fired))

;;; make-inference-environment: inference-environment? ->
;;;   inference-environment?
;;; make-inference-environment: -> inference-environment?
(define (make-inference-environment (parent #f))
  (inference-environment-constructor
   (make-hasheq)                      ; data-index
   (make-hasheq)                      ; goal-index
   '()                              ; rule-nodes
   #f                               ; exit
   1                                ; next-assertion-id
   (make-hasheq)                      ; assertion-index
   #f                               ; trace
   '()                              ; agenda
   #f                               ; rule
   'depth                           ; strategy
   parent                           ; parent
   0                                ; rules-fired
   ))

;;; default-inference-environment variable
(define default-inference-environment
  (make-inference-environment))

;;; current-inference-enironment parameter
(define current-inference-environment
  (make-parameter
   default-inference-environment
   (lambda (x)
     (when (not (inference-environment? x))
       (raise-type-error 'current-inference-environment
                         "inference-environment" x))
     x)))

;;; current-inference-data-index: -> hash-table?
;;; current-inference-data-index: hash-table?
(define current-inference-data-index
  (case-lambda
    (()
     (inference-environment-data-index
      (current-inference-environment)))
    ((data-index)
     (set-inference-environment-data-index!
      (current-inference-environment) data-index))))

;;; current-inference-goal-index: -> hash-table?
;;; current-inference-goal-index: hash-table?
(define current-inference-goal-index
  (case-lambda
    (()
     (inference-environment-goal-index
      (current-inference-environment)))
    ((goal-index)
     (set-inference-environment-goal-index!
      (current-inference-environment) goal-index))))

;;; current-inference-rule-nodes: -> list?
;;; current-inference-rule-nodes: list?
(define current-inference-rule-nodes
  (case-lambda
    (()
     (inference-environment-rule-nodes
      (current-inference-environment)))
    ((rule-nodes)
     (set-inference-environment-rule-nodes!
      (current-inference-environment) rule-nodes))))

;;; current-inference-exit: -> continuation? or #f
;;; current-inference-exit: continuation? or #f
(define current-inference-exit
  (case-lambda
    (()
     (inference-environment-exit
      (current-inference-environment)))
    ((exit)
     (set-inference-environment-exit!
      (current-inference-environment) exit))))

;;; current-inference-next-assertion-id: -> natural-number
;;; current-inference-next-assertion-id: natural-number
(define current-inference-next-assertion-id
  (case-lambda
    (()
     (inference-environment-next-assertion-id
      (current-inference-environment)))
    ((next-assertion-id)
     (set-inference-environment-next-assertion-id!
      (current-inference-environment) next-assertion-id))))

;;; current-inference-assertion-index: -> hash-table?
;;; current-inference-assertion-index: hash-table?
(define current-inference-assertion-index
  (case-lambda
    (()
     (inference-environment-assertion-index
      (current-inference-environment)))
    ((assertion-index)
     (set-inference-environment-assertion-index!
      (current-inference-environment) assertion-index))))

;;; current-inference-trace: -> boolean?
;;; current-inference-trace: boolean?
(define current-inference-trace
  (case-lambda
    (()
     (inference-environment-trace
      (current-inference-environment)))
    ((trace)
     (set-inference-environment-trace!
      (current-inference-environment) trace))))

;;; current-inference-agenda: -> list?
;;; current-inference-agenda: list?
(define current-inference-agenda
  (case-lambda
    (()
     (inference-environment-agenda
      (current-inference-environment)))
    ((agenda)
     (set-inference-environment-agenda!
      (current-inference-environment) agenda))))

;;; current-inference-rule: -> rule? or #f
;;; current-inference-rule: rule? or #f
(define current-inference-rule
  (case-lambda
    (()
     (inference-environment-rule
      (current-inference-environment)))
    ((rule)
     (set-inference-environment-rule!
      (current-inference-environment) rule))))

;;; current-inference-strategy: -> symbol?
;;; current-inference-strategy: symbol?
(define current-inference-strategy
  (case-lambda
    (()
     (inference-environment-strategy
      (current-inference-environment)))
    ((strategy)
     (set-inference-environment-strategy!
      (current-inference-environment) strategy))))

;;; current-inference-parent: -> inference-environment? or #f
;;; current-inference-parent: inference-environment? or #f
(define current-inference-parent
  (case-lambda
    (()
     (inference-environment-parent
      (current-inference-environment)))
    ((parent)
     (set-inference-environment-parent!
      (current-inference-environment) parent))))

;;; current-inference-rules-fired: -> integer?
;;; current-inference-rules-fired: integer?
(define current-inference-rules-fired
  (case-lambda
    (()
     (inference-environment-rules-fired
      (current-inference-environment)))
    ((rules-fired)
     (set-inference-environment-rules-fired!
      (current-inference-environment) rules-fired))))

;;; (with-inference-environment inference-environment
;;;   body ..)
(define-syntax with-inference-environment
  (syntax-rules ()
    ((with-inference-environment inference-environment
                                 body ...)
     (parameterize ((current-inference-environment
                     inference-environment))
       body ...))))

;;; (with-new-inference-environment
;;;   body ...)
(define-syntax with-new-inference-environment
  (syntax-rules ()
    ((with-new-inference-environment
      body ...)
     (parameterize ((current-inference-environment
                     (make-inference-environment)))
       body ...))))

;;; (with-new-child-inference-environment
;;;   body ...)
(define-syntax with-new-child-inference-environment
  (syntax-rules ()
    ((with-new-child-inference-environment
      body ...)
     (parameterize ((current-inference-environment
                     (make-inference-environment
                      (current-inference-environment))))
       body ...))))

(provide
 default-inference-environment
 current-inference-environment
 with-inference-environment
 with-new-inference-environment
 with-new-child-inference-environment)

(provide/contract
 (inference-environment?
  (-> any/c boolean?))
 (make-inference-environment
  (->* () (inference-environment?) inference-environment?))
 (inference-environment-data-index
  (-> inference-environment? hash?))
 (inference-environment-goal-index
  (-> inference-environment? hash?))
 (inference-environment-rule-nodes
  (-> inference-environment? list?))
 (inference-environment-exit
  (-> inference-environment? (or/c procedure? false/c)))
 (set-inference-environment-exit!
  (-> inference-environment? (or/c procedure? false/c) void?))
 (inference-environment-next-assertion-id
  (-> inference-environment? exact-positive-integer?))
 (set-inference-environment-next-assertion-id!
  (-> inference-environment? exact-positive-integer? void?))
 (inference-environment-assertion-index
  (-> inference-environment? hash?))
 (inference-environment-trace
  (-> inference-environment? boolean?))
 (inference-environment-agenda
  (-> inference-environment? any))
 (set-inference-environment-agenda!
  (-> inference-environment? any/c void?))
 (inference-environment-rule
  (-> inference-environment? any))
 (set-inference-environment-rule!
  (-> inference-environment? any/c void?))
 (inference-environment-strategy
  (-> inference-environment? symbol?))
 (set-inference-environment-strategy!
  (-> inference-environment? symbol? void?))
 (inference-environment-parent
  (-> inference-environment? (or/c inference-environment? false/c)))
 (set-inference-environment-parent!
  (-> inference-environment? (or/c inference-environment? false/c) void?))
 (inference-environment-rules-fired
  (-> inference-environment? exact-nonnegative-integer?))
 (current-inference-data-index
  (case->
   (-> hash?)
   (-> hash? void?)))
 (current-inference-goal-index
  (case->
   (-> hash?)
   (-> hash? void?)))
 (current-inference-rule-nodes
  (case->
   (-> list?)
   (-> list? void?)))
 (current-inference-exit
  (case->
   (-> (or/c procedure? false/c))
   (-> (or/c procedure? false/c) void?)))
 (current-inference-next-assertion-id
  (case->
   (-> exact-positive-integer?)
   (-> exact-positive-integer? void?)))
 (current-inference-assertion-index
  (case->
   (-> hash?)
   (-> hash? void?)))
 (current-inference-trace
  (case->
   (-> boolean?)
   (-> boolean? void?)))
 (current-inference-agenda
  (case->
   (-> any)
   (-> any/c void?)))
 (current-inference-rule
  (case->
   (-> any)
   (-> any/c void?)))
 (current-inference-strategy
  (case->
   (-> symbol?)
   (-> symbol? void?)))
 (current-inference-parent
  (case->
   (-> (or/c inference-environment? false/c))
   (-> (or/c inference-environment? false/c) void?)))
 (current-inference-rules-fired
  (case->
   (-> exact-nonnegative-integer?)
   (-> exact-nonnegative-integer? void?)))
 )