Commit a28a4e21 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Added transitive-closure algorithm using hash-tables.

parent 8c60dc38
...@@ -1432,29 +1432,68 @@ RETURN: The maximum value and the item in list for which predicate ...@@ -1432,29 +1432,68 @@ RETURN: The maximum value and the item in list for which predicate
'compute-closure 'transitive-closure) 'compute-closure 'transitive-closure)
(transitive-closure fun set)) (transitive-closure fun set))
(defun transitive-closure (fun set) (defun transitive-closure (fun set &key (test 'eql) (use 'list))
" "
FUN: set --> P(set) FUN: set --> P(set)
x |--> { y } x |--> { y }
RETURN: The closure of fun on the set. SET: A sequence.
NOTE: Not a lisp closure! TEST: EQL, EQUAL or EQUALP
EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1) USE: Either HASH-TABLE or LIST; specifies the data structure used for the intermediary sets.
RETURN: A list containing closure of fun on the set.
EXAMPLE: (transitive-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (3 4 2 1)
NOTE: This version avoids calling FUN twice with the same argument. NOTE: This version avoids calling FUN twice with the same argument.
" "
(flet ((join (lists) ;; current -> fun -> follows
(loop ;; closure + current -> closure
:with result = '() ;; follows - closures -> current
:for list :in lists (ecase use
:do (loop :for item :in list :do (push item result)) (list
:finally (return result)))) (let ((closure '())
(loop (current '())
:for follows = (delete-duplicates (join (mapcar fun set))) (follows '()))
:then (delete-duplicates (join (cons follows (mapcar fun newbies)))) (macrolet ((enter (item list) `(pushnew ,item ,list :test test))
:for newbies = (set-difference follows set) (enter-all (items list) `(setf ,list (delete-duplicates (append ,items ,list) :test test))))
:while newbies (declare (inline enter enter-all))
;; :do (print (list 'newbies newbies)) (setf current (coerce set 'list))
:do (setf set (append newbies set)) (loop
:finally (return set)))) :do (loop ;; current -> fun -> follows
:for item :in current
:initially (setf follows '())
:do (enter-all (funcall fun item) follows)
;; closure + current -> closure
(enter item closure))
(loop ;; follows - closures -> current
:for item :in follows
:initially (setf current '())
:unless (member item closure :test test)
:do (enter item current))
:while current
:finally (return-from transitive-closure closure)))))
(hash-table
(let ((closure (make-hash-table :test test))
(current (make-hash-table :test test))
(follows (make-hash-table :test test)))
(flet ((enter (item hash) (setf (gethash item hash) t))
(enter-all (items hash) (map nil (lambda (item) (setf (gethash item hash) t)) items)))
(declare (inline enter enter-all))
(enter-all set current)
(loop
:do (loop ;; current -> fun -> follows
:for item :being :each :hash-key :in current
:initially (clrhash follows)
:do (enter-all (funcall fun item) follows)
;; closure + current -> closure
(enter item closure))
(loop ;; follows - closures -> current
:for item :being :each :hash-key :in follows
:initially (clrhash current)
:unless (gethash item closure)
:do (enter item current))
:while (plusp (hash-table-count current))
:finally (return-from transitive-closure
(loop
:for item :being :each :hash-key :in closure
:collect item))))))))
;; (array->list array) --> (coerce array 'list) ;; (array->list array) --> (coerce array 'list)
...@@ -1636,9 +1675,9 @@ POST: (<= start index end) ...@@ -1636,9 +1675,9 @@ POST: (<= start index end)
(with-output-to-string (*standard-output*) (with-output-to-string (*standard-output*)
(dolist (item items) (dolist (item items)
(typecase item (typecase item
(string (write-string item)) (string (write-string item *standard-output*))
(sequence (write-sequence item)) (sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format t "~A" item))))))) (t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defmacro scase (keyform &rest clauses) (defmacro scase (keyform &rest clauses)
" "
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment