;; elimbel.scm
;; S-ElimBel - Copyright Nicolas Thiery, November 95
;;
;; Permission to use, copy, and distribute this software
;; for any purpose and without fee is hereby granted,
;; provided that this notice an the name of the author
;; appear in all copies. This software is provided "as is"
;; without express or implied warranty.
;;
;; Bayesian Network propagation of belief
;; using the Elim-Bel Algorithm (R. Dechter)
;; implemented with MIT Scheme

;; USAGE: (load "elimbel.scm")
;;        (get-belief (order dag evidence))

;; For more details,
;; see http://www.spaces.uci.edu/thiery/elimbel

;;;;;;;;;;;;;;;;

(define display-mode 0)
;
; Specifies the verbose mode
; 0 -> no verbose
; 1 -> small verbose
; 2 -> verbose

(define get-belief (lambda (order dag evidence)
;
; Computes the belief given an order, a dag, and a set of evidences
; (see for instance "example.scm")
;
 (let
  ((last-bucket (show-time (lambda ()
    (reduce-buckets-list
     (get-buckets-list order (append dag evidence)))))))
  (begin
   (display "\nBelief-")
   (display (car last-bucket))
   (display (caadr last-bucket))
   (display " = ")
   (display (cdadr last-bucket))))))

(define get-buckets-list (lambda (order functions-list)
;
; Transforms a list of functions into a list of buckets
; for the order given
;
 (if (null? order) '()
  (let*
   ((node (car order))
    (function-of-node? (lambda (function)
     (member node (car function)))))
   (cons (cons node
     (list-transform-positive functions-list function-of-node?))
    (get-buckets-list
     (cdr order)
     (list-transform-negative functions-list function-of-node?)))))))

(define reduce-function-by-sum (lambda (function)
;
; Given a function f(x,y,z,...), computes f(y,z,...) by summing
; on the first variable x
;
 (let
  ((error-message
    "ERROR WHILE SUMMING - THE INPUT DATA IS PROBABLY INVALID"))
  (letrec
   ((add-rec (lambda (a b)
     (if (and (null? a) (null? b))
      '()
      (if (or (null? a) (null? b))
       (error error-message)
       (if (and (list? a) (list? b))
        (cons (add-rec (car a) (car b)) (add-rec (cdr a) (cdr b)))
        (if (not (or (list? a) (list? b)))
         (+ a b)
         (error error-message))))))))
   (cons (cdar function) (reduce add-rec 0 (cdr function)))))))

(define normalize-function (lambda (function)
;
; Normalizes a function so that its sum on the first variable
; becomes equal to 1 (analogous to the alpha operator of the book)
;
 (let
  ((arguments (car function))
   (content (cdr function))
   (sum-content (cdr (reduce-function-by-sum function))))
  (letrec
   ((divide-content (lambda (content sum-content)
     (letrec
      ((divide (lambda (a b)
        (if (list? a)
         (if (null? a) '()
          (cons (divide (car a) (car b)) (divide (cdr a) (cdr b))))
         (/ a b)))))
      (if (null? content) '()
       (cons (divide (car content) sum-content)
        (divide-content (cdr content) sum-content)))))))
   (cons arguments (divide-content content sum-content))))))

