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

'Program code from the Computer Column
'for Sep/Oct 2000.  The program searches
'a word list for a keyword alphabet in
'a 5x5 square that matches corow and
'cocol patterns entered by user.

'12 routes are included in this version.
const NumRoutes=12
defint A-Z
dim shared RtOrder(12,25), Route$(12)
dim shared CoR$(15), CoC$(15)

'Get various inputs from user
Input "Enter Word File Name";Fi$
InitRoutes 'Copy data into arrays
Open Fi$ for Input As 1

For I=1 to 15
 Input "Enter CoRow string: ";CoR$(I)
 If Len(CoR$(I))<2 then
    CoRNum=I-1
    Exit For
 End If
Next I

For I=1 to 15
 Input "CoColumn string: ";CoC$(i)
 If Len(CoC$(I))<2 then
    CoCNum=I-1
    Exit For
 End If
Next I

'Main program loop
Al$= GetAlph$    'Get keyed alphabet
Do While Al$<>"" 'Do all keyed alphas
  For I=1 to NumRoutes 'Do each route

    'Put Al$ into Sq$ using route I
    Sq$ = AlphFromRoute$(I,Al$)

    'Check Co-Row/Co-Column strings
    For J=1 to CoRNum
      If CoRC(Cor$(J),Sq$,1)=0 then
        Goto NextRoute 'Failed test
      End If           'for Co-Row
    Next J
    For J=1 to CoCNum
      If CoRC(CoC$(J),Sq$,0)=0 then
        Goto NextRoute  'Failed test
      End If            'for Co-Col
    Next J
 
    'Get here only if Sq$ satisfies
    'all Co-Row/Column relationships
    'Show user the square
    Print "Alphabet: ";Al$
    Print "Route:    ";Route$(I)
    PrtSq Sq$
    Input "Press Enter";X$
  NextRoute:
  Next I         'Try next route
  Al$ = GetAlph$ 'Try next key word
Loop 'until key words are exhausted
End  'end of main program

Sub InitRoutes      'Copies data
For I=1 to NumRoutes'statements into
  Read Route$(I)    'arrays. RtOrder
  For J=1 to 25     'contains for
   Read RtOrder(I,J)'route I the 25
  Next J            'values used to
Next I              'reorder alphabet
End Sub 'InitRoutes 'into route form

Function AlphFromRoute$(I,Al$)
'Inputs: Route num I & Key alpha Al$
'Output: Al$ reordered as if written
'in by route I, out by horizontals,
  R$=""
  For J=1 to 25
    R$=R$+mid$(Al$,RtOrder(I,J),1)
  Next J
  AlphFromRoute$=R$
End Function 'AlphFromRoute$

Sub PrtSq(Sq$)
'Print alphabet Sq$ as 5x5 square
  RowPosn = 1
  For RowNum=1 to 5
    Print "    ";Mid$(Sq$,RowPosn,5)
    RowPosn = RowPosn+5
  Next RowNum
End Sub

Function GetAlph$()    'Reads next
  Dim Used(26)         'file line as
  Line Input #1, Word$ 'key & returns
  If Eof(1) Then       'keyed alpha-
    Close 1            'bet (or null
    GetAlph$=""        'string at end
    Exit Function      'of file).
  End If
  A25$="ABCDEFGHIKLMNOPQRSTUVWXYZ"
  Word$=Ucase$(Word$)
  Tmp$=Word$+A25$      'Prepend key
  TmpLen=Len(Tmp$)     'to normal 25-
  Alph$=""             'ltr sequence.
  Redim Used(26)       'Rezero used
  For I=1 to TmpLen    'ltr flags.
    C$=Mid$(Tmp$,I,1)  'Cvt ltrs to
    A=ASC(C$)-64       'range of 1-26
    'Ignore punctuation if present
    If A<1 OR A>26 Then Goto NxtI
    IF A=10 Then A=9   'Make J into I
    If Used(A)=0 Then  'Add unused
      Used(A)=1        'ltr to Alph$
      Alph$=Alph$+Chr$(64+A) '& set
    End If             'its Used flag
  NxtI:
  Next I         'Do next ltr in Tmp$
  GetAlph$=Alph$ 'Return keyed alpha
End Function     'GetAlph$
  
Function CoRC(S$,Sq$,R)
'Tests ltrs in S$ as CoRow or CoCol
'in Sq$.  R=1 means test for CoRow;
'         R=0 means test for CoCol.
'Function Returns 1 if all ltrs in
'S$ meet the test. In code below
'P1 is row (or col) of 1st ltr in S$.
'P2 is row (or col) of other ltrs.

  S$  = UCase$(S$)
  L   = len(S$)  
  P1  = instr(1,Sq$,mid$(S$,1,1))-1
  If R then P1=P1\5 else P1=P1 mod 5

  'Check ltrs after 1st against 1st
  For I=2 to L
   P2  = instr(1,Sq$,mid$(S$,I,1))-1
   If R then P2=P2\5 else P2=P2 mod 5
   If P1<>P2 then
     CoRC=0        'A test fails
     Exit Function 'Return 0
   End If
  Next I
  CoRC=1           'All tests succeed
End Function       'Return 1

'Twelve routes. To add a route,
'add 6 similar data statements and
'change NumRoutes at top of program.
data   "horiz"
data   1, 2, 3, 4, 5
data   6, 7, 8, 9,10
data  11,12,13,14,15
data  16,17,18,19,20
data  21,22,23,24,25
data   "alt horiz"
data   1, 2, 3, 4, 5
data  10, 9, 8, 7, 6
data  11,12,13,14,15
data  20,19,18,17,16
data  21,22,23,24,25
data   "up diag"
data   1, 3, 6,10,15
data   2, 5, 9,14,19
data   4, 8,13,18,22
data   7,12,17,21,24
data  11,16,20,23,25
data   "alt up diag"
data   1, 2, 6, 7,15
data   3, 5, 8,14,16
data   4, 9,13,17,22
data  10,12,18,21,23
data  11,19,20,24,25
data   "down diag"
data   1, 2, 4, 7,11
data   3, 5, 8,12,16
data   6, 9,13,17,20
data  10,14,18,21,23
data  15,19,22,24,25
data   "alt down diag"
data   1, 3, 4,10,11
data   2, 5, 9,12,19
data   6, 8,13,18,20
data   7,14,17,21,24
data  15,16,22,23,25
data   "vert"
data   1, 6,11,16,21
data   2, 7,12,17,22
data   3, 8,13,18,23
data   4, 9,14,19,24
data   5,10,15,20,25
data   "alt vert"
data   1,10,11,20,21
data   2, 9,12,19,22
data   3, 8,13,18,23
data   4, 7,14,17,24
data   5, 6,15,16,25
data   "cwise spiral"
data   1, 2, 3, 4, 5
data  16,17,18,19, 6
data  15,24,25,20, 7
data  14,23,22,21, 8
data  13,12,11,10, 9
data   "ccwise spiral"
data   1,16,15,14,13
data   2,17,24,23,12
data   3,18,25,22,11
data   4,19,20,21,10
data   5, 6, 7, 8, 9
data   "rev cwise spiral"
data  25,10,11,12,13
data  24, 9, 2, 3,14
data  23, 8, 1, 4,15
data  22, 7, 6, 5,16
data  21,20,19,18,17
data   "rev ccwise spiral"
data  25,24,23,22,21
data  10, 9, 8, 7,20
data  11, 2, 1, 6,19
data  12, 3, 4, 5,18
data  13,14,15,16,17