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