1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34DEFPARAMETER($wildCard, char "*")
35
36maskMatch?(mask,subject) ==
37  null mask => true
38  if null STRINGP subject then subject := PNAME subject
39  or/[match?(pattern,subject) for pattern in mask]
40
41substring?(part, whole, startpos) ==
42--This function should be replaced by STRING<
43  np := SIZE part
44  nw := SIZE whole
45  np > nw - startpos => false
46  and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw))
47      for ip in 0..np-1 for iw in startpos.. ]
48
49anySubstring?(part,whole,startpos) ==
50  np := SIZE part
51  nw := SIZE whole
52  or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw))
53       for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k
54
55charPosition(c,t,startpos) ==
56  n := SIZE t
57  startpos < 0 or startpos > n => n
58  k:= startpos
59  for i in startpos .. n-1 repeat
60    c = ELT(t,i) => return nil
61    k := k+1
62  k
63
64rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost)
65  k := startpos
66  for i in startpos..0 by -1 while c ~= ELT(t,i) repeat (k := k - 1)
67  k
68
69stringPosition(s,t,startpos) ==
70  n := SIZE t
71  if startpos < 0 or startpos > n then error "index out of range"
72  if SIZE s = 0 then return startpos -- bug in STRPOS
73  r := STRPOS(s,t,startpos,NIL)
74  if EQ(r,NIL) then n else r
75
76superMatch?(opattern,subject) ==  --subject assumed to be DOWNCASEd
77  $wildCard : local := char '_*
78  pattern := patternCheck opattern
79  logicalMatch?(pattern,subject)
80
81logicalMatch?(pattern,subject) ==  --subject assumed to be DOWNCASEd
82  pattern is [op,:argl] =>
83    op = "and" => and/[superMatch?(p,subject) for p in argl]
84    op = "or"  =>  or/[superMatch?(p,subject) for p in argl]
85    op = "not" =>  not superMatch?(first argl,subject)
86    systemError '"unknown pattern form"
87  basicMatch?(pattern,subject)
88
89patternCheck pattern == main where
90 --checks for escape characters, maybe new $wildCard
91  main ==
92--  pattern := pmTransFilter pattern   --should no longer need this (rdj:10/1/91)
93    u := pos(char '__,pattern)
94    null u => pattern
95    not(and/[equal(pattern,i + 1,$wildCard) for i in u]) =>
96      sayBrightly ['"Invalid use of underscores in pattern: ",pattern]
97      '"!!!!!!!!!!!!!!"
98    c := wild(pattern,'(_$ _# _% _& _@))
99--  sayBrightlyNT ['"Choosing new wild card"]
100--  pp c
101    $oldWild  :local := $wildCard
102    $wildCard := c
103    pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u))
104--  sayBrightlyNT ['"Replacing pattern by"]
105--  pp pattern
106    pattern
107  mknew(old,i,r,new) ==
108    new := STRCONC(new,old.(i + 1))  --add underscored character to string
109    null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0))
110    mknew(old,first r,rest r,
111          STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1)))
112  subWild(s,i) ==
113    (k := charPosition($oldWild,s,i)) < #s =>
114      STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1))
115    SUBSTRING(s,i,nil)
116  pos(c,s) ==
117    i := 0
118    n := MAXINDEX s
119    acc := nil
120    repeat
121      k := charPosition(c,s,i)
122      k > n => return NREVERSE acc
123      acc := [k,:acc]
124      i := k + 1
125  equal(p,n,c) ==
126    n > MAXINDEX p => false
127    p.n = c
128  wild(p,u) ==
129    for id in u repeat
130      c := char id
131      not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c
132
133match?(pattern,subject) ==  --returns index of first character that matches
134  basicMatch?(pattern,DOWNCASE subject)
135
136basicMatch?(pattern,target) ==
137  n := #pattern
138  p := charPosition($wildCard,pattern,0)
139  p = n => (pattern = target) and 0
140  if p ~= 0 then
141     -- pattern does not begin with a wild card
142     ans := 0
143     s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1]
144     not substring?(s,target,0) => return false
145  else if n = 1 then return 0
146  i := p   -- starting position for searching the target
147  q := charPosition($wildCard,pattern,p+1)
148  ltarget := #target
149  while q ~= n repeat
150     s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)]
151     i := stringPosition(s,target,i)
152     if null ans then ans := stringPosition(s,target,p)
153     -- for patterns beginning with wildcard, ans gives position of first match
154     if i = ltarget then return (returnFlag := true)
155     i := i + #s
156     p := q
157     q := charPosition($wildCard,pattern,q+1)
158  returnFlag => false
159  if p ~= q-1 then
160     -- pattern does not end with a wildcard
161     s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)]
162     if not suffix?(s,target) then return false
163     if null ans then ans := 1  --pattern is a word preceded by a *
164  ans
165
166stringMatches?(pattern, subject) ==
167    FIXP basicMatch?(pattern,subject) => true
168    false
169
170matchSegment?(pattern,subject,k) ==
171  matchAnySegment?(pattern,DOWNCASE subject,k,nil)
172
173matchAnySegment?(pattern,target,k,nc) ==  --k = start position; nc=#chars or NIL
174  n := #pattern
175  p := charPosition($wildCard,pattern,0)
176  p = n =>
177    m := stringPosition(pattern,target,k)
178    m = #target => nil
179    null nc => true
180    m <= k + nc - n
181  if k ~= 0 and nc then
182    target := SUBSTRING(target,k,nc)
183    k := 0
184  if p ~= 0 then
185     -- pattern does not begin with a wild card
186     ans := 0
187     s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1]
188     not substring?(s,target,k) => return false
189  else if n = 1 then return true
190  i := p + k  -- starting position for searching the target
191  q := charPosition($wildCard,pattern,p+1)
192  ltarget := #target
193  while q ~= n repeat
194     s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)]
195     i := stringPosition(s,target,i)
196     if i = ltarget then return (returnFlag := true)
197     i := i + #s
198     p := q
199     q := charPosition($wildCard,pattern,q+1)
200  returnFlag => false
201  if p ~= q-1 then
202     -- pattern does not end with a '&
203     s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)]
204     if not suffix?(s,target) then return false
205     if null ans then ans := 1  --pattern is a word preceded by a *
206  true
207
208infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x)
209
210prefix?(s,t) == substring?(s,t,0)
211
212suffix?(s,t) ==
213  m := #s; n := #t
214  if m > n then return false
215  substring?(s,t,(n-m))
216