;;;
;;;    by K. Yue
;;;       Dept. of Comp. Sc., UHCL.
;;;       July 10, 1990.
;;;
;;;    representation of
;;;       a set of attributes -- a list of attributes.
;;;       a functional dependencies (fd)
;;;          -- a list of 2 elements, the first element
;;;             is a list of attributes in the left hand
;;;             side of the fd and the second element is
;;;             a list of attributes in the right hand
;;;             side of the fd.
;;;       a set of fd's -- a list of fd's.

;;   
;;   closure-of: find the closure of a set of attributes
;;               with respect to a set of fd's
;;   input: x -- a set of attributes.
;;          fds -- a set of fd's.  Each fd is a list of
;;                 2 elements.
;;   output: the closure of x with respect to fds.
;;
(defun closure-of (x fds)
   (let ((x-new x)
         (x-old) )
      (loop
         (setf x-old x-new)
         (setf x-new (update-closure x-new fds))
         (if (equal x-old x-new) (return x-new)) ) ) )
;;
;;   update-closure: an iteration of finding the clsoure
;;                   a set of attributes.
;;
(defun update-closure (x fds)
   (dolist (fd fds x)
      (if (and (subsetp (first fd) x)
               (not (subsetp (second fd) x)) )
          (return (union x (second fd))) ) ) )

;;
;;   implies-p: to test whether a set of fd's implies a
;;              fd.
;;   input:  s - a set of fd's.
;;           fd - a fd.
;;   output: t if s logically implies fd; nil otherwise.
;;
(defun implies-p (s fd)
   (subsetp (second fd) (closure-of (first fd) s)) )
;;
;;   equi-fdset-p: to test whether two sets of fd's are
;;                 equivalent.
;;   input: fds1 - a set of fd's.
;;          fds2 - a set of fd's.
;;   output: t if fds1 and fds2 are equivalent; nil otherwise.
;;
(defun equi-fdset-p (fds1 fds2)
   (dolist (fd fds1)
      (if (not (implies-p fds2 fd)) (return nil)) )
   (dolist (fd fds2 t)
      (if (not (implies-p fds1 fd)) (return nil)) ) )



;;
;;   minimal-cover: returns a minimal cover of a set of fd's.
;;   input: fds -- a set of fd's.
;;   output: a minimal cover of fds.
;;
(defun minimal-cover (fds)
   (remove-redundant-fds
      (remove-redundant-attributes
         (single-attribute-fd fds) ) ) )
;;
;;   remove-redundant-fds: remove all redundant fd in a set
;;                         of fds.
;;   input: fds -- a set of fd's.
;;   output: fds with all redundant fd's removed.
;;
(defun remove-redundant-fds (fds)
   (let ((fds-old)
         (fds-new fds) )
      (loop
         (setq fds-old fds-new)
         (setq fds-new (rem-a-red-fd fds-new))
         (if (equal fds-old fds-new) (return fds-new)) ) ) )
;;
;;   rem-a-red-fd: remove a redundant fd from a set of fd's.
;;
(defun rem-a-red-fd (fds)
   (dolist (fd fds fds)
      (if (implies-p (set-difference fds (list fd)) fd)
          (return (set-difference fds (list fd))) ) ) )
;;
;;    remove-redundant-attributes: remove all redundant
;;                                 attributes in a set
;;                                 of fds.
;;    input: fds -- a set of fds.
;;    output: fds, with all redundant attributes removed.
;;
;;
(defun remove-redundant-attributes (fds)
   (let ((fds-old)
         (fds-new fds) )
      (loop
         (setf fds-old fds-new)
         (setf fds-new (rem-a-red-attr fds-new))
         (if (equal fds-old fds-new) (return fds-new)) ) ) )
;;
;;    rem-a-red-attr: remove a redundant attribute in a fd of
;;                    a set of fd's.
;;
(defun rem-a-red-attr (fds)
   (dolist (fd fds fds)
      (let ((lhs (first fds))
            (rhs (second fds)))
        (dolist (attr lhs)
           (if (subsetp rhs 
                        (closure-of 
                          (remove attr lhs)
                          fds) )
               (return 
                  (union
                     (remove fd fds :test #'equal)
                     (list (remove attr lhs) rhs) )) ) ) ) ) )
;;
;;    single-attribute-fd: return an equivalent cover of a set
;;                         of fd's such that each fd has a
;;                         single attribute in its right hand
;;                         side.
;;    input: fds -- a set of fds.
;;    output: an equivalent set of fd's such that the right
;;            hasn side of each fd contains a single attribute.
;;
(defun single-attribute-fd (fds)
   (apply #'append
     (mapcar
       #'(lambda (fd)
            (let ((lhs (first fd))
                  (rhs (second fd))
                  (result nil) )
               (dolist (conseq rhs result)
                  (setq result
                    (append result 
                       (list (list lhs (list conseq))) ) ) ) ) )
       fds) ) )