[mcclim-cvs] CVS mcclim/Drei/cl-automaton
thenriksen
thenriksen at common-lisp.net
Wed Nov 8 01:15:32 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton
In directory clnet:/tmp/cvs-serv24994/Drei/cl-automaton
Added Files:
state-and-transition.lisp state-and-transition-test.lisp
regexp.lisp regexp-test.lisp eqv-hash.txt eqv-hash.lisp
eqv-hash-test.lisp automaton.lisp automaton.asd
automaton-test.lisp automaton-test.asd
automaton-test-package.lisp automaton-package.lisp
Log Message:
Committed Drei.
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 1.1
;;; -*- mode: lisp -*-
;;;
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com)
;;;
;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders Møller
(in-package :automaton)
(defconstant +min-char-code+ 0)
(defconstant +max-char-code+ (1- char-code-limit))
;;; In Allegro (for one), defconstants aren't available as values at compile
;;; time.
(deftype char-code-type () `(integer 0 ,(1- char-code-limit)))
(defclass state ()
((accept :initform nil :accessor accept :type boolean)
(transitions :accessor transitions :type generalized-hash-table)
(num :initform 0 :accessor num :type fixnum)
(id :accessor id :type fixnum)
(next-id :allocation :class :initform -1 :accessor next-id :type fixnum)))
(declaim (special *state-ht*))
(defun state-equal (s1 s2) ; for testing, assuming minimization
(multiple-value-bind (se se-p)
(gethash (cons s1 s2) *state-ht*) ; TODO: consider (cons s2 s1), too
(if se-p
se
(setf (gethash (cons s1 s2) *state-ht*) t ; bound recursion temporarily
(gethash (cons s1 s2) *state-ht*)
(and (eq (accept s1) (accept s2))
(transitions-equal (transitions s1) (transitions s2)))))))
(declaim (special *to-first*))
(defun transitions-equal (ts1 ts2) ; for testing, assuming minimization
(let* ((*to-first* nil)
(tss1 (sort (with-ht-collect (t1 nil) ts1 t1) #'transition<))
(tss2 (sort (with-ht-collect (t2 nil) ts2 t2) #'transition<)))
(flet ((%transition-equal (t1 t2)
(with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) t1
(with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) t2
(and
(= minc1 minc2) (= maxc1 maxc2) (state-equal to1 to2))))))
(and (= (length tss1) (length tss2))
(loop for t1 in tss1 and t2 in tss2
always (%transition-equal t1 t2))))))
(defclass state-pair ()
((s :initarg :s :accessor s :type (or null state))
(s1 :initarg :s1 :accessor s1 :type state)
(s2 :initarg :s2 :accessor s2 :type state)))
(defclass transition ()
((minc :initarg :minc :accessor minc :type char-code-type)
(maxc :initarg :maxc :accessor maxc :type char-code-type)
(to :initarg :to :accessor to :type state)))
(defclass state-set ()
((ht :initform (make-hash-table) :initarg :ht :accessor ht :type hash-table)))
(defmethod initialize-instance :after ((s state) &rest initargs)
(declare (ignorable initargs))
(with-slots (transitions id next-id) s
(setf transitions (make-generalized-hash-table +equalp-key-situation+)
id (incf next-id))))
(defmethod initialize-instance :after ((tr transition) &rest initargs)
(declare (ignorable initargs))
(with-slots (minc maxc to) tr
(cond
((not minc)
(assert maxc nil "MINC or MAXC required")
(setf minc maxc))
((not maxc)
(assert minc nil "MINC or MAXC required")
(setf maxc minc))
((> minc maxc)
(rotatef minc maxc)))
(assert to nil "TO required")))
(defmethod eqv ((sp1 state-pair) (sp2 state-pair)
(s (eql +equalp-key-situation+)))
(and (eq (s1 sp1) (s1 sp2)) (eq (s2 sp1) (s2 sp2))))
(defmethod hash ((sp state-pair) (s (eql +equalp-key-situation+)))
"Returns the hash code for state-pair SP."
(the fixnum
(mod (+ (sxhash (s1 sp)) (sxhash (s2 sp))) most-positive-fixnum)))
(defmethod eqv ((tr1 transition) (tr2 transition)
(s (eql +equalp-key-situation+)))
"Returns true if transitions TR1 and TR2 have equal interval and
same (eq) destination state."
(with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1
(with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2
(and (= minc1 minc2) (= maxc1 maxc2) (eq to1 to2)))))
(defmethod hash ((tr transition) (s (eql +equalp-key-situation+)))
"Returns the hash code for transition TR."
(with-slots (minc maxc) tr
(the fixnum (mod (+ (* 2 minc) (* 3 maxc)) most-positive-fixnum))))
(defmethod clone ((tr transition))
"Returns a clone of TR."
(with-slots (minc maxc to) tr
(make-instance 'transition :minc minc :maxc maxc :to to)))
(defmethod eqv ((ss1 state-set) (ss2 state-set)
(s (eql +equalp-key-situation+)))
"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)
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)
sum (sxhash st))
most-positive-fixnum)))
(defvar *escape-unicode-chars* nil) ; true may be useful in Slime
(defun escaped-char (c)
(if (or (not *escape-unicode-chars*)
(and (<= #x21 c #x7e) (/= c (char-code #\\))))
(code-char c)
(format nil "\\u~4,'0O" c)))
(defmethod print-object ((st state) s)
(with-slots (accept transitions num) st
(format s "~@<state ~A [~A]: ~2I~_~@<~{~W~^ ~_~}~:>~:>"
num
(if accept "accept" "reject")
(with-ht-collect (tr nil) transitions tr)))
st)
(defmethod print-object ((tr transition) s)
(with-slots (minc maxc to) tr
(format s "~@<~A~:[~*~;-~A~] -> ~A~:>"
(escaped-char minc)
(/= minc maxc)
(escaped-char maxc)
(num to))
tr))
(defun transition< (tr1 tr2)
"Returns true if TR1 is strictly less than TR2. If *TO-FIRST*
special variable is bound to true, the values of the destination
states' NUM slots are compared first, followed by the intervals
comparison. The intervals comparison is done as follows: the lower
interval bounds are compared first, followed by reversed upper
interval bounds comparisons. If *TO-FIRST* is bound to nil, the
interval comparison is done first, followed by the NUM comparisons."
(with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1
(with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2
(let ((to< (< (num to1) (num to2)))
(to= (= (num to1) (num to2)))
(min-rmax< (or (< minc1 minc2)
(and (= minc1 minc2) (> maxc1 maxc2))))
(min-rmax= (and (= minc1 minc2) (= maxc1 maxc2))))
(if *to-first*
(or to< (and to= min-rmax<))
(or min-rmax< (and min-rmax= to<)))))))
(defun reset-transitions (s)
(setf (transitions s) (make-generalized-hash-table +equalp-key-situation+)))
(defun sstep (s c)
"Returns a state reachable from S, given the input character code
C."
(with-ht (tr nil) (transitions s)
(when (<= (minc tr) (char-code c) (maxc tr))
(return-from sstep (to tr)))))
(defun add-epsilon (s to)
"Adds transitions of state TO to state S. Also, if TO accepts, so
does S."
(when (accept to)
(setf (accept s) t))
(let ((s-table (transitions s)))
(with-ht (tr nil) (transitions to)
(htadd s-table tr))))
(defun sorted-transition-vector (s *to-first*)
"Returns a vector of all transitions of S, sorted using TRANSITION<
and *TO-FIRST*."
(let ((v (make-array `(,(cnt (transitions s)))
:element-type '(or null transition)))
(i -1))
(sort
(progn
(with-ht (tr nil) (transitions s)
(setf (aref v (incf i)) tr))
v)
#'transition<)))
(defun sorted-transition-list (s *to-first*)
"Returns a list of all transitions of S, sorted using TRANSITION<
and *TO-FIRST*."
(sort
(with-ht-collect (tr nil) (transitions s) tr)
#'transition<))--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 1.1
;;; -*- mode: lisp -*-
;;;
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com)
;;;
(in-package :automaton-user)
(deftest clone.transition.test-1
(let* ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(t2 (automaton::clone t1)))
(and (eqv t1 t2 +equalp-key-situation+)
(eql (hash t1 +equalp-key-situation+)
(hash t2 +equalp-key-situation+))))
t)
(deftest transition<.test-1
(let ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\c) :maxc (char-code #\d)
:to (make-instance 'automaton::state)))
(automaton::*to-first* nil))
(automaton::transition< t1 t2))
t)
(deftest transition<.test-2
(let ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\c) :maxc (char-code #\d)
:to (make-instance 'automaton::state)))
(automaton::*to-first* t))
(setf (automaton::num (automaton::to t1)) 1)
(automaton::transition< t2 t1))
t)
(deftest transition<.test-2a
(let ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\d)
:to (make-instance 'automaton::state)))
(automaton::*to-first* t))
(automaton::transition< t2 t1))
t)
(deftest transition<.test-3
(let ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\c)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(automaton::*to-first* nil))
(automaton::transition< t1 t2))
t)
(deftest sstep.test-1
(let* ((s (make-instance 'automaton::state))
(tr (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b) :to s)))
(htadd (automaton::transitions s) tr)
(eq (automaton::sstep s #\a) s))
t)
(deftest sstep.test-2
(let* ((s (make-instance 'automaton::state))
(tr (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b) :to s)))
(htadd (automaton::transitions s) tr)
(automaton::sstep s #\c))
nil)
(deftest add-epsilon.test-1
(let* ((s1 (make-instance 'automaton::state))
(s2 (make-instance 'automaton::state))
(tr (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b) :to s2)))
(htadd (automaton::transitions s2) tr)
(automaton::add-epsilon s1 s2)
(htpresent (automaton::transitions s1) tr))
t)
(deftest sorted-transition-vector.test-1
(let* ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\c)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(s (make-instance 'automaton::state)))
(htadd (automaton::transitions s) t1)
(htadd (automaton::transitions s) t2)
(equalp (automaton::sorted-transition-vector s nil)
(vector t1 t2)))
t)
(deftest sorted-transition-list.test-1
(let* ((t1 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\c)
:to (make-instance 'automaton::state)))
(t2 (make-instance 'automaton::transition
:minc (char-code #\a) :maxc (char-code #\b)
:to (make-instance 'automaton::state)))
(s (make-instance 'automaton::state)))
(htadd (automaton::transitions s) t1)
(htadd (automaton::transitions s) t2)
(equal (automaton::sorted-transition-list s nil)
(list t1 t2)))
t)--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 1.1
;;; -*- mode: lisp -*-
;;;
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com)
;;;
;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders Møller
;;; - Some comments have been copied verbatim from the original code.
;;; Regular expressions are built from the following abstract syntax:
;;; regexp ::= unionexp
;;; unionexp ::= interexp | unionexp (union)
;;; | interexp
;;; interexp ::= concatexp & interexp (intersection) [OPTIONAL]
;;; | concatexp
;;; concatexp ::= repeatexp concatexp (concatenation)
;;; | repeatexp
;;; repeatexp ::= repeatexp ? (zero or one occurrence)
;;; | repeatexp * (zero or more occurrences)
;;; | repeatexp + (one or more occurrences)
;;; | repeatexp {n} (n occurrences)
;;; | repeatexp {n,} (n or more occurrences)
;;; | repeatexp {n,m} (n to m occurrences, including both)
;;; | complexp
;;; complexp ::= ~ complexp (complement) [OPTIONAL]
;;; | charclassexp
;;; charclassexp ::= [ charclasses ] (character class)
;;; | [^ charclasses ] (negated character class)
;;; | simpleexp
;;; charclasses ::= charclass charclasses
;;; | charclass
;;; charclass ::= charexp - charexp (character range, including end-points)
;;; | charexp
;;; simpleexp ::= charexp
;;; | . (any single character)
;;; | # (the empty language) [OPTIONAL]
;;; | @ (any string) [OPTIONAL]
;;; | " <Unicode string without double-quotes> " (a string)
;;; | ( ) (the empty string)
;;; | ( unionexp ) (precedence override)
;;; | < <identifier> > (named automaton) [OPTIONAL]
;;; | <n-m> (numerical interval) [OPTIONAL]
;;; charexp ::= <Unicode character> (a single non-reserved character)
;;; | \ <Unicode character> (a single character)
;;; The productions marked [OPTIONAL] are only allowed if specified by
;;; the syntax flags passed to the string-regexp constructor. The
;;; reserved characters used in the (enabled) syntax must be escaped
;;; with backslash (\) or double-quotes ("..."). (In contrast to other
;;; regexp syntaxes, this is required also in character classes.) Be
;;; aware that dash (-) has a special meaning in charclass
;;; expressions. An identifier is a string not containing right angle
;;; bracket (>) or dash (-). Numerical intervals are specified by
;;; non-negative decimal integers and include both end points, and if
;;; n and m have the same number of digits, then the conforming
;;; strings must have that length (i.e. prefixed by 0's).
(in-package :automaton)
(deftype kind ()
'(member nil :union :concatenation :intersection :optional :repeat
:repeat-min :repeat-minmax :complement :char :char-range :anychar :empty
:string :anystring :automaton :interval))
(defconstant +intersection+ #x0001) ; enables intersection (&)
(defconstant +complement+ #x0002) ; enables complement (~)
(defconstant +empty+ #x0004) ; enables empty language (#)
(defconstant +anystring+ #x0008) ; enables anystring (@)
(defconstant +automaton+ #x0010) ; enables named automaton (<id>)
(defconstant +interval+ #x0020) ; enables numerical intervals (n-m)
(defconstant +all+ #xffff) ; enables all optional syntax
(defconstant +none+ #x0000) ; enables no optional syntax
(deftype flags-type () `(integer ,+none+ ,+all+))
(defclass regexp ()
((kind :initform nil :initarg :kind :reader kind :type kind)
(exp1 :initform nil :initarg :exp1 :reader exp1 :type (or null regexp))
(exp2 :initform nil :initarg :exp2 :reader exp2 :type (or null regexp))
(text :initform nil :initarg :text :reader text :type (or null string))
(s :initform nil :initarg :s :reader s :type (or null string))
[342 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 1.1
[592 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 1.1
[790 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 1.1
[911 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 1.1
[1087 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 1.1
[2300 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 1.1
[2315 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 1.1
[2642 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 1.1
[2657 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 1.1
[2666 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 1.1
[2708 lines skipped]
More information about the Mcclim-cvs
mailing list