;
; trans-closure berechnet den transitiven Abschluss einer Relation R
; die als Liste von Paaren (ai . bi) mit der Bedeutung ai R bi gegeben sind


(defun trans-closure (rel-pair-lis)

  (let* ((domain-elems (elements-of rel-pair-lis))

         (elem-followers (loop for x in domain-elems append (list x ()))))

    (loop

     for rel in rel-pair-lis do

     (let ((e1 (car rel))

           (e2 (cdr rel)))

       (setf (getf elem-followers e1) 

             (union (list e2) 

                    (union (getf elem-followers e1) (getf elem-followers e2))))

       (loop

        for y in domain-elems

        when (member e1 (getf elem-followers y)) do

        (setf (getf elem-followers y)

              (union (getf elem-followers y) (getf elem-followers e1)))))

     finally (return elem-followers))))


;
; eine etwas effizientere Variante von trans-closure :
;



(defun trans-closure1 (rel-pair-lis)

  (let* ((domain-elems (elements-of rel-pair-lis))

         (elem-followers (loop for x in domain-elems append (list x ()))))

    (loop

     for rel in rel-pair-lis do

     (let ((e1 (car rel))

           (e2 (cdr rel))

           (new-elem-followers-e1))

       (setf new-elem-followers-e1

             (union (list e2) 

                    (union (getf elem-followers e1) (getf elem-followers e2))))

       (loop

        for y in domain-elems

        when (member e1 (getf elem-followers y)) do

        (setf (getf elem-followers y)

              (union (union (getf elem-followers y) (list e1 e2)) (getf elem-followers e2))))

       (setf (getf elem-followers e1) new-elem-followers-e1))

     finally (return elem-followers))))


;
; elements-of einer Relationspaarliste gibt eine Liste der verwendeten Elemente zurück
;


(defun elements-of (rel-pair-lis)

  (cond ((null rel-pair-lis) ())

        (t 

         (union (adjoin (car (first rel-pair-lis)) (list (cdr (first rel-pair-lis))))
                
                (elements-of (cdr rel-pair-lis))))))


;
; einige Hilfsfunktionen zum Testen
;

(defun xor-tc-lists (tcl1 tcl2)

  (set-exclusive-or (tc-list-expand tcl1) (tc-list-expand tcl2)
                    :test #'(lambda (x y) (and (eql (car x) (car y)) (eql (cdr x) (cdr y))))))


(defun tc-list-expand (tcl)

  (do ((tcla tcl (cddr tcla))
       (res nil))
      ((null tcla) res)
    (setf res (union res (map 'list #'(lambda (x) (cons (car tcla) x)) (cadr tcla))))))