root/trunk/tdtd/tdtd-make-regexp.el

;;; tdtd-make-regexp.el --- generate efficient regexps to match strings.

;; Copyright (C) 1994, 1995 Simon Marshall.

;; Author: Simon Marshall <simon@gnu.ai.mit.edu>
;; Keywords: strings, regexps
;; Version: 1.02

;; LCD Archive Entry:
;; make-regexp|Simon Marshall|simon@gnu.ai.mit.edu|
;; Generate efficient regexps to match strings.|
;; 11-Jul-1995|1.02|~/functions/make-regexp.el.gz|

;; The archive is archive.cis.ohio-state.edu in /pub/gnu/emacs/elisp-archive.

;;; This file is not part of GNU Emacs.

;;; This program 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 2, or (at your option)
;;; any later version.

;;; This program 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; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; Purpose:
;;
;; To make efficient regexps from lists of strings.

;; For example:
;;
;; (let ((strings '("cond" "if" "while" "let\\*?" "prog1" "prog2" "progn"
;;                  "catch" "throw" "save-restriction" "save-excursion"
;;                  "save-window-excursion" "save-match-data"
;;                  "unwind-protect" "condition-case" "track-mouse")))
;;   (concat "(" (tdtd-make-regexp strings t)))
;;
;;      => "(\\(c\\(atch\\|ond\\(\\|ition-case\\)\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(excursion\\|match-data\\|restriction\\|window-excursion\\)\\|t\\(hrow\\|rack-mouse\\)\\|unwind-protect\\|while\\)"
;;
;; To search for the above regexp takes about 70% of the time as for the simple
;; (concat "(\\(" (mapconcat 'identity strings "\\|") "\\)") regexp.
;;
;; Obviously, the more the similarity between strings, the faster the regexp:
;;
;; (tdtd-make-regexp '("abort" "abs" "accept" "access" "array" "begin" "body" "case"
;;                "constant" "declare" "delay" "delta" "digits" "else" "elsif"
;;                "entry" "exception" "exit" "function"  "generic" "goto" "if"
;;                "others" "limited" "loop" "mod" "new" "null" "out" "subtype"
;;                "package" "pragma" "private" "procedure" "raise" "range"
;;                "record" "rem" "renames" "return" "reverse" "select"
;;                "separate" "task" "terminate" "then" "type" "when" "while"
;;                "with" "xor"))
;;
;;     => "a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|rray\\)\\|b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\)\\|e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|function\\|g\\(eneric\\|oto\\)\\|if\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ew\\|ull\\)\\|o\\(thers\\|ut\\)\\|p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor"
;;
;; To search for the above regexp takes less than 60% of the time of the simple
;; mapconcat equivalent.
;;
;; But even small regexps may be worth it:
;;
;; (tdtd-make-regexp '("and" "at" "do" "end" "for" "in" "is" "not" "of" "or" "use"))
;;     => "a\\(nd\\|t\\)\\|do\\|end\\|for\\|i[ns]\\|not\\|o[fr]\\|use"
;;
;; as this is 10% faster than the mapconcat equivalent.

;; Installation:
;; 
;; (autoload 'tdtd-make-regexp "tdtd-make-regexp"
;;   "Return a regexp to match a string item in STRINGS.")
;;
;; (autoload 'tdtd-make-regexps "tdtd-make-regexp"
;;   "Return a regexp to REGEXPS.")
;;
;; Since these functions were written to produce efficient regexps, not regexps
;; efficiently, it is probably not a good idea to in-line too many calls in
;; your code, unless you use the following neat trick with `eval-when-compile':
;;
;; (defvar definition-regexp
;;   (let ((regexp (eval-when-compile
;;                   (tdtd-make-regexp '("defun" "defsubst" "defmacro" "defalias"
;;                                  "defvar" "defconst" "defadvice") t))))
;;     (concat "^(" regexp)))
;;
;; The `byte-compile' code will be as if you had defined the variable thus:
;;
;; (defvar definition-regexp
;;   "^(\\(def\\(a\\(dvice\\|lias\\)\\|const\\|macro\\|subst\\|un\\|var\\)\\)")

;; Feedback:
;;
;; Originally written for font-lock, from an idea from Stig's hl319.
;; Please don't tell me that it doesn't produce optimal regexps; I know that
;; already.  But (ideas or) code to improve things (are) is welcome.  Please
;; test your code and tell me the speed up in searching an appropriate buffer.
;;
;; Please send me bug reports, bug fixes, and extensions, etc.
;; Simon Marshall <simon@gnu.ai.mit.edu>

;; History:
;;
;; 1.00--1.01:
;; - Made `make-regexp' take `lax' to force top-level parentheses.
;; - Fixed `make-regexps' for MATCH bug and new `font-lock-keywords'.
;; - Added `unfontify' to user timing functions.
;; 1.01--1.02:
;; - Made `make-regexp' `let' a big `max-lisp-eval-depth'.

;; The basic idea is to find the shortest common non-"" prefix each time, and
;; squirrel it out.  If there is no such prefix, we divide the list into two so
;; that (at least) one half will have at least a one-character common prefix.

;; In addition, we (a) delay the addition of () parenthesis as long as possible
;; (until we're sure we need them), and (b) try to squirrel out one-character
;; sequences (so we can use [] rather than ()).

(defun tdtd-make-regexp (strings &optional paren lax)
  "Return a regexp to match a string item in STRINGS.
If optional PAREN non-nil, output regexp parentheses around returned regexp.
If optional LAX non-nil, don't output parentheses if it doesn't require them.
Merges keywords to avoid backtracking in Emacs' regexp matcher."
  (let* ((max-lisp-eval-depth (* 1024 1024))
         (strings (let ((l strings))    ; Paranoia---make strings unique!
                    (while l (setq l (setcdr l (delete (car l) (cdr l)))))
                    (sort strings 'string-lessp)))
         (open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" ""))
         (open-lax (if lax "" open-paren)) (close-lax (if lax "" close-paren))
         (completion-ignore-case nil))
    (cond
     ;; If there's only one string, just return it.
     ((= (length strings) 1)
      (concat open-lax (car strings) close-lax))
     ;; If there's an empty string, pull it out.
     ((string= (car strings) "")
      (if (and (= (length strings) 2) (= (length (nth 1 strings)) 1))
          (concat open-lax (nth 1 strings) "?" close-lax)
        (concat open-paren "\\|" (tdtd-make-regexp (cdr strings)) close-paren)))
     ;; If there are only one-character strings, make a [] list instead.
     ((= (length strings) (apply '+ (mapcar 'length strings)))
      (concat open-lax "[" (mapconcat 'identity strings "") "]" close-lax))
     (t
      ;; We have a list of strings.  Is there a common prefix?
      (let ((prefix (try-completion "" (mapcar 'list strings))))
        (if (> (length prefix) 0)
            ;; Common prefix!  Squirrel it out and recurse with the suffixes.
            (let* ((len (length prefix))
                   (sufs (mapcar '(lambda (str) (substring str len)) strings)))
              (concat open-paren prefix (tdtd-make-regexp sufs t t) close-paren))
          ;; No common prefix.  Is there a one-character sequence?
          (let ((letters (let ((completion-regexp-list '("^.$")))
                           (all-completions "" (mapcar 'list strings)))))
            (if (> (length letters) 1)
                ;; Do the one-character sequences, then recurse on the rest.
                (let ((rest (let ((completion-regexp-list '("^..+$")))
                              (all-completions "" (mapcar 'list strings)))))
                  (concat open-paren
                          (tdtd-make-regexp letters) "\\|" (tdtd-make-regexp rest)
                          close-paren))
              ;; No one-character sequence, so divide the list into two by
              ;; dividing into those that start with a particular letter, and
              ;; those that do not.
              (let* ((char (substring (car strings) 0 1))
                     (half1 (all-completions char (mapcar 'list strings)))
                     (half2 (nthcdr (length half1) strings)))
                (concat open-paren
                        (tdtd-make-regexp half1) "\\|" (tdtd-make-regexp half2)
                        close-paren))))))))))

;; This stuff is realy for font-lock...

;; Ahhh, the wonders of lisp...
(defun regexp-span (regexp &optional start)
  "Return the span or depth of REGEXP.
This means the number of \"\\\\(...\\\\)\" pairs in REGEXP, optionally from START."
  (let ((match (string-match (regexp-quote "\\(") regexp (or start 0))))
    (if (not match) 0 (1+ (regexp-span regexp (match-end 0))))))

;; The basic idea is to concat the regexps together, keeping count of the span
;; of the regexps so that we can get the correct match for hilighting.
(defun tdtd-make-regexps (&rest regexps)
  "Return a regexp to match REGEXPS
Each item of REGEXPS should be of the form:

 STRING                                 ; A STRING to be used literally.
 (STRING MATCH FACE DATA)               ; Match STRING at depth MATCH with FACE
                                        ; and highlight according to DATA.
 (STRINGS FACE DATA)                    ; STRINGS is a list of strings FACE is
                                        ; to highlight according to DATA.

Returns a list of the form:

 (REGEXP (MATCH FACE DATA) ...)

For example:

 (tdtd-make-regexps \"^(\"
               '((\"defun\" \"defalias\" \"defsubst\" \"defadvice\") keyword)
               \"[ \t]*\"
               '(\"\\\\([a-zA-Z-]+\\\\)?\" 1 function-name nil t))

     =>

 (\"^(\\\\(def\\\\(a\\\\(dvice\\\\|lias\\\\)\\\\|subst\\\\|un\\\\)\\\\)[        ]*\\\\([a-zA-Z-]+\\\\)?\"
  (1 keyword) (4 function-name nil t))

Uses `tdtd-make-regexp' to make efficient regexps."
  (let ((regexp "") (data ()))
    (while regexps
      (cond ((stringp (car regexps))
             (setq regexp (concat regexp (car regexps))))
            ((stringp (nth 0 (car regexps)))
             (setq data (cons (cons (+ (regexp-span regexp)
                                       (nth 1 (car regexps)))
                                    (nthcdr 2 (car regexps)))
                              data)
                   regexp (concat regexp (nth 0 (car regexps)))))
            (t
             (setq data (cons (cons (1+ (regexp-span regexp))
                                    (cdr (car regexps)))
                              data)
                   regexp (concat regexp (tdtd-make-regexp (nth 0 (car regexps))
                                                      t)))))
      (setq regexps (cdr regexps)))
    (cons regexp (nreverse data))))

;; Crude-rude timing...

(defsubst time-seconds (&optional time)
  "Return the TIME in seconds, or the current time if not given.
TIME should be the same format as produced by `current-time'."
  (let ((time (or time (current-time))))
    (+ (* (nth 0 time) 65536.0) (nth 1 time) (/ (nth 2 time) 1000000.0))))

(defsubst time-since (time)
  "Return the time in seconds since TIME.
TIME should be the value of `current-time' or `time-seconds'."
  (- (time-seconds) (if (floatp time) time (time-seconds time))))

(defun time-function (func &rest args)
  "Return the time in seconds taken to execute FUNC with ARGS.
Returned is actually the cons pair (func-value . time)."
  (garbage-collect)
  (let ((start (time-seconds)))
    (cons (apply func args) (time-since start))))

(defun time-regexps (regexps &optional buffer unfontify)
  "Return corresponding list of times to fontify using REGEXPS.
Fontify using BUFFER, if non-nil, and UNFONTIFY first, if non-nil."
  (save-excursion
    (and buffer (set-buffer buffer))
    (let ((beg (point-min)) (end (point-max)))
      (and unfontify (font-lock-unfontify-region beg end))
      (mapcar (function (lambda (regexp)
               (let ((font-lock-keywords (list regexp)))
                 (cons (cdr (time-function 'font-lock-hack-keywords beg end))
                       regexp))))
              regexps))))

(defun sort-font-lock-regexps (regexps &optional buffer unfontify)
  "Return sorted times to fontify syntactically and using REGEXPS.
UNFONTIFY first, if non-nil."
  (let ((regexp-time (time-regexps regexps buffer unfontify)))
    (cons (list (apply '+ (mapcar 'car regexp-time)) 'regexps)
          (nreverse (sort regexp-time 'car-less-than-car)))))

(defun time-fontification (&optional buffer unfontify)
  "Return time to fontify syntactically.
UNFONTIFY first, if non-nil."
  (save-excursion
    (and buffer (set-buffer buffer))
    (let ((beg (point-min)) (end (point-max)))
      (and unfontify (font-lock-unfontify-region beg end))
      (cdr (time-function 'font-lock-fontify-region beg end)))))

(defun sort-font-lock-fontification (regexps &optional buffer unfontify)
  "Return sorted times to fontify syntactically and using REGEXPS.
UNFONTIFY first, if non-nil."
  (let ((syntactic-time (time-fontification buffer unfontify))
        (regexp-time (time-regexps regexps buffer)))
    (nreverse
     (sort (append (list (list syntactic-time 'syntactic)
                         (list (apply '+ (mapcar 'car regexp-time)) 'regexps))
                   regexp-time)
           'car-less-than-car))))

;;; tdtd-make-regexp.el ends here