;;;;;;;;;;
;;
;; Bayes network solver
;;
;; Based on the Recursive Decomposition Algorithm of Greg Cooper.
;; G. F. Cooper. Bayesian belief-network inference using nested dissection.
;; Technical Report KSL-90-05, Stanford University, Knowledge Systems
;; Laboratory, Stanford, California, Jan. 1990.
;;
;;;;;;;;;;

;; An interface for defining Bayes nets
;; A simple two-node network might be defined as follows:
;;
;; (define-bnet 'sample1
;;   '((A () (.6 .4) (black white))
;;     (B (A) ((.8 .2) (.3 .7)))))
;; 
;; Each node is specified by
;; a name,
;; a list of its parent nodes (by name),
;; a conditional probability distribution, (defaults to uniform dist)
;; a list of possible values of the node (defaults to (false true))
;;
;; A special notation is available to define conditional probability
;; distributions that are based on the "noisy or" assumption.  Instead of
;; giving a conditional probability distribution, one can give the expression:
;; (noisy-or leak-probability causal-probability1 ...)
;; There must be as many causal probabilities as the node has parents, and
;; each parent must be a binary variable.  (It need not be (false true), but
;; the first value is taken to be false, the second as true.)

(define (bnet-node-named name bnet)
  (let ((bnv (bnet-nodes bnet)))
    (do ((i (- (vector-length bnv) 1) (- i 1))
         (ans #f))
        ((or ans (< i 0)) (if ans ans 
                              (error 'bnet-node-named
                               "Name ~s doesn't correspond to a node."
                               name)))
      (if (eq? name (bn-name (vector-ref bnv i)))
        (set! ans (vector-ref bnv i))))))

(define (define-bnet name node-list)
  (let* ((bnv (make-vector (length node-list)))
         (bnet (make-bnet name bnv '())))
    ;; First fill in BN's from the node-list, but leaving parents, children,
    ;; and cdist unresolved because they depend on having all the nodes already.
    (do ((i 0 (+ 1 i))
         (nl node-list (cdr nl)))
        ((null? nl))
      (let* ((nspec (car nl))
             (nname (car nspec))
             (npar (if (not (null? (cdr nspec)))
                     (cadr nspec) '()))
             (npdist (and (not (null? (cdr nspec)))
                          (not (null? (cddr nspec)))
                          (caddr nspec)))
             (nvals (and (not (null? (cdr nspec)))
                         (not (null? (cddr nspec)))
                         (not (null? (cdddr nspec)))
                         (cadddr nspec))) ) 
        (vector-set!
         bnv
         i
         (make-bn nname 
                  npar 
                  '() 
                  (or (and nvals (length nvals)) 2)
                  (or (and nvals (list->vector nvals)) f/t-vec)
                  npdist))))
    ;; Now the node structures are as needed, but the list of parents is
    ;; given by name rather than as an actual list of the nodes, the
    ;; children list needs to be computed from the parents, and conditional
    ;; probability tables need to be computed if defaulted, or at least
    ;; checked for correct size and turned into arrays.
    ;; First compute actual parents links:
    (dovector bnv
      (lambda (bn) 
        (set-bn-parents! bn
                         (map (lambda (name) (bnet-node-named name bnet))
                              (bn-parents bn)))))
    ;; Second invert the lists of parents to compute a list of children for
    ;; each node.
    (dovector bnv
      (lambda (bn)
        (dolist (bn-parents bn)
                (lambda (parent)
                  (set-bn-children! parent
                                    (cons bn (bn-children parent)))))))
    ;; Third, go over all the conditional distributions and
    ;; if there is one, check that its shape corresponds to the parents
    ;; structure; if not, then create one representing a uniform distribution
    (dovector bnv
      (lambda (bn)
        (let ((cdist (bn-cdist bn))
              (dims (map bn-n-values (append (bn-parents bn) (list bn)))))
          (cond ((not cdist)         ;; default to uniform dist
                 (set-bn-cdist! bn (make-uniform-cdist dims)))
                ((and (pair? cdist) (eq? (car cdist) 'noisy-or))
                 (set-bn-cdist! bn 
                                (make-noisy-or-array
                                 bn
                                 (bn-parents bn)
                                 (if (not (null? (cdr cdist)))
                                   (cddr cdist)
                                   '())
                                 (if (not (null? (cdr cdist)))
                                   (cadr cdist)
                                   0.0))))
                ((check-array-shape cdist dims)
                 (set-bn-cdist! 
                  bn
                  (make-array (normalize-cdists cdist))))
                (else (error 'define-bnet
          "Bad specification of conditional probability distribution: ~s"
          cdist))))))
    ;; Fourth, compute the Markov blanket and neighborhood size of each node.
    (dovector bnv
      (lambda (bn)
        (set-bn-Markov! bn (Markov bn))
        (set-bn-neighborhood-size! bn (+ (length (bn-parents bn))
                                      (length (bn-children bn))))))
    (dissect bnet)
    bnet))

(define (make-uniform-cdist dims)
  ;; This is like make-array, but instead of taking a nested list of the
  ;; initial contents, it takes the array-dimensions list and an initializes
  ;; all values to a uniform distribution.
  (define (ma l val)
    (if (null? l)
      val
      (let ((v (make-vector (car l))))
        (dotimes (car l) 
                 (lambda (i) 
                   (vector-set! v i (ma (cdr l) 
                                        (exact->inexact (/ 1 (car l)))))))
        v)))
  (if (not (null? dims))
    (ma dims 1.0)
    (cons zero-dim-array-marker 1.0)))


;; Defines a way to express noisy-or assumption in Bayes nets.

(define (make-noisy-or-array node parents causal-probs leak-prob)
  ;; Creates a conditional probability table that implements the
  ;; noisy-or assumption.  This concept is well-defined only in the
  ;; case of all binary variables.  Causal-probs holds a list of the
  ;; "causal" probabilities of node given each of its parents.
  (define (probability? p)
    (and (real? p) (<= 0.0 p 1.0)))
  (define (pnot vals)
    ;; Computes the probability (under the noisy-or assumption) that
    ;; node is FALSE given the assignments of values to its parents in
    ;; vals.  Each TRUE parent contributes a factor of (1 - cp) where
    ;; cp is the causal probability from that parent to the node.
    ;; FALSE parents contribute nothing.
    (let iter ((vl vals) (cpl causal-probs) (ans 1.0))
      (if (null? vl)
          ans
          (iter (cdr vl) (cdr cpl) 
                (if (zero? (car vl)) 
                    ans 
                    (* (- 1.0 (car cpl)) ans))))))
  (define (inner nodes val-list)
    (if (null? nodes)
        ;; Leaves of the tree
        ;; Probability of 
        (let ((not-prob (* (pnot val-list) (- 1.0 leak-prob))))
          (list not-prob (- 1.0 not-prob)))
        (list (inner (cdr nodes) (append val-list (list 0)))
              (inner (cdr nodes) (append val-list (list 1))))))
  (let ((nodes (append parents (list node))))
    (if (or (not (= (length parents) (length causal-probs)))
            (not (every? causal-probs probability?))
            (not (probability? leak-prob))
            (not (every? nodes (lambda (n) (= (bn-n-values n) 2)))))
        (error 'make-noisy-or-array
               "Error making noisy-or array"))
    (make-array (normalize-cdists (inner parents '())))))

(define (check-array-shape lis dims)
  ;; Checks to make sure that an array, expressed in list-of-lists notation,
  ;; is the right shape to fill a rectangular array whose dimensions are in 
  ;; dims
  (if (null? dims)
    (not (pair? lis))
    (and (pair? lis)
         (= (length lis) (car dims))
         (every? lis 
                 (lambda (sublis) (check-array-shape sublis (cdr dims)))))))

;; Some utilities that manage sets of nodes.

(define all-children-of-set
  (reducer bn-children union empty-set))

(define all-parents-of-set
  (reducer bn-parents union empty-set))

(define (theta x)
  ;; computes the set consisting of the elements of x and all their parents
  (union x (all-parents-of-set x)))

(define (Markov bn)
  ;; The Markov blanket of a node is the union of its parents, children and
  ;; spouses, where spouses are other parents of its children.  It does not
  ;; include the node itself.
  (let ((ch (bn-children bn)))
    (setdiff (union (bn-parents bn)
                    ch
                    (all-parents-of-set ch))
             (make-set bn))))

(define (neighborhood-size bn)
  (+ (cardinality (bn-parents bn))
     (cardinality (bn-children bn))))

(define (init-bn bn)
  (set-bn-Markov! bn (Markov bn))
  (set-bn-neighborhood-size! bn (neighborhood-size bn)))

;;;;;;;;;;
;;
;; The top-level dissect function.

(define (dissect bnet)
  ;; This procedure analyzes the current structure of the Bayes Net,
  ;; computes the nested decomposition (dissection), and calculates the
  ;; total probability of all states (which should be 1.0)
  ;; Any nodes that have known assigned values are unassigned first, so that
  ;; dissection uses the network in its full generality.
  (dovector (bnet-nodes bnet) reset-index)
  (set-bnet-dissection-tree! bnet '())
  (set-bnet-dissection-tree! bnet (CDT bnet))
  (let ((save-pinned-values '())
        (temp '()))
    (dovector (bnet-nodes bnet)
      (lambda (n) (if (bn-flagged n)
                    (begin (set! save-pinned-values 
                                 (cons (cons n (bn-pinned-value n))
                                       save-pinned-values))
                           (set-bn-pinned-value! n '())
                           (set-bn-flagged! n #f)))))
    (let ((fval (Cooper bnet)))
      (dolist save-pinned-values
              (lambda (spv)
                (let ((node (car spv)))
                  (set-bn-flagged! node #t)
                  (set-bn-pinned-value! node (cdr spv))
                  (reset-caches node))))
      fval)))

(define (infer BNET instantiations)
  ;; Instantiations is a list of 2-lists, where each contains the name of
  ;; a variable in BNET and one of its values.
  (infer* BNET
          (map (lambda (inst)
                 (let* ((node (bnet-node-named (car inst) bnet))
                        (val (vector-position (cadr inst)
                                              (bn-value-vector node))))
                   (if val
                     (cons node val)
                     (error 'infer
                          "Value specified for instantiation, ~s, is not a valid
value for the node"
                          inst))))
               instantiations)))

(define (infer* BNET instantiations)
  "Instantiations is an alist of (node . value) pairs.  The value is an index
   into the value-set of the variable.  We compute the 
   probability that this set of instantiations is present in the network."
  (let ((insts empty-set))
    (if (null? (BNET-dissection-tree BNET))    
      (dissect BNET))
    (dovector (BNET-nodes BNET)
      (lambda (n)
        (let* ((new-inst-spec (assq n instantiations))
               (new-val (and new-inst-spec (cdr new-inst-spec)))
               (old-flagged (BN-flagged n))
               (old-val (BN-pinned-value n)))
          ;; The cases of interest are:
          ;; 1.  Value was pinned but is no longer: reset cache
          ;; 2.  Value was not pinned but now is: reset cache
          ;; 3.  Value is and was pinned, but to different values: reset cache
          ;; 4.  otherwise, leave cache intact.  This occurs only if there is&was no
          ;;     value or if the value happened to be the same.
          (cond (old-flagged
                 (cond (new-val
                        (cond ((not (eqv? old-val new-val))      ;case 3
                               (set-BN-pinned-value! n new-val)
                               (reset-caches n))))
                       (else            ;case 1
                        (set-BN-pinned-value! n '())
                        (set-BN-flagged! n #f)
                        (reset-caches n))))
                (new-val                ;case 2
                 (set-BN-flagged! n #t)
                 (set-BN-pinned-value! n new-val)
                 (reset-caches n)))     ;; case 4a
          )
        (if (BN-flagged n) (set! insts (union insts (make-set n))))))
    (Cooper BNET)))

(define (current-conditional bn)
  ;; Assuming that this node and all its parents have pinned values, this
  ;; retrieves the conditional probability of the pinned value of this node
  ;; given the pinned values of all its parents' nodes.
  (aref* (BN-cdist bn)
         (map bn-pinned-value (append (bn-parents bn) (list bn)))))

;;;;;;;;;;
;;
;; Utilities that manipulate the indices and caches in the dissection tree.

(define (reset-index bn)
  (set-bn-indexed-records! bn '()))

(define (add-to-index bn rec)
  (set-bn-indexed-records! bn (cons rec (bn-indexed-records bn))))

(define (create-inst-cache set-of-vars bnet)
  ;; makes an array (vector of vectors of ... of vectors) that can hold a
  ;; value for any combination of values of set-of-vars.
  (make-array-init (map bn-n-values set-of-vars) '()))

(define (reset-cache rec)
  (reset-array (instantiation-cache rec)))

(define (reset-caches bn)
  (dolist (bn-indexed-records bn) reset-cache))

;;;;;;;;;;
;;
;; Utilities that manipulate arrays

(define zero-dim-array-marker (list 'zero-dim-array-marker))

(define (zero-dim-array? a)
  (and (pair? a) (eq? (car a) zero-dim-array-marker)))
(define zero-dim-array-val cdr)
(define zero-dim-array-set! set-cdr!)

(define (reset-array a)
  ;; An array is a vector of subarrays.  Therefore, recur until we find a
  ;; vector of non-vectors, then reset those values.
  (define (ra a)
    (let ((k (vector-length a)))
      (if (< k 1)
        'done
        (if (vector? (vector-ref a 0))
          (dotimes k (lambda (i) (reset-array (vector-ref a i))))
          (dotimes k (lambda (i) (vector-set! a i '())))))))
  (if (zero-dim-array? a)
    (zero-dim-array-set! a '())
    (ra a)))

(define (aref* array index-list)
  ;; We walk down the vector of subarrays until we get to the end of the
  ;; index list, when we must have the value.  We just have a special
  ;; treatment for a zero-dimensional
  (define (iter array index-list)
    (if (null? index-list)
      array
      (iter (vector-ref array (car index-list)) (cdr index-list))))
  (if (null? index-list)
    (if (zero-dim-array? array)
      (zero-dim-array-val array)
      (error 'aref* "Array ~s accessed as scalar is not." array))
    (iter array index-list)))

(define (aref*-set! array index-list val)
  ;; Handle zero-dim array specially; returns val.
  (define (iter array il last-v last-i)
    (if (null? il)
      (if (null? last-i)
        (error 'aref*-set!
             "Dimenstion mismatch setting ~s to ~s"
              array
              val)
        (vector-set! last-v last-i val))
      (iter (vector-ref array (car il))
            (cdr il)
            array
            (car il))))
  (if (null? index-list)
    ;; better have a zero-dim array
    (if (zero-dim-array? array)
      (zero-dim-array-set! array val)
      (error 'aref*-set! "Dimenstion mismatch setting ~s to ~s" array val))
    (iter array index-list '() '()))
  val)

(define (make-array l)
  ;; This would be very simple if we didn't need to deal with the case of
  ;; the zero-dimensional array, which is in fact a scalar.  To have a place in
  ;; which to store that scalar value, we have a special convention.
  ;; l is a list of lists representation of an array, in row-major order.
  (define (ma l)
    (if (pair? l)
      (list->vector (map ma l))
      l))
  (if (pair? l)
    (ma l)
    (cons zero-dim-array-marker l)))

(define (make-array-init l init-val)
  ;; This is like make-array, but instead of taking a nested list of the
  ;; initial contents, it takes the array-dimensions list and an initial
  ;; value to which to initialize all elements.
  (define (ma l)
    (if (null? l)
      init-val
      (let ((v (make-vector (car l))))
        (dotimes (car l) (lambda (i) (vector-set! v i (ma (cdr l)))))
        v)))
  (if (not (null? l))
    (ma l)
    (cons zero-dim-array-marker init-val)))

(define (normalize-cdists l)
  ;; l is a nested set of lists of conditional probabilities, where the last index
  ;; varies over the variable of interest, and earlier indices correspond to the
  ;; conditioning variable.  We need to normalize each set of probs over the last
  ;; index.
  (define (inner v)
    (cond ((null? v))
          ((not (pair? (car v)))
           ;; this is the final-indexed set; normalize it
           (let ((sum (apply + v)))
             (do ((vl v (cdr vl)))
                 ((null? vl))
               (set-car! vl (exact->inexact (/ (car vl) sum))))))
          (else (dolist v inner))))
  (inner l)
  l)

;;(define cd1 '(((.8 .2) (1 20))
;;              ((3 8) (100 11))))
;; (normalize-cdists cd1)

;;;;;;;;;;
;;
;; Globals for dissection algorithm:
;;

(define *max-sweeps* 3) ; Max number of sweeps in CDT; must be >= 1
(define *balance* 0.4 ) ; Min size of smaller set created by bisect, 0<=b<=.5
(define *max-state-space* 536870911)    ; largest exact number (fixnum) in sci
;;  OK to abandon dissection if state space exceeds this.

(define (CDT bnet)
  (constructrecord empty-set
                   (vector->list (bnet-nodes bnet))     ; all nodes
                   bnet))

(define (ConstructRecord H X BNET)
  (if (not (empty? X))
       (let* ((bsv (Bisect X H BNET))
              (BestA (car bsv))
              (BestB (cadr bsv))
              (BestS (caddr bsv)))
         (let* ((H-U-BestS (union H BestS))
                (Q (those (intersection X H-U-BestS)
                          (lambda (v) (subset? (bn-parents v) H-U-BestS))))
                (K-BestA (all-children-of-set BestA))
                (K-BestA-A-X (intersection K-BestA X))
                (Y (union BestA K-BestA-A-X))
                (Z (setdiff (union BestB BestS) K-BestA-A-X))
                (Y-Q (setdiff Y Q))
                (Z-Q (setdiff Z Q))
                (Y-rec (ConstructRecord (intersection (theta Y-Q) H-U-BestS)
                                        Y-Q
                                        BNET))
                (Z-rec (ConstructRecord (intersection (theta Z-Q) H-U-BestS)
                                        Z-Q
                                        BNET))
                (new-rec (make-rec
                          (setdiff BestS H)     ; :summation-set
                          Q             ; :evaluation-set
                          H             ; :instantiation-set
                          (setdiff X H)         ; :variable-set
                          (create-inst-cache H BNET)    ; :instantiation-cache
                          Y-rec         ; :net-y-ptr
                          Z-rec)))      ; :net-z-ptr
           (dolist (variable-set new-rec)
                   (lambda (n)
                     (add-to-index n new-rec)))
           new-rec))
       '()))

(define show-bisect #f)       ;; trace bisection

(define (Bisect X H BNET)
  ;; Ugly transliteration of a CommonLisp program:
  ;; this could be done more elegantly with a nested tail-recursion, but the
  ;; compiler is not smart enough to avoid the recursion here, so we grunge
  ;; it in terms of DO.
  (let* ((V (setdiff X H))
         (Vl (cardinality V)))
    (if (= 1 Vl)
      (list empty-set (setdiff X V) V)
      (let* ((low (truncate (* *balance* Vl)))
             (high (- Vl (if (zero? low) 1 low)))
             (middle (truncate (/ Vl 2)))
             (BestA #f) 
             (BestB #f)
             (BestS #f)
             (best-score #f)
             (A empty-set)
             (B empty-set)
             (S empty-set))
        (define (U-function v) 
          (union (setdiff S (make-set v))
                 (intersection B (BN-Markov v))))
        (cond
         (show-bisect
          (display `(bisect-start x ,(node-names x)
                                    h ,(node-names h)
                                      v ,(node-names v)))
          (newline)))
        (do ((sweep *max-sweeps*
                    ;; count down only if SOME solution
                    ;; but also if there is already a perfect solution, stop
                    (if BestS (- sweep 1) sweep))
             (ordered-nodes (sort V
                                  (lambda (a b)
                                    (< (bn-neighborhood-size a)
                                       (bn-neighborhood-size b))))
                            (cdr ordered-nodes)))
            ((or (null? ordered-nodes) 
                 (<= sweep 0) 
                 (and best-score (<= best-score 1)))
             (if (not best-score)
               ;; this means no acceptable bisection occurred
               (error 'Bisect  "No acceptable bisection"))
             (cond (show-bisect
                    (display `(done-bisect bestA ,(node-names bestA)
                                           bestB ,(node-names bestB)
                                           bestS ,(node-names bestS)))
                    (newline)))
             (list BestA BestB BestS))
          (set! A empty-set)
          (set! S (make-set (car ordered-nodes)))
          (set! B (setdiff X S))
          (cond (show-bisect
                 (display `(bisect-loop sweep ,sweep 
                                  ordered-nodes ,(node-names ordered-nodes)))
                 (newline)
                 (display `(a ,(node-names a) 
                              b ,(node-names b)
                                s ,(node-names s)))
                 (newline)))
          (let loop ()
            (if (empty? (setdiff S H))
              (let* ((ve (make-set
                          (find-element-with-characteristic-value 
                           min BN-neighborhood-size
                               (setdiff B H)
                               BNET))))
                (set! S (union ve S))
                ;; ve is in B-H, so must've been in B.
                (set! B (setdiff B ve))
                (cond (show-bisect
                       (display `(added-to-s ve ,(node-names ve)
                                                s ,(node-names s)
                                                  b ,(node-names b)))
                       (newline)))))
            (let* ((ve (find-element-with-characteristic-value
                        min (lambda (v) 
                              (state-space-size
                               (setdiff (U-function v) H)
                               BNET))
                            S BNET)))
              ;; Need a parallel set!
              (let ((new-a (union (make-set ve) A))
                    (new-b (setdiff B (BN-Markov ve))) ;; B - (B int M(v))
                    (new-s (U-function ve)))
                (set! A new-a)
                (set! B new-b)    
                (set! S new-s))
              (cond (show-bisect
                     (display `(bisect
                                moved ,(bn-name ve) to A
                                a ,(node-names a) 
                                  b ,(node-names b)
                                    s ,(node-names s)))
                     (newline)))
              (if (> (state-space-size (setdiff S H) BNET)
                     *max-state-space*)
                ;; abandon search from this seed, but don't count as a sweep
                (begin (cond (show-bisect
                              (display `(abandon search
                                                 size
                                                 ,(state-space-size 
                                                   (setdiff S H) BNET)))
                              (newline)))
                       #t)
                (begin
                  (if (<= low (cardinality A) high)
                    (let ((n-S-H (state-space-size (setdiff S H) BNET)))
                      (if (or (not best-score)
                              (< n-S-H best-score)
                              (and (= n-S-H best-score)
                                   (< (abs (- (cardinality A) middle))
                                      (abs (- (cardinality BestA)
                                              middle)))))
                        (begin
                          (set! BestA A)
                          (set! BestB B)
                          (set! BestS S)
                          (set! best-score n-S-H)
                          (cond (show-bisect
                                 (display
                                  `(new best 
                                        ,n-S-H
                                        bestA ,(node-names bestA)
                                        bestB ,(node-names bestB)
                                        bestS ,(node-names bestS)))
                                 (newline)))))))
                  (if (= (cardinality A) high)
                    (begin (cond (show-bisect
                                  (display `(A too big ,high))
                                  (newline)))
                           #t)
                    (loop)))))))))))

(define (state-space-size S BNET)
  ((reducer bn-n-values * 1) s))

(define (find-element-with-characteristic-value 
         characteristic-fn value-fn S BNET)
  ;; finds the (an) element of S with the "characteristic-fn" value computed
  ;; by value-fn.
  (let ((cur-val #f) (the-val #f) (the-item #f))
    (dolist s
            (lambda (n)
              (set! cur-val (value-fn n))
              (set! the-val
                    (if (not the-val)
                        cur-val
                        (characteristic-fn the-val cur-val)))
              (if (eqv? cur-val the-val)
                  (set! the-item n))))
    the-item))

;;;;;;;;;;;;;;;;
;;
;;  The evaluation procedure
;;

(define set-cc-product
  (reducer current-conditional * 1.0))
  

(define (Cooper BNET)
  (let ((inst-set empty-set))
    (define (Cooper-evaluate evaluation-set)
      (set-cc-product evaluation-set))
    (define (inner rec)
      ;; (display `(Cooper-inner ,(show-rec rec))) (newline)
      (if (null? rec)
        1.0
        (let* ((iset-vals (map BN-pinned-value (instantiation-set rec)))
               (cache (instantiation-cache rec))
               (cached-val (aref* cache iset-vals)))
          (cond ((not (null? cached-val)) cached-val)
                (else
                 (aref*-set! 
                  cache iset-vals
                  (let ((sum 0.0))
                    (define (sum-over remaining-nodes)
                      (if (null? remaining-nodes)
                        (let* ((CE (Cooper-evaluate (evaluation-set rec)))
                               (CY (if (zero? CE)
                                     0.0
                                     (inner (net-y-ptr rec))))
                               (CZ (if (zero? CY)
                                     0.0
                                     (inner (net-z-ptr rec)))))
                          (set! sum (+ sum (* CE CY CZ))))
                        (let ((node (car remaining-nodes)))
                          (dotimes (BN-n-values node)
                            (lambda (i)
                              (set-BN-pinned-value! node i)
                              (sum-over (cdr remaining-nodes))))
                          (set-BN-pinned-value! node '()))))
                    (sum-over (setdiff (summation-set rec) inst-set))
                    (abs sum))))))))
    (dovector (BNET-nodes BNET)
      (lambda (n)
        (if (BN-flagged n)
          (set! inst-set (union inst-set (make-set n))))))
    (inner (BNET-dissection-tree BNET))))