1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PU: FIND.SL
4% Description:  Start of recognition and search OBLIST functions
5% Author:       M. L. Griss
6% Created:
7% Modified:     05-Dec-83 17:32:05 (Nancy Kendzierski)
8% Package:      Utilities
9% Status:       Open Source: BSD License
10%
11% (c) Copyright 1982, University of Utah
12%
13% Redistribution and use in source and binary forms, with or without
14% modification, are permitted provided that the following conditions are met:
15%
16%    * Redistributions of source code must retain the relevant copyright
17%      notice, this list of conditions and the following disclaimer.
18%    * Redistributions in binary form must reproduce the above copyright
19%      notice, this list of conditions and the following disclaimer in the
20%      documentation and/or other materials provided with the distribution.
21%
22% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
24% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
25% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
26% CONTRIBUTORS
27% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
28% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
29% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
30% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
31% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
32% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33% POSSIBILITY OF SUCH DAMAGE.
34%
35%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
36%
37% Revisions:
38%
39% 05-Dec-83 17:32:05 (Nancy Kendzierski)
40%   Added contents of .BUILD file.
41% 02-Dec-83 18:02:16 (Nancy Kendzierski)
42%   Translated from Rlisp to Lisp.
43% 30 Dec 1982, MLG
44%   Move IMPORTS etc to BUILD file
45%
46%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
47
48(imports '(gsort))
49
50(fluid '(collectid!* teststring!*))
51
52(de findprefix (teststring!*)
53  %. Scan ObLIST for prefix
54  (prog nil
55        (setq collectid!* nil)
56        (when (idp teststring!*)
57          (setq teststring!* (id2string teststring!*)))
58        (unless (stringp teststring!*)
59          (stderror "Expect String or ID in FindPrefix"))
60        (mapobl (function findprefix1))
61        (return (idsort collectid!*))))
62
63(de findprefix1 (x)
64  (when (isprefixstring teststring!* (id2string x))
65    (setq collectid!* (cons x collectid!*))))
66
67(de findsuffix (teststring!*)
68  %. Scan ObLIST for prefix
69  (prog nil
70        (setq collectid!* nil)
71        (when (idp teststring!*)
72          (setq teststring!* (id2string teststring!*)))
73        (unless (stringp teststring!*)
74          (stderror "Expect String or ID in FindPrefix"))
75        (mapobl (function findsuffix1))
76        (return (idsort collectid!*))))
77
78(de findsuffix1 (x)
79  (when (issuffixstring teststring!* (id2string x))
80    (setq collectid!* (cons x collectid!*))))
81
82(de isprefixstring (s1 s2)
83  %. test if exact string prefix
84  (prog (l1 l2 l)
85        (setq l1 (size s1))
86        (setq l2 (size s2))
87        (setq l 0)
88        (when (greaterp l1 l2)
89          (return nil))
90   loop
91        (unless (eq (indx s1 l) (indx s2 l))
92          (return nil))
93        (when (greaterp (setq l (add1 l)) l1)
94          (return t))
95        (go loop)))
96
97(de issuffixstring (s1 s2)
98  %. test if exact string prefix
99  (prog (l1 l2 l)
100        (setq l1 (size s1))
101        (setq l2 (size s2))
102        (when (greaterp l1 l2)
103          (return nil))
104   loop
105        (unless (eq (indx s1 l1) (indx s2 l2))
106          (return nil))
107        (when (leq l1 0)
108          (return t))
109        (setq l1 (difference l1 1))
110        (setq l2 (difference l2 1))
111        (go loop)))
112
113% More extensive String matcher
114(de stringmatch (p s)
115  (stringmatch1 p 0 (size p) s 0 (size s)))
116
117(de stringmatch1 (p p1 p2 s s1 s2)
118  (prog (c)
119   l1
120        % test Range
121        (cond ((greaterp p1 p2) (return (if (greaterp s1 s2)
122                                   t
123                                   nil)))
124              ((greaterp s1 s2) (return nil)))
125        % test if % something
126        (when (eq (setq c (indx p p1)) (char !%))
127          (go l3))
128   l2
129        % exact match
130        (when (eq c (indx s s1))
131          (setq p1 (plus p1 1))
132          (setq s1 (plus s1 1))
133          (go l1))
134        (return nil)
135   l3
136        % special cases
137        (setq p1 (plus p1 1))
138        (when (greaterp p1 p2)
139          (return (stderror "pattern ran out in % case of StringMatch")))
140        (setq c (indx p p1))
141        (when (eq c (char !%))
142          (go l2))
143        (when (eq c (char !?))
144          (setq p1 (plus p1 1))
145          (setq s1 (plus s1 1))
146          (go l1))
147        (cond ((eq c (char !*)) % 0 or more vs 1 or more
148               (return (progn (while (and
149                                      (not
150                                       (setq c
151                                        (stringmatch1 p (plus p1 1) p2 s
152                                         s1 s2)))
153                                      (leq s1 s2))
154                                (setq s1 (plus s1 1)))
155                              c))))
156        (return (stderror
157                 (bldmsg " %% %r not known in StringMatch" (int2id c))))))
158
159(de find (teststring!*)
160  %. Scan ObLIST for prefix
161  (prog nil
162        (setq collectid!* nil)
163        (when (idp teststring!*)
164          (setq teststring!* (id2string teststring!*)))
165        (unless (stringp teststring!*)
166          (stderror "Expect String or ID in FindPrefix"))
167        (mapobl (function findstringmatch))
168        (return (idsort collectid!*))))
169
170(de findstringmatch (x)
171  (when (stringmatch teststring!* (id2string x))
172    (setq collectid!* (cons x collectid!*))))
173
174