This is pretty much my first time using lisp 'in anger', on a
non-deterministic finite automata simulator for a class i'm auditing.
I found it interesting that, even on the small samples I have, the more
functional version conses less and runs faster. Any comments would be
welcome.
example usage:
:cl-user> (test *nfa/input* #'simulate-nfa2)
(EPSILON) -> (Q3)
(Y) -> (Q3)
(Y Y Y Y) -> (Q3)
(X Y Y Y) -> NIL
(Y X) -> NIL
thanks,
Cody
;;;; simulate a non-deterministic finite automata, aka nfa
;;; example nfa in list form w/input strings
(defparameter *nfa/input*
'(((x y) ;alphabet
(q1 q2 q3 q4 q5 q6 q7) ;states
(q1) ;start states
(q3) ;accept states
((q1 y q2) ;transition relation table,
(q1 y q5) ;(state input result)
(q1 x q6) ;where 'epsilon = no input
(q1 epsilon q6)
(q1 epsilon q3)
(q2 y q3)
(q2 epsilon q1)
(q3 epsilon q4)
(q4 epsilon q2)
(q5 epsilon q1)
(q6 y q7)))
((epsilon) ;input strings
(y)
(y y y y)
(x y y y)
(y x))))
;;; structure to hold a given nfa
(defstruct nfa
alphabet
states
starts
accepts
transition-fn)
;;; build nfa structure from list of nfa fields
;;; should probably do error checking for consistency of nfa
(defun list->nfa (lst)
"takes a list of nfa fields according to spec, returns an nfa
structure"
(let ((transition-hash (make-hash-table :test 'equal)))
(dolist (trans (fifth lst))
(push (third trans)
(gethash (cons (first trans) (second trans)) transition-hash)))
(make-nfa :alphabet (first lst)
:states (second lst)
:starts (third lst)
:accepts (fourth lst)
:transition-fn (lambda (state sym)
(gethash (cons state sym) transition-hash)))))
;;;convenience functions
(defun mappend (fn lst)
(apply #'append (mapcar fn lst)))
(defun set-union (&rest args)
(remove-duplicates (apply #'union args)))
(defun set-intersection (&rest args)
(remove-duplicates (apply #'intersection args)))
;;; follow transitions that don't consume input, avoid loops
(defun eps (start-states transition-fn)
"return set of all states reachable from start-states by 0 or more
epsilon transitions"
(labels ((reach-from (lst)
(mappend (lambda (s) (funcall transition-fn s 'epsilon))
lst)))
(do ((result start-states (set-union result new-states))
(new-states (reach-from start-states) (reach-from new-states)))
((null (set-difference new-states result)) result))))
;;; simulate nfa, breadth-first search, iterative style
(defun simulate-nfa (nfa input)
"return accepting states, if any, reached by nfa on list of symbols
given as input"
(let* ((trans-fn (nfa-transition-fn nfa))
(current-states (eps (nfa-starts nfa) trans-fn)))
(dolist (sym input)
(let ((next-states nil))
(dolist (state current-states)
(setf next-states (set-union next-states
(eps (funcall trans-fn state sym) trans-fn))))
(setf current-states next-states)))
(set-intersection current-states (nfa-accepts nfa))))
;;;same thing, more functional style
(defun simulate-nfa2 (nfa input)
"return accepting states, if any, reached by nfa on list of symbols
given as input"
(let* ((trans-fn (nfa-transition-fn nfa))
(start-states (eps (nfa-starts nfa) trans-fn)))
(set-intersection (nfa-accepts nfa)
(reduce (lambda (states sym)
(eps (mappend (lambda (state)
(funcall trans-fn state sym))
states)
trans-fn))
input
:initial-value start-states))))
(defun test (nfa/input sim-fn)
"test a single nfa/input list using sim-fn"
(let ((nfa (list->nfa (first nfa/input)))
(inputs (second nfa/input)))
(dolist (input inputs)
(format t "~20A -> ~A~%" input (funcall sim-fn nfa input)))))
From: Thomas A. Russ
Subject: Re: noob request for comments - NFA simulator
Date:
Message-ID: <ymi4q7c2htn.fsf@sevak.isi.edu>
··············@gmail.com" <·············@gmail.com> writes:
Congratulations on picking a nice task for using lisp.
> ;;;convenience functions
> (defun mappend (fn lst)
> (apply #'append (mapcar fn lst)))
Look at MAPCAN. It should do what you want.
> (defun set-union (&rest args)
> (remove-duplicates (apply #'union args)))
>
> (defun set-intersection (&rest args)
> (remove-duplicates (apply #'intersection args)))
Note:
If you can be sure you start with true sets, then intersection and union
will not introduce duplicates.
> ;;; follow transitions that don't consume input, avoid loops
> (defun eps (start-states transition-fn)
> "return set of all states reachable from start-states by 0 or more
> epsilon transitions"
> (labels ((reach-from (lst)
> (mappend (lambda (s) (funcall transition-fn s 'epsilon))
> lst)))
> (do ((result start-states (set-union result new-states))
> (new-states (reach-from start-states) (reach-from new-states)))
> ((null (set-difference new-states result)) result))))
>
> ;;; simulate nfa, breadth-first search, iterative style
> (defun simulate-nfa (nfa input)
> "return accepting states, if any, reached by nfa on list of symbols
> given as input"
> (let* ((trans-fn (nfa-transition-fn nfa))
> (current-states (eps (nfa-starts nfa) trans-fn)))
> (dolist (sym input)
> (let ((next-states nil))
> (dolist (state current-states)
> (setf next-states (set-union next-states
> (eps (funcall trans-fn state sym) trans-fn))))
> (setf current-states next-states)))
> (set-intersection current-states (nfa-accepts nfa))))
;;; Same thing, less copying although potentially more list traversals:
;;; Assumes that all sets of states are true sets and makes sure they
;;; stay that way.
(defun simulate-nfa3 (nfa input)
"return accepting states, if any, reached by nfa on list of symbols
given as input"
(let* ((trans-fn (nfa-transition-fn nfa))
(current-states (eps (nfa-starts nfa) trans-fn)))
(dolist (sym input)
(let ((next-states nil))
(dolist (state current-states)
(dolist (new-state (eps (funcall trans-fn state sym) trans-fn))
(pushnew next-states new-state))))
(setf current-states next-states)))
(intersection current-states (nfa-accepts nfa)))
--
Thomas A. Russ, USC/Information Sciences Institute
Thomas A. Russ wrote:
> Congratulations on picking a nice task for using lisp.
It's a fun language - flexible & succinct (but not too succinct).
> Look at MAPCAN. It should do what you want.
I'm still a bit wary of destructive functions - I don't have a good
understanding of when they're safe.
At any rate, Mapcan does something ugly to the list structure if I use
it in eps - goes into an infinite loop.
> Note:
> If you can be sure you start with true sets, then intersection and union
> will not introduce duplicates.
Okay, that makes at least a little more sense - garbage in, garbage
out. I was initially somewhat offended to see what looked like a set
function returning duplicates. Is there a good implementation of sets
using hash tables that still allows for functions like map / dolist ?
Because it still seems necessary to avoid duplicates in eps, due to
multiple transitions to a given state. . . wait, nevermind, I got it.
see below.
> (defun simulate-nfa3 (nfa input)
> "return accepting states, if any, reached by nfa on list of symbols
> given as input"
> (let* ((trans-fn (nfa-transition-fn nfa))
> (current-states (eps (nfa-starts nfa) trans-fn)))
> (dolist (sym input)
> (let ((next-states nil))
> (dolist (state current-states)
> (dolist (new-state (eps (funcall trans-fn state sym) trans-fn))
> (pushnew next-states new-state))))
Thanks for pointing out pushnew! I knew adjoin, but forgot that for
some reason. In testing this i noticed the args to pushnew are swapped
above, and in the line below setf is out of scope by one paren.
> (setf current-states next-states)))
> (intersection current-states (nfa-accepts nfa)))
You inspired me to clean it up - I knew there was something wrong about
passing a transition function to eps, & there was duplication between
eps and simulate-nfa. Eps no longer calls set-union, since it's
relying on a more general 'next' transition to keep the set true. End
result = conses half as much & runs faster, even compared to your
version which was an improvement.
Thanks much for your feedback,
-cody
;;;same thing, local tail-recursive style, without calls to set-union
(defun simulate-nfa4 (nfa symbol-list)
"return accepting states, if any, reached by nfa on list of symbols
given as input"
(labels
;; set of states, symbol -> next set of states
((next (states symb)
(let ((next-states nil))
(dolist (state states)
(dolist (new-state (funcall (nfa-transition-fn nfa) state symb))
(pushnew new-state next-states)))
next-states))
;; set of states -> set of states reachable by epsilon
transitions
(eps (states)
(let ((reached (union states (next states 'epsilon))))
(if (null (set-difference reached states))
states
(eps reached))))
;; set of states, list of symbols -> end states
(recur (states symbol-list)
(let ((current-states (eps states))
(sym (car symbol-list)))
(cond ((null current-states) nil)
((null sym) (set-intersection current-states
(nfa-accepts nfa)))
(t (recur (next current-states sym) (cdr symbol-list)))))))
(recur (nfa-starts nfa) symbol-list)))
··············@gmail.com" <·············@gmail.com> writes:
> This is pretty much my first time using lisp 'in anger', on a
> non-deterministic finite automata simulator for a class i'm auditing.
> I found it interesting that, even on the small samples I have, the more
> functional version conses less and runs faster. Any comments would be
> welcome.
Congratulations! You have fought your way through some
tricky issues in a tough problem to come up with some good
code. You are no longer a noob.
So I'm not really qualified to hand out advice, but I will
anyway. Consider them peer-to-peer comments.
> example usage:
> :cl-user> (test *nfa/input* #'simulate-nfa2)
> (EPSILON) -> (Q3)
> (Y) -> (Q3)
> (Y Y Y Y) -> (Q3)
> (X Y Y Y) -> NIL
> (Y X) -> NIL
Exemplary! Others (including me) could learn from this. If
you want others to read your code, include some examples of
what it does.
> ;;; example nfa in list form w/input strings
> (defparameter *nfa/input*
> '(((x y) ;alphabet
> (q1 q2 q3 q4 q5 q6 q7) ;states
> (q1) ;start states
> (q3) ;accept states
> ((q1 y q2) ;transition relation table,
> (q1 y q5) ;(state input result)
You could plunge straight in with the defstruct, then set up
the machine
(defstruct nfa
alphabet
states
start-states
accept-states
transition-table
trans-func)
(defparameter *machine1*
#s(nfa :alphabet (x y)
:states (q1 q2 q3 q4 q5 q6 q7)
:start-states (q1)
:accept-states (q3)
:transition-table ((q1 y q2) ;transition relation table,
(q1 y q5) ;(state input result)
(q1 x q6) ;where 'epsilon = no input
(q1 epsilon q6)
(q1 epsilon q3)
(q2 y q3)
(q2 epsilon q1)
(q3 epsilon q4)
(q4 epsilon q2)
(q5 epsilon q1)
(q6 y q7))))
I prefered to keep the test cases separate
(defparameter *input-strings*
`((epsilon) ;input strings
(y) ...
You get to build the transition function when you create the
structure. I had to write
(defun add-trans-function (nfa)
(setf (nfa-trans-func nfa)
(let ((stateXsymbol->state (make-hash-table :test 'equal)))
(dolist (transition-entry (nfa-transition-table nfa)
(lambda(state sym)
(copy-list (gethash (cons state sym)
stateXsymbol->state))))
(push (third transition-entry)
;; The accumulation of options
;; here is what makes the automaton
;; non-deterministic
(gethash (cons (first transition-entry)
(second transition-entry))
stateXsymbol->state
'()))))))
(I worry about add-trans-function. Is it unreadable crap?
If I have time I'll add a note at the end why I think that
is a reasonable style)
It would be more stylish to make nfa a class and have this
initialisation code as an after method on shared-initialize
I've used your technique of pushing the states onto the
hash-table. It is very clever, and surely worth a comment.
You are using the third argument to gethash to get your list
started. Good. That is what it is there for. It is unusual
though, so it is probably worth putting it in explicitly so
that readers can see that you are defaulting to the empty
list, and not doing the common thing of getting back nil as
a not-found flag.
> ;;;convenience functions
These had me puzzled for a while. Isn't mappend just mapcan?
No. There is a subtle dependency in the code. Your
transition function
> :transition-fn (lambda (state sym)
> (gethash (cons state sym) transition-hash)))))
is returning the list from the transition hashtable. mapcan
would destroy it, as I discovered when my version of your
code went into an infinite loop. So I bunged in a
copy-list. mappend is saves a few cons, because the last
list doesn't get copied.
> (defun mappend (fn lst)
> (apply #'append (mapcar fn lst)))
This is where you need a block comment explaining your
cunning plan.
> (defun set-union (&rest args)
> (remove-duplicates (apply #'union args)))
>
> (defun set-intersection (&rest args)
> (remove-duplicates (apply #'intersection args)))
These are very mysterious. Union only takes two sets as
arguments, so why a list? And why set-union? That is what
union is supposed to do. The clue comes in eps
> ;;; follow transitions that don't consume input, avoid loops
> (defun eps (start-states transition-fn)
> "return set of all states reachable from start-states by 0 or more
> epsilon transitions"
> (labels ((reach-from (lst)
> (mappend (lambda (s) (funcall transition-fn s 'epsilon))
> lst)))
> (do ((result start-states (set-union result new-states))
> (new-states (reach-from start-states) (reach-from new-states)))
> ((null (set-difference new-states result)) result))))
mappend isn't really a powerful as it needs to be. It is
creating sets, but fails to reduce them to cannonical form
because it isn't removing duplicates, so the built-in union
doesn't work right, and you have to patch it with your own
set-union.
I think that it would require super-natural foresight to
avoid getting into this kind of tangle. Your code is as good
as anyone gets in their first version. Nevertheless this is
the place where I would try to polish the code.
> ;;;same thing, more functional style
> (defun simulate-nfa2 (nfa input)
> "return accepting states, if any, reached by nfa on list of symbols
> given as input"
> (let* ((trans-fn (nfa-transition-fn nfa))
> (start-states (eps (nfa-starts nfa) trans-fn)))
> (set-intersection (nfa-accepts nfa)
> (reduce (lambda (states sym)
> (eps (mappend (lambda (state)
> (funcall trans-fn state sym))
> states)
> trans-fn))
> input
> :initial-value start-states))))
The use of reduce feels very natural to me, although I find
that lambda breaks the flow of the code. I've take to
using a little macro
(defmacro defcurry (name arglist1 arglist2 &body code)
`(defun ,name ,arglist1
(lambda ,arglist2 ,@code)))
so that I can write little function builders easily
(defcurry increase-by(x)(y)
(+ x y))
(mapcar (increase-by 10) '(1 2 3)) => (11 12 13)
so simulate-nfa ends up as two functions
(defcurry using-trans-func(trans-func)(from-set symbol)
(full-transition from-set trans-func symbol))
(defun simulate-nfa (nfa input)
(intersection (nfa-accept-states nfa)
(reduce (using-trans-func (nfa-trans-func nfa))
input
:initial-value (empty-transitions
(nfa-start-states nfa)
(nfa-trans-func nfa)))))
I've not mentioned this on c.l.l. before. Others might hate
it.
Returning to polishing the set manipulations. I've had a
think about this an come up with
;;; This functions embodies the claim that one can compute a
;;; transition by doing the transition required by the symbol
;;; and then adding all the sequences of empty transitions that
;;; are then possible
(defun full-transition (from-set trans-func symbol)
(empty-transitions (symbol-transition from-set trans-func symbol)
trans-func))
(defun symbol-transition (from-set trans-func symbol)
;; we are careful to keep our sets in canonical form
(remove-duplicates (mapcan (via-symbol trans-func
symbol)
from-set)))
(defcurry via-symbol(trans-func symbol)(state)
(funcall trans-func state symbol))
(defun single-empty-transition (from-set trans-func)
;; We can build empty transitions on top of non-empty
;; transitions, provided we remember that they are not
;; compulsory.
(union from-set
(symbol-transition from-set trans-func 'epsilon)))
;;; Now for the function I've been aiming towards.
;;; Getting the tricky, "repeat until stable" code as
;;; clean as possible.
(defun empty-transitions (from-set trans-func)
(do ((new (single-empty-transition from-set trans-func)
(single-empty-transition new trans-func))
(old from-set new))
((null (set-difference new old)) new)))
Have fun!
Alan Crowe
Edinburgh
Scotland
Alan Crowe wrote:
> You could plunge straight in with the defstruct, then set up
> the machine
...
> I prefered to keep the test cases separate
>
Yeah, in my particular case I already had a file of several pairs of
machine / input strings, so it was easier to keept the test cases
together with the given machine.
> It would be more stylish to make nfa a class and have this
> initialisation code as an after method on shared-initialize
I may have a go at rewriting it this way, but I haven't really used
clos at all yet.
> I've used your technique of pushing the states onto the
> hash-table. It is very clever, and surely worth a comment.
> You are using the third argument to gethash to get your list
> started. Good. That is what it is there for. It is unusual
> though, so it is probably worth putting it in explicitly so
> that readers can see that you are defaulting to the empty
> list, and not doing the common thing of getting back nil as
> a not-found flag.
Okay, the above worries me. Either I didn't understand my code, or
didn't write it in such a way that it was clear to others. I don't
think I'm using a third argument to gethash. I'm using a dotted pair
of (start-state . symbol) for the hash key, taken from the first two
entries in a given line of the transition table. I'm using the normal
default hash value, nil. Pushing a result state onto nil naturally
starts building a list.
> > ;;;convenience functions
> These had me puzzled for a while. Isn't mappend just mapcan?
I remembered mappend from the beginning of PAIP. I'm a little confused
as to why a non-destructive function to collate the results of a map
isn't in the language definition, when a destructive version is.
> The use of reduce feels very natural to me, although I find
> that lambda breaks the flow of the code. I've take to
> using a little macro
>
> (defmacro defcurry (name arglist1 arglist2 &body code)
> `(defun ,name ,arglist1
> (lambda ,arglist2 ,@code)))
>
> so that I can write little function builders easily
I thought about currying the transition-function at one point, but
realized I was only ever using it in one particular way; this became
the local 'next' function in the 4th version I posted,which to me is a
clearer abstraction. Is there a more or less standard way of
expressing currying in common lisp?
> ;;; Now for the function I've been aiming towards.
> ;;; Getting the tricky, "repeat until stable" code as
> ;;; clean as possible.
> (defun empty-transitions (from-set trans-func)
> (do ((new (single-empty-transition from-set trans-func)
> (single-empty-transition new trans-func))
> (old from-set new))
> ((null (set-difference new old)) new)))
I'm not sure about the clarity of this - there are about 5 layers of
abstraction I have to follow to get back to the original transition
function, including a macro. Does this buy you flexibility, say in
terms of implementing the other strategies (depth first search, reduce
the NFA to a DFA first . . ?).
Thanks for your comments, especially about needing more comments ;) Do
you think the 4th version has less need of explanation?
regards,
cody
··············@gmail.com" <·············@gmail.com> writes:
> Okay, the above worries me. Either I didn't understand my code, or
> didn't write it in such a way that it was clear to others. I don't
> think I'm using a third argument to gethash. I'm using a dotted pair
> of (start-state . symbol) for the hash key, taken from the first two
> entries in a given line of the transition table. I'm using the normal
> default hash value, nil. Pushing a result state onto nil naturally
> starts building a list.
I think I'm just reading too much into your code. At first I
couldn't work out what the push was for. I expected to see
(setf (gethash ...) next-state)
Pondering this I wondered why the code worked at all. After
all, it was a brand new hashtable with no list in it to push
onto. Well a missing key is indicated by a return value of
nil, so yes you could use push, but what was the author
actually tring to do, was this just a `clever' way of
writing
(setf (gethash ...) (list next-state))
but why wrap the state in a list? Was this something to do
with mapcan requiring freshly consed lists? If so, it wasn't
going to work.
Then I remembered about the third argument to gethash. If
you want to use a hash-table for counting things you can say
(incf (gethash key hashtable 0))
and you don't get an error from (+ nil 1) on an unitialised
key. So I finally worked out that you were doing
(push another-possible-next-state (gethash key hashtable '()))
and exploiting the fact that the not-in-the-table return
value happens to be the empty list to let you leave out the
third argument.
So I hope you can see the difference between understanding
code that you have just written, and understanding code that
somebody else wrote or that you wrote a year or two ago.
>
> > > ;;;convenience functions
> > These had me puzzled for a while. Isn't mappend just mapcan?
>
> I remembered mappend from the beginning of PAIP. I'm a little confused
> as to why a non-destructive function to collate the results of a map
> isn't in the language definition, when a destructive version is.
My guess: usually the function is consing up a fresh
list. Copying it with append means that all those conses are
wasted. You have to have mapcan so that programmers can
avoid that. Then mappend looks mostly redundant.
> > ;;; Now for the function I've been aiming towards.
> > ;;; Getting the tricky, "repeat until stable" code as
> > ;;; clean as possible.
> > (defun empty-transitions (from-set trans-func)
> > (do ((new (single-empty-transition from-set trans-func)
> > (single-empty-transition new trans-func))
> > (old from-set new))
> > ((null (set-difference new old)) new)))
>
> I'm not sure about the clarity of this - there are about 5 layers of
> abstraction I have to follow to get back to the original transition
> function, including a macro. Does this buy you flexibility, say in
> terms of implementing the other strategies (depth first search, reduce
> the NFA to a DFA first . . ?).
Thinking about some more, I would be inclined to write
(defun fixed-point (function starting-point &optional (test #'eql))
(do ((new (funcall function starting-point)
(funcall function new))
(old starting-point new))
((funcall test new old) new)))
and define set-equal and then write empty-transitions as
(defun empty-transitions (from-set trans-func)
(fixed-point (single-empty-transition-using trans-func)
from-set
#'set-equal))
(defcurry single-empty-transition-using (trans-func)(from-set)
(single-empty-transition from-set trans-func))
which adds a sixth layer of abstraction :-)
What I think this buys me is something very down to earth.
I can play with fixed-point separately from the rest of the
code
* (fixed-point (lambda(n)(if (< n 10) (+ n 1) n)) 3) => 10
So I debug my control flow concepts without thinking about the
details of my application. Done right this buys me an
exemption from conventional debugging, ie no digging into
the messy guts of a real application. Well maybe. I hope I've
explained the idea.
Err, you are auditing an academic course. Isn't getting an
abstract, eagles eye view of nfa's the ultimate goal?
> Thanks for your comments, especially about needing more comments ;) Do
> you think the 4th version has less need of explanation?
I missed the earlier versions. There are many posts on
c.l.l. I triage with great brutality, deleting threads
unread, and no doubt missing out on much interesting stuff.
If the code is for others to read, or to be kept for more than
a few weeks, so that you can no longer remember the details,
then you need to write many more comments.
Comments are where you get to boast of prowess.
Remember to explain the problem that your clever trick
solves. Don't let anyone underestimate your brilliance
because they didn't realise that there was a pitfall to be
avoided.
That paragraph is only partly tongue in cheek. Programmers
get put off writing comments because they are
encouraged/taught to comment 20 line exercises for which
comments are not really needed. But even a hundred line
program has tricky interactions between the parts and
requires design decisions, so there is real meat to put in
the comments.
Alan Crowe
Edinburgh
Scotland
This is a Qi - not a Lisp solution. It
is compiled into Lisp.
Here is a NDFSM table.
State Input Goes to State
========================================
1 a 2
1 a 3
2 b 1
2 b 3
3 c 2
4 c 4
1 is the start state
4 is the acceptor state
We want to show that [a b a b a c] is accepted
by the above NDFSM. Here is the Qi code.
(define state1
[a | X] <- (state2 X)
[a | X] -> (state3 X)
_ -> #\Escape)
(define state2
[b | X] <- (state1 X)
[b | X] -> (state3 X)
_ -> #\Escape)
(define state3
[c | X] <- (state2 X)
[c | X] -> (state4 X)
_ -> #\Escape)
(define state4
[] -> accept
_ -> #\Escape)
A short script.
(4-) (state1 [a b a b a c])
accept
(5-) (state1 [a b a b a c c])
#\Escape
Qi contains backtracking on demand. See chapter 7 in
FPQi on this.
The <- returns its RHS iff the RHS does not evaluate
to #\Escape. If it does then the next line of the
function is evaluated. This NDFSM either returns
accept (if it accepts a sentence) or #\Escape otherwise.
Thats rather shorter than the Lisp version. Probably need
to explain this better; but need lunch.
Mark