Merge commit '4709fc4530da4ddfd29b910763c801292b228f69' from diff-hl

[gnu-emacs-elpa] / packages / tNFA / tNFA.el

;;; tNFA.el --- Tagged non-deterministic finite-state automata

;; Copyright (C) 2008-2010, 2012   Free Software Foundation, Inc

;; Author: Toby Cubitt <toby-predictive@dr-qubit.org>
;; Version: 0.1.1
;; Keywords: extensions, matching, data structures
;;           tNFA, NFA, DFA, finite state automata, automata, regexp
;; Package-Requires: ((queue "0.1"))
;; URL: http://www.dr-qubit.org/emacs.php
;; Repository: http://www.dr-qubit.org/git/predictive.git

;; This file is part of Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
;; more details.
;;
;; You should have received a copy of the GNU General Public License along
;; with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.


;;; Commentary:
;;
;; A tagged, non-deterministic finite state automata (NFA) is an abstract
;; computing machine that recognises regular languages. In layman's terms,
;; they are used to decide whether a string matches a regular expression. The
;; "tagged" part allows the NFA to do group-capture: it returns information
;; about which parts of a string matched which subgroup of the regular
;; expression.
;;
;; Why re-implement regular expression matching when Emacs comes with
;; extensive built-in support for regexps? Primarily, because some algorithms
;; require access to the NFA states produced part way through the regular
;; expression matching process (see the trie.el package for an
;; example). Secondarily, because Emacs regexps only work on strings, whereas
;; regular expressions can usefully be used in Elisp code to match other
;; sequence types, not just strings.
;;
;; A tagged NFA can be created from a regular expression using
;; `tNFA-from-regexp', and its state can be updated using
;; `tNFA-next-state'. You can discover whether a state is a matching state
;; using `tNFA-match-p', extract subgroup capture data from it using
;; `tNFA-group-data', check whether a state has any wildcard transitions using
;; `tNFA-wildcard-p', and get a list of non-wildcard transitions using
;; `tNFA-transitions'. Finally, `tNFA-regexp-match' uses tagged NFAs to decide
;; whether a regexp matches a given string.
;;
;; Note that Emacs' regexps are not regular expressions in the original
;; meaning of that phrase. Emacs regexps implement additional features (in
;; particular, back-references) that allow them to match far more than just
;; regular languages. This comes at a cost: regexp matching can potentially be
;; very slow (NP-hard in fact, though the hard cases rarely crop up in
;; practise), whereas there are efficient (polynomial-time) algorithms for
;; matching regular expressions (in the original sense). Therefore, this
;; package only supports a subset of the full Emacs regular expression
;; syntax. See the function docstrings for more information.
;;
;; This package essentially implements Laurikari's algorithm, as described in
;; his master's thesis, but it builds the corresponding tagged deterministic
;; finite state automaton (DFA) on-the-fly as needed.
;;
;; This package uses the queue package queue.el.


;;; Change Log:
;;
;; Version 0.1.1
;; * work-around mysterious byte-compiler bug by defining
;;   `tNFA--NFA-state-create' and `tNFA--NFA-state-create-tag' via `defun'
;;   instead of directly in `defstruct'
;;
;; Version 0.1
;; * initial version



;;; Code:

(eval-when-compile (require 'cl))
(require 'queue)



;;; ================================================================
;;;                  Replcements for CL functions

(defun* tNFA--assoc (item alist &key (test 'eq))
  ;; Return first cons cell in ALIST whose CAR matches ITEM according to
  ;; :test function (defaulting to `eq')
  (while (and alist
              (or (not (consp (car alist)))
                  (not (funcall test item (caar alist)))))
    (setq alist (cdr alist)))
  (car alist))



;;; ================================================================
;;;                    Data structures

;;; ----------------------------------------------------------------
;;;                    tagged NFA states

(defstruct
  (tNFA--state
   (:constructor nil)
   (:constructor tNFA--state-create-initial
                 (NFA-state num-tags min-tags max-tags
                  &aux
                  (tags (tNFA--tags-create num-tags min-tags max-tags))))
   (:constructor tNFA--state-create (NFA-state tags))
   (:copier nil))
  NFA-state tags)

(defmacro tNFA--state-id (state)
  `(tNFA--NFA-state-id (tNFA--state-NFA-state ,state)))

(defmacro tNFA--state-type (state)
  `(tNFA--NFA-state-type (tNFA--state-NFA-state ,state)))

(defmacro tNFA--state-label (state)
  `(tNFA--NFA-state-label (tNFA--state-NFA-state ,state)))

(defmacro tNFA--state-in-degree (state)
  `(tNFA--NFA-state-in-degree (tNFA--state-NFA-state ,state)))

(defmacro tNFA--state-next (state)
  `(tNFA--NFA-state-next (tNFA--state-NFA-state ,state)))

(defmacro tNFA--state-count (state)
  `(tNFA--NFA-state-count (tNFA--state-NFA-state ,state)))



;;; ----------------------------------------------------------------
;;;                         NFA states

(declare (special NFA--state-id))

