Commit a28a4e21 by 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!