Import GNU Enscript version 1.6.4
[enscript.git] / states / enscript.el
1 ;;
2 ;; Emacs help commands for enscript.
3 ;; Copyright (c) 1997 Markku Rossi.
4 ;; Author: Markku Rossi <mtr@iki.fi>
5 ;;
6
7 ;;
8 ;; This file is part of GNU enscript.
9 ;;
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14 ;;
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19 ;;
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; see the file COPYING.  If not, write to
22 ;; the Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24 ;;
25
26 ;/* Keywords:
27 ;   (build-re '(auto break case char const continue default do double else
28 ;               enum extern float for goto if int long register return
29 ;               short signed sizeof static struct switch typedef union
30 ;               unsigned void volatile while))
31 ;*/
32
33 (defun fetch-first-chars (lst)
34   "Fetch the initial character of list LST of strings."
35   (let ((result '())
36         (str ""))
37     (mapcar
38      (lambda (str)
39        (let ((ch (string-to-char str)))
40          (if (not (member ch result))
41              (setq result (cons ch result)))))
42      lst)
43     (sort result (function <))))
44
45 (defun fetch-with-prefix (prefix lst)
46   "Fetch the list items from list LST with start with PREFIX.  The fetched
47 items are modified so that the prefix is removed from strings."
48   (let ((result '())
49         (prefix-len (length prefix)))
50     (mapcar
51      (lambda (str)
52        (if (and (>= (length str) prefix-len)
53                 (string= prefix (substring str 0 prefix-len)))
54            (setq result (cons (substring str prefix-len) result))))
55      lst)
56     result))
57
58 (defun build-tree (lst)
59   "Build a regular expressions tree from list LST of words to match."
60   (mapcar
61    (lambda (prefix)
62      (if (= prefix 0)
63          ""
64        (setq prefix (char-to-string prefix))
65        (let ((result (fetch-with-prefix prefix lst)))
66          (if (= (length result) 1)
67              (concat prefix (car result))
68            (let ((rest (build-tree result)))
69              (if (and (= (length rest) 1) (listp (car rest)))
70                  (cons (concat prefix (car (car rest))) (cdr (car rest)))
71                (cons prefix rest)))))))
72    (fetch-first-chars lst)))
73
74 (defun join (list glue result)
75   (if (stringp list)
76       list
77     (if (= (length list) 1)
78         (concat result (car list))
79       (join (cdr list) glue (concat result (car list) glue)))))
80
81 (defun join-column (list glue result column pos)
82   (if (and (> (+ pos (length (car list)) (length glue)) column) (> pos 0))
83       (let ((len (length result))
84             (gluelen (length glue)))
85         (join-column list glue
86                      (concat (substring result 0 (- len gluelen)) "\\\n" glue)
87                      column 0))
88     (if (= (length list) 1)
89         (concat result (car list))
90       (join-column (cdr list) glue (concat result (car list) glue) column
91                    (+ pos (length (car list)) (length glue))))))
92
93 (defun join-tree (tree case-insensitive)
94   "Join regular expression tree TREE to a string.  Argument CASE-INSENSITIVE
95 specifies whatever the generated expression matches its words case
96 insensitively or not."
97   (join-column
98    (mapcar
99     (lambda (item)
100       (if (stringp item)
101           (if case-insensitive
102               (make-case-insensitive-regexp item)
103             item)
104         (concat (if case-insensitive
105                     (make-case-insensitive-regexp (car item))
106                   (car item))
107                 "("
108                 (join (join-tree (cdr item) case-insensitive) "|" "") ")")))
109     tree)
110    "|" "" 70 0))
111
112 (defun make-case-insensitive-regexp (string)
113   (let ((result ""))
114     (while (not (string= string ""))
115       (let* ((ch (string-to-char string))
116              (uch (upcase ch)))
117         (if (= ch uch)
118             (progn
119               (setq string (substring string 1))
120               (setq result (concat result (char-to-string ch))))
121           (setq string (substring string 1))
122           (setq result (concat result "[" (char-to-string ch)
123                                (char-to-string uch) "]")))))
124     result))
125
126 (defun build-re (words &optional case-insensitive)
127   "Build an optimized regular expression from list WORDS which can contain
128 symbols and strings.  Optional second argument CASE-INSENSITIVE specifies
129 whatever the created regular expression should match its keywords case
130 insensitively or not.  The default is case sensitive matching.  If the
131 function is enclosed in C-comments, it inserts the generated regular expression
132 after the closing \"*/\" sequence, otherwise it returns regular expression
133 as a string."
134   (save-excursion
135     (let ((re (concat "/\\b("
136                       (join-tree (build-tree (mapcar (lambda (item)
137                                                        (if (stringp item)
138                                                            item
139                                                          (symbol-name item)))
140                                                      words))
141                                  case-insensitive)
142                       ")\\b/ {")))
143       (if (search-forward "*/" nil t)
144           (progn
145             (open-line 2)
146             (next-line 1)
147             (insert "  " re))
148         re))))