(defstruct
  (tNFA--NFA-state
   (:type vector)
   (:constructor nil)
   (:constructor tNFA---NFA-state-create
                 (&optional type label next
                  &aux
                  (in-degree 0)
                  (count 0)
                  (id (incf NFA--state-id))
                  ;; (dummy
                  ;;  (when next
                  ;;    (setf (tNFA--NFA-state-count next)
                  ;;       (incf (tNFA--NFA-state-in-degree next)))))
                  ))
   (:constructor tNFA--NFA-state-create-branch
                 (&rest next
                  &aux
                  (type 'branch)
                  (in-degree 0)
                  (count 0)
                  (id (incf NFA--state-id))))
   (:constructor tNFA---NFA-state-create-tag
                 (tag &optional next
                  &aux
                  (type 'tag)
                  (label tag)
                  (in-degree 0)
                  (count 0)
                  (id (incf NFA--state-id))
                  ;; (dummy
                  ;;  (when next
                  ;;    (setf (tNFA--NFA-state-count next)
                  ;;       (incf (tNFA--NFA-state-in-degree next)))))
                  ))
   (:copier nil))
  id type label in-degree
  count tNFA-state  ; used internally in NFA evolution algorithms
  next)


;; Define these via defun instead of using the dummy argument in the
;; above defstruct to work around a mysterious byte-compiler bug.

(defun tNFA--NFA-state-create (&optional type label next)
  (when next
    (setf (tNFA--NFA-state-count next)
          (incf (tNFA--NFA-state-in-degree next))))
    (tNFA---NFA-state-create type label next))

(defun tNFA--NFA-state-create-tag (tag &optional next)
  (when next
    (setf (tNFA--NFA-state-count next)
          (incf (tNFA--NFA-state-in-degree next))))
    (tNFA---NFA-state-create-tag tag next))


;; tag number for a tagged epsilon transition is stored in label slot
(defalias 'tNFA--NFA-state-tag 'tNFA--NFA-state-label)

(defmacro tNFA--NFA-state-tags (state)
  `(tNFA--state-tags (tNFA--NFA-state-tNFA-state ,state)))


(defun tNFA--NFA-state-patch (attach state)
  ;; patch STATE onto ATTACH. Return value is meaningless
  (setf
   (tNFA--NFA-state-type attach)
     (tNFA--NFA-state-type state)
   (tNFA--NFA-state-label attach)
     (tNFA--NFA-state-label state)
   (tNFA--NFA-state-next attach)
     (tNFA--NFA-state-next state)
   (tNFA--NFA-state-count state)
     (incf (tNFA--NFA-state-in-degree state))))


(defun tNFA--NFA-state-make-epsilon (state next)
  ;; create an epsilon transition from STATE to NEXT
  (setf
   (tNFA--NFA-state-type state)  'epsilon
   (tNFA--NFA-state-label state) nil
   (tNFA--NFA-state-next state)  next
   (tNFA--NFA-state-count next)
     (incf (tNFA--NFA-state-in-degree next))))


(defun tNFA--NFA-state-make-branch (state next)
  ;; create a branch from STATE to all states in NEXT list
  (setf (tNFA--NFA-state-type state)  'branch
        (tNFA--NFA-state-label state) nil
        (tNFA--NFA-state-next state)  next)
  (dolist (n next)
    (setf (tNFA--NFA-state-count n)
          (incf (tNFA--NFA-state-in-degree n)))))


(defun tNFA--NFA-state-copy (state)
  ;; Return a copy of STATE. The next link is *not* copied, it is `eq'
  ;; to the original next link. Use `tNFA--fragment-copy' if you want to
  ;; recursively copy a chain of states. Note: NFA--state-id must be
  ;; bound to something appropriate when this function is called.
  (let ((copy (copy-sequence state)))
    (setf (tNFA--NFA-state-id copy) (incf NFA--state-id))
    copy))



;;; ----------------------------------------------------------------
;;;                        NFA fragments

(defstruct
  (tNFA--fragment
   (:type vector)
   (:constructor nil)
   (:constructor tNFA--fragment-create (initial final))
   (:copier nil))
  initial final)


(defun tNFA--fragment-patch (frag1 frag2)
  ;; patch FRAG2 onto end of FRAG1; return value is meaningless
  (tNFA--NFA-state-patch (tNFA--fragment-final frag1)
                        (tNFA--fragment-initial frag2))
  (setf (tNFA--fragment-final frag1) (tNFA--fragment-final frag2)))


(defun tNFA--fragment-copy (fragment)
  ;; return a copy of FRAGMENT.
  (declare (special copied-states))
  (let (copied-states)
    (tNFA--fragment-create
     (tNFA--do-fragment-copy (tNFA--fragment-initial fragment))
     (cdr (assq (tNFA--fragment-final fragment) copied-states)))))


(defun tNFA--do-fragment-copy (state)
  ;; return a copy of STATE, recursively following and copying links
  ;; (note: NFA--state-id must be bound to something appropriate when
  ;; this is called)
  (declare (special copied-states))
  (let ((copy (tNFA--NFA-state-copy state)))
    (push (cons state copy) copied-states)

    ;; if STATE is a branch, copy all links
    (cond
     ((eq (tNFA--NFA-state-type copy) 'branch)
      (setf (tNFA--NFA-state-next copy)
            (mapcar (lambda (next)
                      (or (cdr (assq next copied-states))
                          (tNFA--do-fragment-copy next)))
                    (tNFA--NFA-state-next copy))))

     ;; if state doesn't have a next link, return
     ((or (eq (tNFA--NFA-state-type copy) 'match)
          (null (tNFA--NFA-state-type copy))))

     ;; otherwise, copy next link
     ((tNFA--NFA-state-type copy)
      ;; for a non-branch STATE, copy next link
      (setf (tNFA--NFA-state-next copy)
            ;; if we've already copied next state, set next link to that
            (or (cdr (assq (tNFA--NFA-state-next copy) copied-states))
                ;; otherwise, recursively copy next state
                (tNFA--do-fragment-copy (tNFA--NFA-state-next copy))))))
    copy))



;;; ----------------------------------------------------------------
;;;                      DFA states

(defstruct
  (tNFA--DFA-state
   :named
   (:constructor nil)
   (:constructor tNFA--DFA-state--create
                 (list pool
                  &key
                  (test 'eq)
                  &aux
                  (transitions ())))
   (:copier nil))
  list transitions test wildcard match pool)


(defun* tNFA--DFA-state-create (state-list state-pool &key (test 'eq))
  ;; create DFA state and add it to the state pool
  (let ((DFA-state (tNFA--DFA-state--create
                    state-list state-pool :test test))
        tmp-list)
    (puthash state-list DFA-state (tNFA--DFA-state-pool DFA-state))

    (dolist (state state-list)
      ;; if state in state list is...
      (cond
       ;; literal state: add literal transition
       ((eq (tNFA--state-type state) 'literal)
        (setq tmp-list (tNFA--DFA-state-transitions DFA-state))
        (add-to-list 'tmp-list (cons (tNFA--state-label state) t))
        (setf (tNFA--DFA-state-transitions DFA-state) tmp-list))

       ;; character alternative: add transitions for all alternatives
       ((eq (tNFA--state-type state) 'char-alt)
        (dolist (c (tNFA--state-label state))
          (setq tmp-list (tNFA--DFA-state-transitions DFA-state))
          (add-to-list 'tmp-list (cons c t))
          (setf (tNFA--DFA-state-transitions DFA-state) tmp-list)))

       ;; wildcard or negated character alternative: add wildcard
       ;; transistion
       ((or (eq (tNFA--state-type state) 'wildcard)
            (eq (tNFA--state-type state) 'neg-char-alt))
        (setf (tNFA--DFA-state-wildcard DFA-state) t))

       ;; match state: set match tags
       ((eq (tNFA--state-type state) 'match)
        (setf (tNFA--DFA-state-match DFA-state)
              (tNFA--state-tags state)))))

    ;; return constructed state
    DFA-state))


(defun* tNFA--DFA-state-create-initial (state-list &key (test 'eq))
  ;; create initial DFA state from initial tNFA state INITIAL-STATE
  (tNFA--DFA-state-create state-list
                          (make-hash-table :test 'equal)
                          :test test))


(defalias 'tNFA-match-p 'tNFA--DFA-state-match
  "Return non-nil if STATE is a matching state, otherwise return nil.")


(defalias 'tNFA-wildcard-p 'tNFA--DFA-state-wildcard
  "Return non-nil if STATE has a wildcard transition,
 otherwise return nil.")


(defun tNFA-transitions (state)
  "Return list of literal transitions from tNFA state STATE."
  (mapcar 'car (tNFA--DFA-state-transitions state)))



;;; ----------------------------------------------------------------
;;;                      tag tables

(defun tNFA--tags-create (num-tags min-tags max-tags)
  ;; construct a new tags table
  (let ((vec (make-vector num-tags nil)))
    (dolist (tag min-tags)
      (aset vec tag (cons -1 'min)))
    (dolist (tag max-tags)
      (aset vec tag (cons -1 'max)))
    vec))


(defun tNFA--tags-copy (tags)
  ;; return a copy of TAGS table
  (let* ((len (length tags))
         (vec (make-vector len nil)))
    (dotimes (i len)
      (aset vec i (cons (car (aref tags i))
                        (cdr (aref tags i)))))
    vec))


(defmacro tNFA--tags-set (tags tag val)
  ;; set value of TAG in TAGS table to VAL
  `(setcar (aref ,tags ,tag) ,val))


(defmacro tNFA--tags-get (tags tag)
  ;; get value of TAG in TAGS table
  `(car (aref ,tags ,tag)))


(defmacro tNFA--tags-type (tags tag)
  ;; return tag type ('min or 'max)
  `(cdr (aref ,tags ,tag)))


(defun tNFA--tags< (val tag tags)
  ;; return non-nil if VAL takes precedence over the value of TAG in
  ;; TAGS table, nil otherwise
  (setq tag (aref tags tag))
  (or (and (eq (cdr tag) 'min)
           (< val (car tag)))
    ;;(and (eq (cdr tag) 'max)
           (> val (car tag));)
           ))


(defun tNFA--tags-to-groups (tags)
  ;; Convert TAGS table to a list of indices of group matches. The n'th
  ;; element of the list is a cons cell, whose car is the starting index
  ;; of the nth group and whose cdr is its end index. If a group didn't
  ;; match, the corresponding list element will be null."
  (let ((groups (make-list (/ (length tags) 2) nil))
        group-stack
        (grp 0))
    (dotimes (i (length tags))
      (if (eq (tNFA--tags-type tags i) 'max)
          (unless (= (tNFA--tags-get tags i) -1)
            (setf (nth (caar group-stack) groups)
                  (cons (cdr (pop group-stack))
                        (tNFA--tags-get tags i))))
        (unless (= (tNFA--tags-get tags i) -1)
          (push (cons grp (tNFA--tags-get tags i)) group-stack))
        (incf grp)))
    groups))




;;; ================================================================
;;;                        Regexp -> tNFA

;;;###autoload
(defun* tNFA-from-regexp (regexp &key (test 'eq))
  "Create a tagged NFA that recognizes the regular expression REGEXP.
The return value is the initial state of the tagged NFA.

REGEXP can be any sequence type (vector, list, or string); it
need not be an actual string. Special characters in REGEXP are
still just that: elements of the sequence that are characters
which have a special meaning in regexps.

The :test keyword argument specifies how to test whether two
individual elements of STRING are identical. The default is `eq'.

Only a subset of the full Emacs regular expression syntax is
supported. There is no support for regexp constructs that are
only meaningful for strings (character ranges and character
classes inside character alternatives, and syntax-related
backslash constructs). Back-references and non-greedy postfix
operators are not supported, so `?' after a postfix operator
loses its special meaning. Also, matches are always anchored, so
`$' and `^' lose their special meanings (use `.*' at the
beginning and end of the regexp to get an unanchored match)."

  ;; convert regexp to list, build NFA, and return initial state
  (declare (special NFA--state-id))
  (destructuring-bind (fragment num-tags min-tags max-tags regexp)
      (let ((NFA--state-id -1))
        (tNFA--from-regexp (append regexp nil) 0 '() '() 'top-level))
    (if regexp
        (error "Syntax error in regexp: missing \"(\"")
      (setf (tNFA--NFA-state-type (tNFA--fragment-final fragment))
            'match)
      (tNFA--DFA-state-create-initial
       (tNFA--epsilon-boundary
        (list
         (tNFA--state-create-initial
          (tNFA--fragment-initial fragment) num-tags min-tags max-tags))
        0)
       :test test)
      )))


(defmacro tNFA--regexp-postfix-p (regexp)
  ;; return t if next token in REGEXP is a postfix operator, nil
  ;; otherwise
  `(or (eq (car ,regexp) ?*)
       (eq (car ,regexp) ?+)
       (eq (car ,regexp) ??)
       (and (eq (car ,regexp) ?\\)
            (cdr ,regexp)
            (eq (cadr ,regexp) ?{))))


(defun tNFA--from-regexp (regexp num-tags min-tags max-tags
                                 &optional top-level shy-group)
  ;; Construct a tagged NFA fragment from REGEXP, up to first end-group
  ;; character or end of REGEXP. The TAGS arguments are used to pass the
  ;; tags created so far. A non-nil TOP-LEVEL indicates that REGEXP is
  ;; the complete regexp, so we're constructing the entire tNFA. A
  ;; non-nil SHY-GROUP indicates that we're constructing a shy subgroup
  ;; fragment. (Both optional arguments are only used for spotting
  ;; syntax errors in REGEXP.)
  ;;
  ;; Returns a list: (FRAGMENT NUM-TAGS MIN-TAGS MAX-TAGS
  ;; REGEXP). FRAGMENT is the constructed tNFA fragment, REGEXP is the
  ;; remaining, unused portion of the regexp, and the TAGS return values
  ;; give the tags created so far.

  (let* ((new (tNFA--NFA-state-create))
         (fragment-stack (list (tNFA--fragment-create new new)))
         fragment copy attach token type group-end-tag)

    (catch 'constructed
      (while t
        (setq regexp (tNFA--regexp-next-token regexp)
              type   (nth 0 regexp)
              token  (nth 1 regexp)
              regexp (nth 2 regexp))
        (setq fragment nil
              group-end-tag nil)

        ;; ----- construct new fragment -----
        (cond
         ;; syntax error: missing )
         ((and (null type) (not top-level))
          (error "Syntax error in regexp:\
 extra \"(\" or missing \")\""))

         ;; syntax error: extra )
         ((and (eq type 'shy-group-end) top-level)
          (error "Syntax error in regexp:\
 extra \")\" or missing \"(\""))

         ;; syntax error: ) ending a shy group
         ((and (eq type 'shy-group-end) (not shy-group))
          (error "Syntax error in regexp: \"(\" matched with \")?\""))

         ;; syntax error: )? ending a group
         ((and (eq type 'group-end) shy-group)
          (error "Syntax error in regexp: \"(?\" matched with \")\""))

         ;; syntax error: postfix operator not after atom
         ((eq type 'postfix)
          (error "Syntax error in regexp: unexpected \"%s\""
                 (char-to-string token)))


         ;; regexp atom: construct new literal fragment
         ((or (eq type 'literal) (eq type 'wildcard)
              (eq type 'char-alt) (eq type 'neg-char-alt))
          (setq new (tNFA--NFA-state-create
                     type token (tNFA--NFA-state-create))
                fragment (tNFA--fragment-create
                          new (tNFA--NFA-state-next new))))

         ;; shy subgroup start: recursively construct subgroup fragment
         ((eq type 'shy-group-start)
          (setq new (tNFA--from-regexp
                     regexp num-tags min-tags max-tags nil t)
                num-tags (nth 1 new)
                min-tags (nth 2 new)
                max-tags (nth 3 new)
                regexp   (nth 4 new)
                fragment (nth 0 new)))

         ;; subgroup start: add minimize tag to current fragment, and
         ;;                 recursively construct subgroup fragment
         ((eq type 'group-start)
          (setq new (tNFA--NFA-state-create))
          (setq fragment
                (tNFA--fragment-create
                 (tNFA--NFA-state-create-tag
                  (car (push (1- (incf num-tags)) min-tags))
                  new)
                 new))
          (tNFA--fragment-patch (car fragment-stack) fragment)
          ;; reserve next tag number for subgroup end tag
          (setq group-end-tag num-tags)
          (incf num-tags)
          ;; recursively construct subgroup fragment
          (setq new (tNFA--from-regexp
                     regexp num-tags min-tags max-tags)
                num-tags (nth 1 new)
                min-tags (nth 2 new)
                max-tags (nth 3 new)
                regexp   (nth 4 new)
                fragment (nth 0 new)))


         ;; end of regexp or subgroup: ...
         ((or (null type) (eq type 'shy-group-end) (eq type 'group-end))

          ;; if fragment-stack contains only one fragment, throw
          ;; fragment up to recursion level above
          (cond
           ((null (nth 1 fragment-stack))
            (throw 'constructed
                   (list (car fragment-stack)
                         num-tags min-tags max-tags regexp)))

           ;; if fragment-stack contains multiple alternation fragments,
           ;; attach them all together
           ;;
           ;;          .--fragment--.
           ;;         /              \
           ;;        /----fragment----\
           ;;       /                  \
           ;;   ---o------fragment------o--->
           ;;       \        .         /
           ;;        \       .        /
           ;;                .
           (t
            ;; create a new fragment containing start and end of
            ;; alternation
            (setq fragment
                  (tNFA--fragment-create
                   (tNFA--NFA-state-create-branch)
                   (tNFA--NFA-state-create)))
            ;; patch alternation fragments into new fragment
            (dolist (frag fragment-stack)
              (push (tNFA--fragment-initial frag)
                    (tNFA--NFA-state-next
                     (tNFA--fragment-initial fragment)))
              (setf (tNFA--NFA-state-count
                     (tNFA--fragment-initial frag))
                    (incf (tNFA--NFA-state-in-degree
                           (tNFA--fragment-initial frag))))
              (tNFA--NFA-state-make-epsilon (tNFA--fragment-final frag)
                                      (tNFA--fragment-final fragment)))
            ;; throw constructed fragment up to recursion level above
            (throw 'constructed
                   (list fragment num-tags min-tags max-tags regexp)))
           ))

         ;; | alternation: start new fragment
         ((eq type 'alternation)
          (setq new (tNFA--NFA-state-create))
          (push (tNFA--fragment-create new new) fragment-stack)))


        ;; ----- attach new fragment -----
        (when fragment
          ;; if next token is not a postfix operator, attach new
          ;; fragment onto end of current NFA fragment
          (if (not (tNFA--regexp-postfix-p regexp))
              (tNFA--fragment-patch (car fragment-stack) fragment)

            ;; if next token is a postfix operator, splice new fragment
            ;; into NFA as appropriate
            (when (eq type 'alternation)
              (error "Syntax error in regexp: unexpected \"%s\""
                     (char-to-string token)))
            (setq regexp (tNFA--regexp-next-token regexp)
                  type   (nth 0 regexp)
                  token  (nth 1 regexp)
                  regexp (nth 2 regexp))

            (while fragment
              (setq attach (tNFA--fragment-final (car fragment-stack)))
              (setq new (tNFA--NFA-state-create))
              (cond

               ;; * postfix = \{0,\}:
               ;;
               ;;    .--fragment--.
               ;;   /              \
               ;;   \        ______/
               ;;    \      /
               ;;  ---attach-----new---
               ;;
               ((and (eq (car token) 0) (null (cdr token)))
                (tNFA--NFA-state-make-branch
                 attach (list (tNFA--fragment-initial fragment) new))
                (tNFA--NFA-state-make-epsilon
                 (tNFA--fragment-final fragment) attach)
                (setf (tNFA--fragment-final (car fragment-stack)) new)
                (setq fragment nil))

               ;; + postfix = \{1,\}:
               ;;
               ;;      .----.
               ;;     /      \
               ;;    /        \
               ;;    \        /
               ;;  ---fragment-----new---
               ;;
               ((and (eq (car token) 1) (null (cdr token)))
                (tNFA--NFA-state-patch
                 attach (tNFA--fragment-initial fragment))
                (tNFA--NFA-state-make-branch
                 (tNFA--fragment-final fragment) (list attach new))
                (setf (tNFA--fragment-final (car fragment-stack)) new)
                (setq fragment nil))

               ;; \{0,n\} (note: ? postfix = \{0,1\}):
               ;;
               ;;            .--fragment--.
               ;;           /              \
               ;;  ---attach                new---
               ;;           \______________/
               ;;
               ((eq (car token) 0)
                ;; ? postfix = \{0,1\}: after this we're done
                (if (eq (cdr token) 1)
                    (setq copy nil)
                  (setq copy (tNFA--fragment-copy fragment)))
                ;; attach fragment
                (tNFA--NFA-state-make-branch
                 attach (list (tNFA--fragment-initial fragment) new))
                (tNFA--NFA-state-make-epsilon
                 (tNFA--fragment-final fragment) new)
                (setf (tNFA--fragment-final (car fragment-stack)) new)
                ;; prepare for next iteration
                (decf (cdr token))
                (setq fragment copy))

               ;; \{n,\} or \{n,m\}:
               ;;
               ;;  ---attach----fragment----new---
               ;;
               (t
                (setq copy (tNFA--fragment-copy fragment))
                (tNFA--fragment-patch (car fragment-stack) fragment)
                ;; prepare for next iteration
                (decf (car token))
                (when (cdr token) (decf (cdr token)))
                (if (eq (cdr token) 0)
                    (setq fragment nil)
                  (setq fragment copy)))
               )))


          ;; if ending a group, add a maximize tag to end
          (when group-end-tag
            (setq new (tNFA--NFA-state-create)
                  fragment (tNFA--fragment-create
                            (tNFA--NFA-state-create-tag
                             group-end-tag new)
                            new))
            (push group-end-tag max-tags)
            (tNFA--fragment-patch (car fragment-stack) fragment)))
        ))  ; end of infinite loop and catch
    ))



;; Note: hard-coding the parsing like this is ugly, though sufficient
;;       for our purposes. Perhaps it would be more elegant to implement
;;       this in terms of a proper parser...

(defun tNFA--regexp-next-token (regexp)
  ;; if regexp is empty, return null values for next token type, token
  ;; and remaining regexp
  (if (null regexp)
      (list nil nil nil)

    (let ((token (pop regexp))
          (type 'literal))  ; assume token is literal initially
      (cond

       ;; [: gobble up to closing ]
       ((eq token ?\[)
        ;; character alternatives are stored in lists
        (setq token '())
        (cond
         ;; gobble ] appearing straight after [
         ((eq (car regexp) ?\]) (push (pop regexp) token))
         ;; gobble ] appearing straight after [^
         ((and (eq (car regexp) ?^) (eq (nth 1 regexp) ?\]))
          (push (pop regexp) token)
          (push (pop regexp) token)))
        ;; gobble everything up to closing ]
        (while (not (eq (car regexp) ?\]))
          (push (pop regexp) token)
          (unless regexp
            (error "Syntax error in regexp: missing \"]\"")))
        (pop regexp)  ; dump closing ]
        (if (not (eq (car (last token)) ?^))
            (setq type 'char-alt)
          (setq type 'neg-char-alt)
          (setq token (butlast token))))

       ;; ]: syntax error (always gobbled when parsing [)
       ((eq token ?\])
        (error "Syntax error in regexp: missing \"[\""))

       ;; . * + ?: set appropriate type
       ((eq token ?*) (setq type 'postfix token (cons 0 nil)))
       ((eq token ?+) (setq type 'postfix token (cons 1 nil)))
       ((eq token ??) (setq type 'postfix token (cons 0 1)))
       ((eq token ?.) (setq type 'wildcard))

       ;; \: look at next character
       ((eq token ?\\)
        (unless (setq token (pop regexp))
          (error "Syntax error in regexp:\
 missing character after \"\\\""))
        (cond
         ;; |: alternation
         ((eq token ?|) (setq type 'alternation))
         ;; \(?: shy group start
         ((and (eq token ?\() (eq (car regexp) ??))
          (setq type 'shy-group-start)
          (pop regexp))
         ;; \)?: shy group end
         ((and (eq token ?\)) (eq (car regexp) ??))
          (setq type 'shy-group-end)
          (pop regexp))
         ;; \(: group start
         ((eq token ?\() (setq type 'group-start))
         ;; \): group end
         ((eq token ?\)) (setq type 'group-end))

         ;; \{: postfix repetition operator
         ((eq token ?{)
          (setq type 'postfix token (cons nil nil))
          ;; extract first number from repetition operator
          (while (if (null regexp)
                     (error "Syntax error in regexp:\
 malformed \\{...\\}")
                   (not (or (eq (car regexp) ?,)
                            (eq (car regexp) ?\\))))
            (setcar token
                    (concat (car token) (char-to-string (pop regexp)))))
          (if (null (car token))
              (setcar token 0)
            (unless (string-match "[0-9]+" (car token))
              (error "Syntax error in regexp: malformed \\{...\\}"))
            (setcar token (string-to-number (car token))))
          (cond
           ;; if next character is "\", we expect "}" to follow
           ((eq (car regexp) ?\\)
            (pop regexp)
            (unless (eq (car regexp) ?})
              (error "Syntax error in regexp: expected \"}\""))
            (pop regexp)
            (unless (car token)
              (error "Syntax error in regexp: malformed \\{...\\}"))
            (setcdr token (car token)))
           ;; if next character is ",", we expect a second number to
           ;; follow
           ((eq (car regexp) ?,)
            (pop regexp)
            (while (if (null regexp)
                       (error "Syntax error in regexp:\
 malformed \\{...\\}")
                     (not (eq (car regexp) ?\\)))
              (setcdr token
                      (concat (cdr token)
                              (char-to-string (pop regexp)))))
            (unless (null (cdr token))
              (unless (string-match "[0-9]+" (cdr token))
                (error "Syntax error in regexp: malformed \\{...\\}"))
              (setcdr token (string-to-number (cdr token))))
            (pop regexp)
            (unless (eq (car regexp) ?})
              (error "Syntax error in regexp: expected \"}\""))
            (pop regexp))))
         ))
       )

      ;; return first token type, token, and remaining regexp
      (list type token regexp))))



;;; ================================================================
;;;                     tNFA evolution

(defun tNFA-next-state (tNFA chr pos)
  "Evolve tNFA according to CHR, which corresponds to position
POS in a string."
  (let (elem state)
    ;; if there is a transition for character CHR...
    (cond
     ((setq elem (tNFA--assoc chr (tNFA--DFA-state-transitions tNFA)
                               :test (tNFA--DFA-state-test tNFA)))
      ;; if next state has not already been computed, do so
      (unless (tNFA--DFA-state-p (setq state (cdr elem)))
        (setq state (tNFA--DFA-next-state tNFA chr pos nil))
        (setcdr elem state)))

     ;; if there's a wildcard transition...
     ((setq state (tNFA--DFA-state-wildcard tNFA))
      ;; if next state has not already been computed, do so
      (unless (tNFA--DFA-state-p state)
        (setq state (tNFA--DFA-next-state tNFA chr pos t))
        (setf (tNFA--DFA-state-wildcard tNFA) state))))
    state))



(defun tNFA--DFA-next-state (DFA-state chr pos wildcard)
  (let (state-list state)
    ;; add all states reached by a CHR transition from DFA-STATE to
    ;; state list
    (if wildcard
        (dolist (state (tNFA--DFA-state-list DFA-state))
          (when (or (eq (tNFA--state-type state) 'wildcard)
                    (and (eq (tNFA--state-type state) 'neg-char-alt)
                         (not (memq chr (tNFA--state-label state)))))
            (push (tNFA--state-create
                   (tNFA--state-next state)
                   (tNFA--tags-copy (tNFA--state-tags state)))
                  state-list)))
      (dolist (state (tNFA--DFA-state-list DFA-state))
        (when (or (and (eq (tNFA--state-type state) 'literal)
                       (eq chr (tNFA--state-label state)))
                  (and (eq (tNFA--state-type state) 'char-alt)
                       (memq chr (tNFA--state-label state)))
                  (and (eq (tNFA--state-type state) 'neg-char-alt)
                       (not (memq chr (tNFA--state-label state))))
                  (eq (tNFA--state-type state) 'wildcard))
          (push (tNFA--state-create
                 (tNFA--state-next state)
                 (tNFA--tags-copy (tNFA--state-tags state)))
                state-list))))

    ;; if state list is empty, return empty, failure DFA state
    (when state-list
      ;; otherwise, construct new DFA state and add it to the pool if
      ;; it's not already there
      (setq state-list (tNFA--epsilon-boundary state-list (1+ pos)))
      (setq state
            (or (gethash state-list (tNFA--DFA-state-pool DFA-state))
                (tNFA--DFA-state-create
                 state-list
                 (tNFA--DFA-state-pool DFA-state)
                 :test (tNFA--DFA-state-test DFA-state))))
      ;; return next state
      state)))



(defun tNFA--epsilon-boundary (state-set pos)
  ;; Return the tagged epsilon-boundary of the NFA states listed in
  ;; STATE-SET, that is the set of all states that can be reached via
  ;; epsilon transitions from some state in STATE-SET (not including
  ;; states in STATE-SET itself).
  (let ((queue (queue-create))
        (result '())
        (reset '())
        state next tags)
    ;; temporarily link the NFA states to their corresponding tNFA
    ;; states, and add them to the queue
    (dolist (t-state state-set)
      (setf state (tNFA--state-NFA-state t-state)
            (tNFA--NFA-state-tNFA-state state) t-state)
      (push state reset)
      (queue-enqueue queue state))

    (while (setq state (queue-dequeue queue))
      (cond
       ;; branch or epsilon: add next states as necessary, copying tags
       ;; across
       ((or (eq (tNFA--NFA-state-type state) 'branch)
            (eq (tNFA--NFA-state-type state) 'epsilon))
        (dolist (next (if (eq (tNFA--NFA-state-type state) 'epsilon)
                          (list (tNFA--NFA-state-next state))
                        (tNFA--NFA-state-next state)))
          (unless (tNFA--NFA-state-tNFA-state next)
            (setf (tNFA--NFA-state-tNFA-state next)
                  (tNFA--state-create
                   next (tNFA--tags-copy (tNFA--NFA-state-tags state))))
            (push next reset)
            ;; if next state hasn't already been seen in-degree times,
            ;; add it to the end of the queue
            (if (/= (decf (tNFA--NFA-state-count next)) 0)
                (queue-enqueue queue next)
              ;; if it has now been seen in-degree times, reset count
              ;; and add it back to the front of the queue
              (setf (tNFA--NFA-state-count next)
                    (tNFA--NFA-state-in-degree next))
              (queue-prepend queue next)))))

       ;; tag: add next state if necessary, updating tags if necessary
       ((eq (tNFA--NFA-state-type state) 'tag)
        (setq next (tNFA--NFA-state-next state))
        ;; if next state is not already in results list, or it is
        ;; already in results but new tag value takes precedence...
        (when (or (not (tNFA--NFA-state-tNFA-state next))
                  (tNFA--tags< pos (tNFA--NFA-state-tag state)
                              (tNFA--NFA-state-tags next)))
          ;; if next state is already in results, update tag value
          (if (tNFA--NFA-state-tNFA-state next)
              (tNFA--tags-set (tNFA--NFA-state-tags next)
                             (tNFA--NFA-state-tag state) pos)
            ;; if state is not already in results, copy tags, updating
            ;; tag value, and add next state to results list
            (setq tags (tNFA--tags-copy (tNFA--NFA-state-tags state)))
            (tNFA--tags-set tags (tNFA--NFA-state-tag state) pos)
            (setf (tNFA--NFA-state-tNFA-state next)
                  (tNFA--state-create next tags))
            (push next reset))
          ;; if next state hasn't already been seen in-degree times, add
          ;; it to the end of the queue
          (if (/= (decf (tNFA--NFA-state-count next)) 0)
              (queue-enqueue queue next)
            ;; if it has now been seen in-degree times, reset count and
            ;; add it back to the front of the queue
            (setf (tNFA--NFA-state-count next)
                  (tNFA--NFA-state-in-degree next))
            (queue-prepend queue next))))

       ;; anything else is a non-epsilon-transition state, so add it to
       ;; result
       (t (push (tNFA--NFA-state-tNFA-state state) result))
       ))

    ;; reset temporary NFA state link and count
    (dolist (state reset)
      (setf (tNFA--NFA-state-tNFA-state state) nil
            (tNFA--NFA-state-count state)
              (tNFA--NFA-state-in-degree state)))
    ;; sort result states
    (sort result
          (lambda (a b) (< (tNFA--state-id a) (tNFA--state-id b))))
    ))



;;; ================================================================
;;;                       tNFA matching

;;;###autoload
(defun* tNFA-regexp-match (regexp string &key (test 'eq))
  "Return non-nil if STRING matches REGEXP, nil otherwise.
Sets the match data if there was a match; see `match-beginning',
`match-end' and `match-string'.

REGEXP and STRING can be any sequence type (vector, list, or
string); they need not be actual strings. Special characters in
REGEXP are still just that: elements of the sequence that are
characters which have a special meaning in regexps.

The :test keyword argument specifies how to test whether two
individual elements of STRING are identical. The default is `eq'.

Only a subset of the full Emacs regular expression syntax is
supported. There is no support for regexp constructs that are
only meaningful for strings (character ranges and character
classes inside character alternatives, and syntax-related
backslash constructs). Back-references and non-greedy postfix
operators are not supported, so `?' after a postfix operator
loses its special meaning. Also, matches are always anchored, so
`$' and `^' lose their special meanings (use `.*' at the
beginning and end of the regexp to get an unanchored match)."

  (let ((tNFA (tNFA-from-regexp regexp :test test))
        (i -1) tags match-data group-stack (grp 0))

    ;; evolve tNFA according to characters of STRING
    (catch 'fail
      (dolist (chr (append string nil))
        (unless (setq tNFA (tNFA-next-state tNFA chr (incf i)))
          (throw 'fail nil)))

      ;; if REGEXP matched...
      (when (setq tags (tNFA--DFA-state-match tNFA))
        (setq match-data (make-list (+ (length tags) 2) nil))
        ;; set match data
        (setf (nth 0 match-data) 0
              (nth 1 match-data) (length string))
        ;; set group match data if there were any groups
        (dotimes (i (length tags))
          (if (eq (tNFA--tags-type tags i) 'max)
              (unless (= (tNFA--tags-get tags i) -1)
                (setf (nth (1+ (* 2 (pop group-stack))) match-data)
                      (tNFA--tags-get tags i)))
            (incf grp)
            (unless (= (tNFA--tags-get tags i) -1)
              (push grp group-stack)
              (setf (nth (* 2 grp) match-data)
                    (tNFA--tags-get tags i)))))
        (set-match-data match-data)
        tags))))


(defun tNFA-group-data (tNFA)
  "Return the group match data associated with a tNFA state."
  (tNFA--tags-to-groups (tNFA--DFA-state-match tNFA)))



(provide 'tNFA)

;;; tNFA.el ends here