'Copyright 1999 The American Cryptogram Association (ACA)
'3613 Piedmont Drive, Plano TX 75075-6234
'All rights reserved.

'Program 1: Word Pattern Search

Input "Enter Name of Word File";F$
Input "Enter Pattern";P$
W$ = WordMatch$(F$,P$)
Do While W$<>""
  Print W$,
  W$ = WordMatch$("","")
Loop
Print "-> Done"

Defint A-Z
Function Matches(Word$,Init%) Static
Dim Pat[32]            'Call first
If Init% <> 0 Then     'with Init=1
  WLen = Len(Word$)    'to create
  PatLen=WLen-1        'the pattern
  For I=1 to PatLen    'in array
    C$=Mid$(Word$,I,1) 'Pat[]
    Pat[I]=Instr(I+1,Word$,C$)
  Next I
Else
  Match=1         'Assume Match found
  WSeg$=Word$          'Scan terminal
  SegLen=Len(WSeg$)    'segments for 
  While SegLen >= Wlen 'pattern match
    For I=1 to PatLen     'Check cur
      C$=Mid$(WSeg$,I,1)  'segment
      Posn=Instr(I+1,WSeg$,C$) 'with
      If Pat[I]<>Posn Then'pattern in
         Goto NextSeg     'Pat[].
      End If              '
    Next I                '
    Goto MatchSuccess     'Matched.
  NextSeg:                'No match,
    WSeg$=Mid$(WSeg$,2)   'examine
    SegLen=SegLen-1       'next
  Wend                    'segment
End If
Match=0
MatchSuccess:
Matches=Match
End Function 'Matches

'Each call to WordMatch$() returns
'from file Fi$ one word that matches
'the string in Patt$.  What counts as
'a match is determined by the helper
'function Matches().
Function WordMatch$(Fi$,Patt$) Static
If Init=0 Then 'If first call, open
  Init=1       'the file and init-
  Open Fi$ For Input As 1 'ialize
  Temp=Matches(Patt$,1)   'pattern
End If                    'array
Do While Not Eof(1)
  Line Input #1, Word$
  If Matches(Word$,0) Then
     WordMatch$=Word$
     Goto WordMatchEnd
  End If
Loop
  Close #1
  Init=0
  WordMatch$=""
WordMatchEnd:
End Function  'WordMatch$