;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code written by R. Williams, last modified Nov. 3, 2003.
;;;
;;; Warning: This code is designed to work with a Bayes net file
;;; that has been properly constructed.  It performs no sanity
;;; checking whatsoever.  For example, if there are loops in the
;;; network topology, the topological sort will go into an infinite
;;; loop.  Similarly, if the value lists, parent lists, etc. are
;;; incorrect in any way, this will lead to errors that may be hard
;;; to track down.  For example, attempting to retrieve probability
;;; values from the CPT using this code may yield values of NIL
;;; in such situations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These utilities are not directly dependent on the details of the
;;; Bayes net data structure.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; returns a list of vars where parents always appear before their children
(defun topological-sort-vars (bn)
  (let* ((topology (get-vars-with-parents bn))
	 (ordered-nodes nil))
    (loop
     (if (null topology) (return (reverse ordered-nodes)))
     (dolist (node-data topology)
       (let ((node (first node-data))
	     (node-parents (rest node-data)))
	 (if (null node-parents)
	     (progn
	       (push node ordered-nodes)
	       (setf topology
		     (remove nil
			     (mapcar #'(lambda (l) (remove node l))
				     topology)))
	       (return))))))))

;; a distribution is assumed to be a list of elements having the form
;; (symbol-1 ... symbol-k number), which specifies the relative probability
;; of each particular combination of values for k query variables
(defun normalize (distrib)
  (let* ((nums (mapcar #'(lambda (l) (first (last l))) distrib))
	 (probs (normalize-nums nums))
	 (val-combos (mapcar #'butlast distrib)))
    (mapcar #'(lambda (l n) (append l (list n))) val-combos probs)))

(defun normalize-nums (alon)
  (let ((sum (apply #'+ alon)))
    (mapcar #'(lambda (x) (/ x sum)) alon)))

;; look up values for the given vars and list them in same order
;; - used as a helper to access appropriate CPT values
(defun list-vals-for (vars vars-with-vals)
  (if (null vars)
      nil
      (cons (second (assoc (first vars) vars-with-vals))
	    (list-vals-for (rest vars) vars-with-vals))))

;; vars-with-vals is a list of the form ((var-1 val-1) ... (var-n val-n))
;; returns nil if var doesn't appear in vars-with-vals
(defun get-val (var vars-with-vals)
  (let ((var-val-pair (assoc var vars-with-vals)))
    (if var-val-pair (second var-val-pair) nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These utilities are directly dependent on the details of the
;;; Bayes net data structure.  To see how a Bayes net is assumed to be
;;; encoded, look at "test-net.lisp" and "burglar-alarm-net.lisp",
;;; for example.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-vars (bn)
  (mapcar #'first bn))

(defun get-values (var bn)
  (second (assoc var bn)))

(defun get-parents (var bn)
  (third (assoc var bn)))

(defun get-cpt (var bn)
  (nthcdr 3 (assoc var bn)))

(defun get-all-parents (bn)
  (mapcar #'third bn))

(defun get-vars-with-parents (bn)
  (let ((vars (get-vars bn))
	(parents (get-all-parents bn)))
    (mapcar #'cons vars parents)))

;; assumes all parents have values specified in vars-with-vals
(defun prob-given-parents (var val vars-with-vals bn)
  (let* ((var-data (rest (assoc var bn)))
	 (column (position val (get-values var bn)))
	 (parents (second var-data))
	 (parent-vals (list-vals-for parents vars-with-vals))
	 (cpt (nthcdr 2 var-data))
	 (cpt-row (if (null (rest cpt)) ; if only one row
		      (first cpt)       ; return it, else find matching row
		      (rest (assoc parent-vals cpt :test #'equal))))
	 )
    (nth column cpt-row)
    ))