(define reduce-buckets-list (lambda (buckets-list)
;
; Given a list of buckets, computes the sum of the top
; bucket, then add this sum to the next bucket, and return
; the reduced list of buckets (that is the initial list of
; buckets minus the top bucket and with the modified next
; bucket)
;
 (letrec
  ((singleton? (lambda (list) (null? (cdr list))))
   (bucket (car buckets-list))
   (add-function-to-buckets-list (lambda (function buckets-list)
    (let*
     ((bucket (car buckets-list))
      (node (car bucket)))
     (if (member node (car function))
      (cons (cons node
        (cons function (cdr bucket))) (cdr buckets-list))
      (cons bucket
        (add-function-to-buckets-list function (cdr buckets-list))))))))
  (begin
   (display-buckets-list buckets-list)
   (if (singleton? buckets-list)
    (cons (car bucket)
     (cons (normalize-function
       (compute-function (car bucket) (cdr bucket)))
      '()))
    (reduce-buckets-list
     (add-function-to-buckets-list
      (reduce-function-by-sum (compute-function (car bucket) (cdr bucket)))
      (cdr buckets-list))))))))

(define compute-function (lambda (node functions-list)
;
; Computes the sum of several functions relatively to a node
; (typically used to compute the sum of a bucket relatively to its node)
;
 (letrec
  ((compute-function-2 (lambda (f g)
    (if (and (null? (car f)) (null? (car g)))
     (cons '() (* (cdr f) (cdr g)))
     (let*
      ((fg-nodes (append (car f) (car g)))
       (factorizing-node (if (member node fg-nodes) node (car fg-nodes)))
       (factorized-f (factorize factorizing-node f))
       (factorized-g (factorize factorizing-node g))
       (compute-1-factorized (lambda (u v swap?)
        (let*
         ((u-nodes-list (cdar u))
          (v-compute (lambda (u-value)
           (if swap?
            (compute-function-2 v (cons u-nodes-list u-value))
            (compute-function-2 (cons u-nodes-list u-value) v)))))
         (map v-compute (cdr u)))))
       (fg-sub-functions-list (if (not (car factorized-g))
        (compute-1-factorized (cdr factorized-f) g #f)
        (if (not (car factorized-f))
         (compute-1-factorized (cdr factorized-g) f #t)
         (let
          ((f-nodes-list (cdadr factorized-f))
           (g-nodes-list (cdadr factorized-g)))
          (letrec
           ((fg-compute (lambda (f-values-list g-values-list)
             (if (or (null? f-values-list) (null? g-values-list)) '()
              (cons (compute-function-2
                (cons f-nodes-list (car f-values-list)) 
                (cons g-nodes-list (car g-values-list)))
               (fg-compute (cdr f-values-list) (cdr g-values-list)))))))
           (fg-compute (cddr factorized-f) (cddr factorized-g)))))))
       (fg-sub-factorized-nodes (caar fg-sub-functions-list))
       (nfg-factorized-nodes (cons factorizing-node fg-sub-factorized-nodes)))
      (cons nfg-factorized-nodes (map cdr fg-sub-functions-list)))))))
  (fold-left compute-function-2
   (cdr (factorize node (car functions-list))) (cdr functions-list)))))

(define factorize (lambda (node function)
;
; Given a function f(n1,n2,...) and a node z, it returns
; (#t . f(z,ni...)) if z is among the nis
; (#f . f(n1,n2,...)) otherwise
; (this is very useful when we want to sum all the functions
; in a bucket - we first factorize all the functions relatively
; to the bucket's node, then it becomes straightforward to sum them)
;
 (letrec
  ((cons-rec (lambda (list)
    (let ((reversed-list (reverse list))
      (error-message
       "ERROR WHILE FACTORIZING - THE INPUT DATA IS PROBABLY INVALID"))
     (letrec
      ((cons-rec-2 (lambda (acc element)
        (if (and (null? acc) (null? element)) '()
         (if (or (null? element) (null? acc))
          (error error-message)
          (if (and (list? acc) (list? element))
           (cons (cons-rec-2 (car acc) (car element))
            (cons-rec-2 (cdr acc) (cdr element)))
           (if (and (not (list? element)) (list? acc))
            (cons element acc)
            (if (and (list? element) (not (list? acc)))
             (erro error-message)
             (cons element (cons acc '()))))))))))
      (fold-left cons-rec-2 (car reversed-list) (cdr reversed-list)))))))
  (if (member node (car function))
   (cons #t
    (if (equal? (caar function) node) function
     (cdr (factorize node
      (cons
       (append (cdar function) (cons (caar function) '()))
       (cons-rec (cdr function)))))))
   (cons #f function)))))

; Below are several tools to display intermediate and
; final results
;
(define display-functions-list (lambda (functions-list)
;
; Displays a list of functions:
;
 (if (null? functions-list) (newline)
  (begin
   (newline)
   (display ";;   L")
   (display (caar functions-list))
   (display "=")
   (display (cdar functions-list))
   (display-functions-list (cdr functions-list))))))

(define display-buckets-list (lambda (buckets-list)
;
; Displays a list of buckets:
; (depends on "display-mode" which sets the verbose mode)
; (see on top)
;
 (letrec
  ((c-display-functions-list (lambda (functions-list)
    (if (null? functions-list) '()
     (begin
      (display " L")
      (display (caar functions-list))
      (c-display-functions-list (cdr functions-list)))))))
  (if (zero? display-mode) '()
   (if (null? buckets-list) (newline)
    (begin
     (newline)
     (display ";; bucket-")
     (display (caar buckets-list))
     (display ":")
     (if (= display-mode 1)
      (c-display-functions-list (cdar buckets-list))
      (if (= display-mode 2)
       (display-functions-list (cdar buckets-list))))
     (display-buckets-list (cdr buckets-list))))))))