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

'Tridigital/Keyphrase pattern search

Input "Enter Name of Word File";F$
Print "As a pattern, enter a keyphrase or tridigital cipher word."
Print "Or enter an extended word including a plaintext/ciphertext crib,"
Print "   like this: 143212135/THE/512
Input "What is the pattern";P$
W$ = WordMatch$(F$,P$)
Do While W$<>""
  Print W$,
  W$ = WordMatch$("","")
Loop
Print "-> Done"

Defint A-Z
'Listing 2 Tridigital/Keyphrase match
Function Matches(Word$,Init%) Static
Dim Ltr[90] 'Temp array used to build
Dim Pat[32] '  the pattern in Pat
Word$=UCase$(Word$) 'Make upper case

If Init% <> 0 Then  'Do inits
  For I=48 To 90: Ltr(I)=0: Next I
  Typ$="K" 'Assume type is keyphrase
  If Word$ < "A" Then Typ$="T"

  'Parse extended pattern into target
  '  and crib pt/ct strings.
  SL=Instr(1,word$,"/") 'Posn of left
  If SL=0 Then          '  slash
     CribCt$="" : CribPt$=""
     Ew$=Word$  : WordLen=Len(Ew$)
  Else
     SR=Instr(SL+1,Word$,"/")
     Ew$=Mid$(Word$,1,SL-1)
     WordLen=Len(Ew$)
     CribPt$=mid$(word$,SL+1,SR-SL-1)
     CribCt$=mid$(word$,SR+1)
  EndIf
  Ew$=Ew$+CribCt$ 'Extended Word is
  EwLen=Len(Ew$)  'CtWord+CribCt

  'Scan ct word EW$ & build pattern
  LtrNum = 1
  For I = 1 TO EwLen
    Ch = Asc(Mid$(Ew$, I, 1))
    If Ltr(Ch) = 0 Then
      Ltr(Ch) = LtrNum
      LtrNum = LtrNum + 1
    End If
    Pat(I) = Ltr(Ch)
  Next I
Else

  'Execution normally begins here
  '  to see if Word$ matches pattern
  Match=0    'Assume the match fails
  If Len(Word$)<>WordLen Then
    Goto MatchesEnd      'No match
  End If
  For I=48 To 90: Ltr(I)=0: Next I
  EPt$ = Word$+CribPt$ 'Extended Pt

  'Check EPt$ for match with pattern
  For I=1 to EwLen
    ch = Asc(Mid$(EPt$,I,1))
    LtrNum = Pat(I)
    If Ltr(Ch) = 0 Then
       Ltr(Ch) = LtrNum
    Elseif Ltr(Ch) <> LtrNum Then
       Goto MatchesEnd 'No Match
    End If
  Next I

  'We now know Word$ matches pattern
  'If a tridigital match, check limit
  If Typ$="T" Then
    For I=1 to 10:Ltrs$(I)="":Next I
    For I=1 to EwLen
      Ch$= Mid$(EPt$,I,1)
      LtrNum = Pat(I)
      T$ = Ltrs$(LtrNum)
      If Instr(T$,Ch$)=0 Then
         Ltrs$(LtrNum)=T$+Ch$
      End If
    Next I
    For I=1 to 10
      If Len(Ltrs$(I))>3 Then
         GoTo MatchesEnd 'No Match
      End If
    Next I
  End If 
End If

Match=1    'Succesful init or match
MatchesEnd:
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$