[mcclim-cvs] CVS mcclim/Drei/cl-automaton
thenriksen
thenriksen at common-lisp.net
Sun Jan 14 17:33:51 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton
In directory clnet:/tmp/cvs-serv24917/Drei/cl-automaton
Modified Files:
automaton.lisp eqv-hash.lisp state-and-transition.lisp
Log Message:
Make cl-automaton (the regexp part of Drei) work in CLISP. This was
done by fixing non-conformant loops that SBCL happens to handle.
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 1.1
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/01/14 17:33:51 1.2
@@ -83,20 +83,21 @@
(worklist nil))
(setf (gethash (initial a) visited) t)
(push (initial a) worklist)
- (loop while worklist
- for s = (pop worklist) do
- (with-ht (tr nil) (transitions s)
- (let ((s2 (to tr)))
- (unless (gethash s2 visited)
- (setf (gethash s2 visited) t)
- (push s2 worklist)))))
+ (loop for s = (first worklist)
+ while worklist do
+ (pop worklist)
+ (with-ht (tr nil) (transitions s)
+ (let ((s2 (to tr)))
+ (unless (gethash s2 visited)
+ (setf (gethash s2 visited) t)
+ (push s2 worklist)))))
visited))
(defun accepting-states (a)
"Returns a hash table containing the set of accepting states
reachable from the initial state of A."
(let ((accepting (make-hash-table)))
- (loop for s being the hash-key of (states a)
+ (loop for s being the hash-keys of (states a)
when (accept s) do
(setf (gethash s accepting) t))
accepting))
@@ -106,7 +107,7 @@
states being the keys of STATES hash table, and finally returns
STATES."
(let ((i -1))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(setf (num s) (incf i))))
states)
@@ -117,7 +118,7 @@
(tr (make-instance
'transition :minc +min-char-code+ :maxc +max-char-code+ :to s)))
(htadd (transitions s) tr)
- (loop for p being the hash-key of (states a)
+ (loop for p being the hash-keys of (states a)
and maxi = +min-char-code+ do
(loop for tr in (sorted-transition-list p nil) do
(with-slots (minc maxc) tr
@@ -140,7 +141,7 @@
a
(let ((states (states a)))
(set-state-nums states)
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(let ((st (sorted-transition-list s t)))
(reset-transitions s)
(let ((p nil)
@@ -179,7 +180,7 @@
"Returns a sorted vector of all interval start points (character
codes)."
(let ((pset (make-hash-table)))
- (loop for s being the hash-key of (states a) do
+ (loop for s being the hash-keys of (states a) do
(setf (gethash +min-char-code+ pset) t)
(with-ht (tr nil) (transitions s)
(with-slots (minc maxc) tr
@@ -188,7 +189,7 @@
(setf (gethash (1+ maxc) pset) t)))))
(let ((pa (make-array (hash-table-count pset)
:element-type 'char-code-type)))
- (loop for p being the hash-key of pset and n from 0 do
+ (loop for p being the hash-keys of pset and n from 0 do
(setf (aref pa n) p)
finally (return (sort pa #'<))))))
@@ -196,19 +197,20 @@
"Returns the set of live states of A that are in STATES hash
table. A state is live if an accepting state is reachable from it."
(let ((map (make-hash-table)))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(setf (gethash s map) (make-hash-table)))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(with-ht (tr nil) (transitions s)
(setf (gethash s (gethash (to tr) map)) t)))
(let* ((live (accepting-states a))
- (worklist (loop for s being the hash-key of live collect s)))
- (loop while worklist
- for s = (pop worklist) do
- (loop for p being the hash-key of (gethash s map)
- unless (gethash p live) do
- (setf (gethash p live) t)
- (push p worklist)))
+ (worklist (loop for s being the hash-keys of live collect s)))
+ (loop for s = (first worklist)
+ while worklist do
+ (pop worklist)
+ (loop for p being the hash-keys of (gethash s map)
+ unless (gethash p live) do
+ (setf (gethash p live) t)
+ (push p worklist)))
live)))
(defun remove-dead-transitions (a)
@@ -218,7 +220,7 @@
nil
(let* ((states (states a))
(live (live-states2 a states)))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(let ((st (transitions s)))
(reset-transitions s)
(with-ht (tr nil) st
@@ -232,7 +234,7 @@
slot."
(set-state-nums states)
(let ((transitions (make-array (hash-table-count states))))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(setf (aref transitions (num s)) (sorted-transition-vector s nil)))
transitions))
@@ -466,7 +468,7 @@
(progn
(setf a1 (clone-expanded a1)
a2 (clone-expanded a2))
- (loop for s being the hash-key of (accepting-states a1) do
+ (loop for s being the hash-keys of (accepting-states a1) do
(setf (accept s) nil)
(add-epsilon s (initial a2)))
(setf (deterministic a1) nil)
@@ -482,7 +484,7 @@
(loop for a2 in (cdr l) do
(let* ((a2 (clone-expanded a2))
(ac2 (accepting-states a2)))
- (loop for s being the hash-key of ac1 do
+ (loop for s being the hash-keys of ac1 do
(setf (accept s) nil)
(add-epsilon s (initial a2))
(when (accept s)
@@ -511,7 +513,7 @@
(s (make-instance 'state)))
(setf (accept s) t)
(add-epsilon s (initial a))
- (loop for p being the hash-key of (accepting-states a) do
+ (loop for p being the hash-keys of (accepting-states a) do
(add-epsilon p s))
(setf (initial a) s
(deterministic a) nil)
@@ -546,10 +548,10 @@
(let ((a3 (clone a)))
(loop while (> (decf max) 0) do
(let ((a4 (clone a)))
- (loop for p being the hash-key of (accepting-states a4) do
+ (loop for p being the hash-keys of (accepting-states a4) do
(add-epsilon p (initial a3)))
(setq a3 a4)))
- (loop for p being the hash-key of (accepting-states a2) do
+ (loop for p being the hash-keys of (accepting-states a2) do
(add-epsilon p (initial a3)))
(setf (deterministic a2) nil)
(check-minimize-always a2))))
@@ -559,7 +561,7 @@
(let ((a (clone-expanded a)))
(determinize a)
(totalize a)
- (loop for p being the hash-key of (states a) do
+ (loop for p being the hash-keys of (states a) do
(setf (accept p) (not (accept p))))
(remove-dead-transitions a)
(check-minimize-always a)))
@@ -673,7 +675,7 @@
(loop while worklist do
(let* ((s (pop worklist))
(r (htref newstate s)))
- (loop for q being the hash-key of (ht s)
+ (loop for q being the hash-keys of (ht s)
when (accept q) do
(setf (accept r) t)
(return))
@@ -681,7 +683,7 @@
for c across points
and n from 0 do
(let ((p (make-instance 'state-set)))
- (loop for q being the hash-key of (ht s) do
+ (loop for q being the hash-keys of (ht s) do
(with-ht (tr nil) (transitions q)
(when (<= (minc tr) c (maxc tr))
(setf (gethash (to tr) (ht p)) t))))
@@ -763,7 +765,7 @@
(defun mark-pair (mark triggers n1 n2)
(setf (aref mark n1 n2) t)
(when (aref triggers n1 n2)
- (loop for p being the hash-key of (aref triggers n1 n2) do
+ (loop for p being the hash-keys of (aref triggers n1 n2) do
(let ((m1 (n1 p))
(m2 (n2 p)))
(when (> m1 m2)
@@ -773,7 +775,7 @@
(defun ht-set-to-vector (ht)
(loop with vec = (make-array (hash-table-count ht))
- for k being the hash-key of ht
+ for k being the hash-keys of ht
and i from 0 do
(setf (aref vec i) k)
finally (return vec)))
@@ -900,9 +902,10 @@
(let ((j (if (<= i0 i1) 0 1)))
(push (make-instance 'int-pair :n1 j :n2 i) pending)
(setf (aref pending2 i j) t)))
- (loop while pending
- for ip = (pop pending)
- for p = (n1 ip) and i = (n2 ip) do
+ (loop for ip = (first pending)
+ for p = (when pending (n1 ip)) and i = (when pending (n2 ip))
+ while pending do
+ (pop pending)
(setf (aref pending2 i p) nil)
(loop for m = (fst (aref active p i)) then (succ m)
while m do
@@ -970,20 +973,20 @@
(let ((m (make-hash-table))
(states (states a))
(astates (accepting-states a)))
- (loop for r being the hash-key of states do
+ (loop for r being the hash-keys of states do
(setf (gethash r m)
(make-generalized-hash-table +equalp-key-situation+)
(accept r) nil))
- (loop for r being the hash-key of states do
+ (loop for r being the hash-keys of states do
(with-ht (tr nil) (transitions r)
(htadd (gethash (to tr) m)
(make-instance
'transition :minc (minc tr) :maxc (maxc tr) :to r))))
- (loop for r being the hash-key of states do
+ (loop for r being the hash-keys of states do
(setf (transitions r) (gethash r m)))
(setf (accept (initial a)) t
(initial a) (make-instance 'state))
- (loop for r being the hash-key of astates do
+ (loop for r being the hash-keys of astates do
(add-epsilon (initial a) r))
(setf (deterministic a) nil)
astates))
@@ -1011,13 +1014,14 @@
(let ((worklist pairs)
(workset (make-generalized-hash-table +equalp-key-situation+)))
(loop for p in pairs do (htadd workset p))
- (loop while worklist
- for p = (pop worklist) do
+ (loop for p = (first worklist)
+ while worklist do
+ (pop worklist)
(htremove workset p)
(let ((tos (gethash (s2 p) forward))
(froms (gethash (s1 p) back)))
(when tos
- (loop for s being the hash-key of tos
+ (loop for s being the hash-keys of tos
for pp = (make-instance 'state-pair :s1 (s1 p) :s2 s)
unless (member pp pairs
:test #'(lambda (o1 o2)
@@ -1029,7 +1033,7 @@
(push pp worklist)
(htadd workset pp)
(when froms
- (loop for q being the hash-key of froms
+ (loop for q being the hash-keys of froms
for qq = (make-instance 'state-pair :s1 q :s2 (s1 p))
unless (htpresent workset qq) do
(push qq worklist)
@@ -1113,7 +1117,7 @@
"Returns the number of transitions of A."
(if (singleton a)
(length (singleton a))
- (loop for s being the hash-key of (states a)
+ (loop for s being the hash-keys of (states a)
sum (cnt (transitions s)))))
(defun empty-p (a)
@@ -1152,7 +1156,7 @@
(set-state-nums states))
(format s "~@<initial state: ~A ~_~@<~{~W~^ ~_~}~:>~:>"
(num (initial a))
- (loop for st being the hash-key of states collect st)))
+ (loop for st being the hash-keys of states collect st)))
a)
(defun clone-expanded (a)
@@ -1173,9 +1177,9 @@
(setf (singleton a2) (singleton a))
(let ((map (make-hash-table))
(states (states a)))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(setf (gethash s map) (make-instance 'state)))
- (loop for s being the hash-key of states do
+ (loop for s being the hash-keys of states do
(let ((p (gethash s map)))
(setf (accept p) (accept s))
(when (eq s (initial a))
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 1.1
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2007/01/14 17:33:51 1.2
@@ -100,13 +100,13 @@
(defmacro with-ht ((key value) table &body body)
(let ((bucket (gensym "BUCKET")))
- `(loop for ,bucket being the hash-value of (ht ,table) do
+ `(loop for ,bucket being the hash-values of (ht ,table) do
(loop for (,key . ,value) in ,bucket do
, at body))))
(defmacro with-ht-collect ((key value) table &body body)
(let ((bucket (gensym "BUCKET")))
- `(loop for ,bucket being the hash-value of (ht ,table) nconc
+ `(loop for ,bucket being the hash-values of (ht ,table) nconc
(loop for (,key . ,value) in ,bucket collect
, at body))))
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 1.1
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/01/14 17:33:51 1.2
@@ -110,13 +110,13 @@
"Returns true if state-set objects SS1 and SS2 contain the same (eql)
state objects."
(and (= (hash-table-count (ht ss1)) (hash-table-count (ht ss2)))
- (loop for st being the hash-key of (ht ss1)
+ (loop for st being the hash-keys of (ht ss1)
always (gethash st (ht ss2)))))
(defmethod hash ((ss state-set) (s (eql +equalp-key-situation+)))
"Returns the hash code for state-set SS."
(the fixnum
- (mod (loop for st being the hash-key of (ht ss)
+ (mod (loop for st being the hash-keys of (ht ss)
sum (sxhash st))
most-positive-fixnum)))
More information about the Mcclim-cvs
mailing list