haskeem-0.7.7: regexp.scm
; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
; $Id: regexp.scm,v 1.14 2009-07-02 05:49:56 uwe Exp $
; BSD3... but if you use this for anything serious, you gotta be kidding
; grammar for regular expressions: precedence is (highest to lowest)
; counting operators: *+? TODO: add count {N} or range {LO,HI}
; -> convert current ops to
; ('count lo hi ...) kind of thing
; concatenation
; alternation RE1 | RE2
; parentheses force grouping
; TODO: add negated ranges [^a-z], more-complex character ranges [a-fq-z] etc
;
; regexp = re1
; | re1 '|' regexp
;
; re1 = re2
; | re2 re1
;
; re2 = re3
; | re3 '?'
; | re3 '*'
; | re3 '+'
;
; re3 = character
; | escaped-character
; | character-range (only simple ranges [x-y])
; | '(' regexp ')'
;
; NOTE!!! escaped characters are '\(' for example; but the scheme reader
; already processes '\', so if entering from keyboard or some literal
; string, need to double-escape it: for example (regexp-parse "(a|\\()*")
; An NFA state is a list: the car is the name of the state itself, a simple
; integer. The names are generated by the st-count counter in the
; regexp-make-nfa routine: it starts at 0, and it's pre-incremented, so
; state names start at 1. In principle, they could be arbitrary, but we
; make use of the fact that they are non-negative integers in the next
; routine, where we generate the epsilon-closure of each state: we use
; bit-sets there, which assume (in my implementation) that all elements of
; a set are non-negative integers. The second element of the NFA state
; list is the set of states to which epsilon-transitions are possible. In
; the output of this routine, that is a simple list of state names; in the
; output of gen-eps-closure, it gets turned into a bitset which is
; represented as a single integer. The remaining entries in the list are
; themselves lists, each representing a new state to which a transition may
; be made, and the inputs triggering that transition. For example:
;
; (2 (10) (1 #\+ #\-) (5 #\a #\b) (7 #\c #\d))
;
; describes NFA state 2, with an eps-transition to state 10, and capable of
; undergoing a transition to state 1 on inputs #\+ and #\-, to state 5 on
; inputs #\a and #\b, and to state 7 on inputs #\c and #\d.
;
; A complete NFA is a list of such NFA states. The first state in the list is
; the start state, and the second state in the list is the end state (although
; of course multiple internal states can & often will make eps-transitions to
; that final state, so that they too are accepting states). States beyond the
; first two are internal states (subject to the previous comment).
;
; There is no particular order associated with the state identifiers.
; Generally the start state will be 2, due to the particulars of how the
; make-nfa routine allocates its states; but there is no significance
; attached to that.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Parse a complete regular expression, checking that there is nothing left
; at the end. This is kind of a large function... but I don't really want to
; expose the individual levels, they don't make much sense by themselves.
; This returns an AST: a literal character or a list of lists describing
; sub-regexps. The car of each list is a description of the type of regexp:
; 'CONCAT, 'ALT, or 'COUNT. If the type is 'COUNT, then the cadr of the list
; descibes the count range: currently one of #\? #\* #\+. Remaining entries
; in all the lists are again ASTs.
(define (regexp-parse str)
(letrec* ((tokens (filter (lambda (c) (not (char-whitespace? c)))
(string->char str)))
(cur-tok #f)
; look ahead one character without consuming it
(peek (lambda ()
(if (null? tokens)
#f
(car tokens))))
; get and consume the current character
(pop (lambda ()
(if (null? tokens)
#f
(begin (set! cur-tok (car tokens))
(set! tokens (cdr tokens))
cur-tok))))
; handle choice operator '|'
(p-re0 (lambda ()
(let* ((re1 (p-re1))
(cur (peek)))
(if (eqv? cur #\|)
(begin (pop)
(list 'ALT re1 (p-re0)))
re1))))
; handle special kind of choice: character range; for now, only handle
; [a-b] type (except that the brackets are done outside these routines)
(gen-range (lambda (cs)
(if (null? (cdr cs))
(car cs)
(list 'ALT (car cs) (gen-range (cdr cs))))))
(p-range (lambda ()
(let* ((c1 (char->integer (pop)))
(cminus (pop))
(c2 (char->integer (pop)))
(lo (min c1 c2))
(hi (max c1 c2))
(n (+ 1 (- hi lo))))
(if (eqv? cminus #\-)
(gen-range (map integer->char (upfrom lo n)))
(raise "bad character range")))))
; handle concatenation "operator"
(p-re1 (lambda ()
(let* ((re2 (p-re2))
(cur (peek)))
(if (or (eqv? cur #f)
(eqv? cur #\|)
(eqv? cur #\)))
re2
(list 'CONCAT re2 (p-re1))))))
; handle count operators '?', '*', and '+'
(p-re2 (lambda ()
(let* ((re3 (p-re3))
(cur (peek)))
(if (or (eqv? cur #\?)
(eqv? cur #\*)
(eqv? cur #\+))
(list 'COUNT (pop) re3)
re3))))
; handle individual characters and parenthesized regexps
(p-re3 (lambda ()
(let ((cur (peek)))
(cond ((eqv? cur #\()
(pop)
(set! cur (p-re0))
(if (eqv? (peek) #\))
(begin (pop) cur)
(raise "error: unbalanced parentheses")))
((eqv? cur #\[)
(pop)
(set! cur (p-range))
(if (eqv? (peek) #\])
(begin (pop) cur)
(raise "error: unbalanced brackets")))
((eqv? cur #\\)
(pop)
(pop))
((or (eqv? cur #\|)
(eqv? cur #\?)
(eqv? cur #\*)
(eqv? cur #\+))
(raise "error: unexpected operator"))
(else (pop))))))
; parse the whole regexp
(regexp (p-re0)))
; if there's something left over, it's an error;
; otherwise, we've successfully parsed the regexp
(if (eqv? (peek) #f)
regexp
(raise "error: input not completely used"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Flatten the AST produced by regexp-parse: instead of a nearly pure tree
; of binary ops, CONCAT and ALT get turned into multi-operand operators
; where applicable. For example
; (CONCAT #\a (CONCAT #\b (CONCAT #\c (CONCAT #\d #\e))))
; gets turned into
; (CONCAT #\a #\b #\c #\d #\e)
; This makes the NFA have a lot fewer intermediate states.
; Probably this should eventually just get added into regexp-parse, but
; for now it's nicer to be able to look at all the intermediate steps.
(define (regexp-flatten-ast ast)
(let ((s-op (lambda (op t1 t2)
(let ((lifter (lambda (l)
((if (and (list? l) (eqv? (car l) op))
cdr
list) l))))
(cons op (append (lifter t1) (lifter t2)))))))
(if (list? ast)
(cond ((eqv? 'COUNT (car ast))
(list (car ast)
(cadr ast)
(regexp-flatten-ast (caddr ast))))
((or (eqv? 'CONCAT (car ast)) (eqv? 'ALT (car ast)))
(s-op (car ast)
(regexp-flatten-ast (cadr ast))
(regexp-flatten-ast (caddr ast))))
(else ast))
ast)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This routine generates a list of states describing an NFA, given an AST
; generated from the above routine(s). The first state in the list will be
; the start state, and the second state in the list will be the end state;
; intermediate states will follow after that. The initial version produces
; copious intermediate states with epsilon-transitions. It does do fairly
; efficient character ranges now: rather than producing a pair of states
; for every single character in a range, and gluing all of these together
; with another pair of states, it just does one pair of states with a whole
; bunch of characters on which to transition.
(define (regexp-make-nfa ast)
(letrec* ((con3 (lambda (a b c) (cons a (cons b c))))
; Make a new state
(st-count 0)
(mk-st (lambda ()
(set! st-count (+ 1 st-count))
(list st-count '())))
; Add a transition from state ST1 to state ST2 on character C
; or an eps-transition if c is the empty list
(add-tr (lambda (st1 st2 c)
(cons (car st1)
(append
(cond ((null? c)
(list (cons (car st2) (cadr st1))))
((char? c)
(list (cadr st1) (list (car st2) c)))
(else
(list (cadr st1) (cons (car st2) c))))
(cddr st1)))))
; Make a simple alternation across a range of chars
(mk-alt-range (lambda (chars)
(let* ((st2 (mk-st))
(st1 (add-tr (mk-st) st2 chars)))
(list st1 st2))))
; Add an eps-transition from state ST to each of the states in the list STS
(add-h-eps (lambda (st sts)
(if (null? sts)
st
(add-h-eps
(add-tr st (car sts) '()) (cdr sts)))))
; Add an eps-transition from the tail state of NFA to state ST
(add-t-eps (lambda (nfa st)
(con3 (car nfa)
(add-tr (cadr nfa) st '())
(cddr nfa))))
; Merge two NFAs into one which represents their concatenation
(merge-nfas (lambda (nfa1 nfa2)
(cond ((null? nfa1) nfa2)
((null? nfa2) nfa1)
(else (let ((h2 (car nfa2)))
(con3 (car nfa1) (cadr nfa2)
(append
(list
(add-tr
(cadr nfa1) h2 '()) h2)
(cddr nfa1)
(cddr nfa2))))))))
; Main routine to walk the AST and translate into an NFA
(gen-nfa (lambda (ast)
(let ((st #f)
(cop #f)
(sub #f))
(cond ((char? ast)
(set! st (mk-st))
(list (add-tr (mk-st) st ast) st))
((eqv? 'COUNT (car ast))
(set! cop (cadr ast))
(set! sub (gen-nfa (caddr ast)))
(cond ((eqv? #\? cop)
(cons (add-tr (car sub) (cadr sub) '())
(cdr sub)))
((eqv? #\+ cop)
(con3 (car sub)
(add-tr (cadr sub) (car sub) '())
(cddr sub)))
((eqv? #\* cop)
(con3 (add-tr (car sub) (cadr sub) '())
(add-tr (cadr sub) (car sub) '())
(cddr sub)))
(else (raise "unknown COUNT op!"))))
((eqv? 'CONCAT (car ast))
(foldl merge-nfas '() (map gen-nfa (cdr ast))))
((eqv? 'ALT (car ast))
(let* ((part (partition char? (cdr ast)))
(chars (car part))
(other (cadr part)))
(unless (null? chars)
(set! chars (mk-alt-range chars)))
(unless (null? other)
(set! sub (map gen-nfa other))
(unless (null? chars)
(set! sub
(cons (list chars) sub))
(set! chars '())))
(if (null? other)
chars
(begin
(set! st (mk-st))
(con3 (add-h-eps (mk-st)
(map car sub)) st
(apply append
(map (lambda (a)
(add-t-eps a st))
sub)))))))
(else (raise "unknown regexp op!")))))))
(gen-nfa ast)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This is a lot simpler using a vector than it would be with pure lists...
; it would be possible, but the vector gives us the equivalent of set-car!
; and that makes a huge difference. With bitsets, it's even not
; unreasonably slow.
(define (regexp-gen-eps-closure nfa)
(letrec* ((max-state (lambda (nfa m)
(if (null? nfa)
m
(max-state (cdr nfa) (max m (caar nfa))))))
(n (+ 1 (max-state nfa 1)))
(vec (make-vector n))
(cur #f)
(new #f)
(change #t))
(map (lambda (s)
(vector-set! vec (car s)
(foldl bitset-add (bitset-new) (cadr s))))
nfa)
(while change
(set! change #f)
(do ((i 1 (+ i 1)))
((>= i n) #t)
(set! cur (vector-ref vec i))
(set! new cur)
(bitset-for-each
cur (lambda (j)
(set! new (bitset-or new (vector-ref vec j)))))
(unless (bitset-equal? new cur)
(set! change #t)
(vector-set! vec i new))))
(map (lambda (s)
(let ((ec (vector-ref vec (car s))))
(set! ec (bitset-add ec (car s)))
(cons (car s) (cons ec (cddr s)))))
nfa)))
; This generates the epsilon-union of a state set from the nfa
(define (find-eps-union set nfa)
(letrec* ((eps-union (bitset-new))
(find-eps-closure
(lambda (s nfa)
(cond ((null? nfa)
(raise "programming error! state not in nfa!"))
((= s (caar nfa)) (cadar nfa))
(else (find-eps-closure s (cdr nfa))))))
(merge-eps-closure
(lambda (s)
(set! eps-union
(bitset-or eps-union (find-eps-closure s nfa))))))
(bitset-for-each set merge-eps-closure)
eps-union))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This makes a DFA from the NFA... eventually.
; It assumes an NFA that is the output of gen-eps-closure rather than one
; that comes directly out of make-nfa; we might need to eventually test for
; that and do it automatically. It also assumes that the initial state is
; the first one in the NFA, and the matching state is the second one; this
; is as constructed by make-nfa and preserved by gen-eps-closure. If I
; understand J & C correctly, the gen-eps-closure routine has done a fair
; part of the work for this already, since it has generated the
; eps-closures for all the NFA states already.
; pseudo-code from J & C:
; {M} = eps-closure of NFA state 1
; DFA state 1 = {M}
; add {M} to work queue (or stack, order doesn't particularly matter)
; while (work queue/stack not empty)
; remove {M}
; for each input character i
; {P} = set of states reachable from {M} on input i
; if ({P} is the empty set) then
; do nothing
; else
; {N} = eps-union({P})
; if ({N} already exists as a DFA state) then
; do nothing
; else
; add {N} to work queue/stack
; end if
; add a transition from {M} to {N} labeled i
; end if
; end do
; end while
(define (regexp-make-dfa nfa)
(let ((counter 0)
(dfa-states '())
(agenda '()))
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; NFA walker
; This makes a single transition from any one of the input states STS,
; given the character CH
(define (make-transition nfa sts ch)
(letrec ((find-transitions
(lambda (s ss)
(cond ((null? ss) (raise "programming error! state not in nfa!"))
((= s (caar ss)) (cddar ss))
(else (find-transitions s (cdr ss))))))
(p-trans (lambda (acc trans)
(if (memv ch (cdr trans))
(bitset-add acc (car trans))
acc)))
(eps-union (find-eps-union sts nfa))
(new-sts (bitset-new)))
; make all possible transitions to new states from this eps-union
; TODO: this is a foldl, too... make it so -- maybe need a bitset-foldl
; unholy mix of scheme and quasi-haskell syntax, and some details are
; wrong... but something vaguely like this is what I think I want
; (bitset-foldl (bitset-or . (find-transitions s nfa)) (bitset-new) eps-union)
(bitset-for-each eps-union
(lambda (s)
(set! new-sts
(bitset-or new-sts
(foldl p-trans (bitset-new)
(find-transitions s nfa))))))
new-sts))
; Make a series of transitions
(define (make-transitions nfa init-state str . match-states)
(letrec* ((chars (string->char str))
(matches (foldl bitset-add (bitset-new) match-states))
(no-matches? (null? match-states))
(last-accept '())
(last-accept-state 0)
(mk-ret (lambda (a s)
(let ((mr1 (lambda (a s)
(list (char->string (reverse a)) s))))
(if no-matches?
(mr1 a s)
(mr1 last-accept last-accept-state)))))
(doit (lambda (sts chs acc)
(if (null? chs)
(mk-ret acc sts)
(let* ((new-st (make-transition nfa sts (car chs)))
(nsu (find-eps-union new-st nfa)))
(if (bitset-empty? new-st)
(mk-ret acc sts)
(begin (set! acc (cons (car chs) acc))
(unless (bitset-empty?
(bitset-and matches nsu))
(set! last-accept acc)
(set! last-accept-state nsu))
(doit new-st (cdr chs) acc)))))))
(result (doit (bitset-add (bitset-new) init-state) chars '()))
(final-state (find-eps-union (cadr result) nfa)))
(if no-matches?
(cons #t result)
(begin (set! matches (bitset-and matches last-accept-state))
(if (bitset-empty? matches)
(list #f)
(list #t (car result) matches))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Some simple regexps to try out: note that all the escaped characters
; are double-escaped: to get a literal '+' into the regexp parser, we
; need to get it (a) past the REPL's escape mechanism, then (b) escape
; it for the regexp parser. Hence all the '\\+'
; unsigned and signed integers: very simple
(define unsigned-integer "[0-9]+")
(define signed-integer "(\\+|-)?[0-9]+")
; an unsigned decimal number: xxx.yyy, where both xxx and yyy can
; represent any number of digits including none, except that they
; can't both be empty simultaneously. allow plain unsigned integers,
; don't require a decimal point
(define unsigned-decimal
"(([0-9]+(.[0-9]*)?)|([0-9]*.[0-9]+))")
; same as above, with an optional sign out front
(define signed-decimal
(string-join-by "" "(\\+|-)?" unsigned-decimal))
; same as above, with an optional scientific-notation trailer
(define signed-scientific
(string-join-by "" signed-decimal "((e|E)(\\+|-)?[0-9]+)?"))
; same in base-2, for simplicity
(define unsigned-integer2 "[0-1]+")
(define signed-integer2 "(\\+|-)?[0-1]+")
(define unsigned-decimal2
"(([0-1]+.[0-1]*)|([0-1]*.[0-1]+))")
(define signed-decimal2
(string-join-by "" "(\\+|-)?" unsigned-decimal2))
(define signed-scientific2
(string-join-by "" signed-decimal2 "((e|E)(\\+|-)?[0-1]+)?"))
; Possible variable names for a C-like language... this runs very fast
; (for some value of "very"...)
(define var-or-keyword "([A-Z]|[a-z]|_)([a-z]|[A-Z]|[0-9]|_)*")
; These two are for conveniently building "killer" regexps which will
; cause backtracking NFA implementations (such as in perl, python, and
; many other scripting languages) to run exponentially slowly. We do
; better than that... although the constant out front is kinda bad :-)
(define (make-slow-string n)
(string-join-by "" (replicate "a" n)))
(define (make-slow-regexp n)
(string-join-by "" (append (replicate "a?" n) (replicate "a" n))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; debugging stuff
(define (show-eps cur)
(if (number? cur)
(let ((start #\<))
(if (bitset-empty? cur)
(write-string start)
(bitset-for-each cur (lambda (j)
(write-string start)
(set! start #\space)
(write-string (number->string j)))))
(write-string ">"))
(display cur)))
(define (tab) (write-string #\tab))
(define (space) (write-string #\space))
(define (show-state s)
(write-string "state = ")
(display (car s))
(unless (null? (cadr s))
(write-string "\teps ")
(show-eps (cadr s)))
(unless (null? (cddr s))
(write-string " regular ")
(map (lambda (x) (display x) (space)) (cddr s)))
(newline))
(define (show-states s)
(write-string "states = \n")
(map (lambda (st) (show-state st)) s)
#t)