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

'This file is RouteSol.Bas.  It contains the complete
'RouteSol.Bas program.  It was formed by taking the
'published code from file RouteSol.txt and adding
'the Function InbyRoute$() from Routes.Bas in Jul/Aug 2002.
'That function uses several support routines from Routes.Bas,
'and all those have been added as well.  Finally, DiAvg() and
'DiSum() functions have been added from Nov/Dec 2001.

'The result is executable with QBasic; it solves Route
'transpositions or allows the user to determine a cipher is
'not a Route tramp.  See the Sep/Oct 2002 printed Computer
'Column for more details.


'RouteSol.Bas
DefInt A-Z
Const alt = -1, up = -1, max = 999
Dim shared Sq[100,100] 
dim shared RouteIn[500]
dim shared threshold

'Demo cipher  MJ02 E-02
ct$="DOCLFCMGPAAMAIAEUHPAINARSTALG"
ct$=ct$+"NXSAIURATOTIXLHITMVNNCVEC"
ct$=ct$+"INIYTNROUEAUISRNGMLCE"

Print "Digraph Threshold ";
Input "<Enter = 720> ";Threshold
If Threshold = 0 then Threshold=720
DiagnoseRoute ct$
input "Press Enter to Exit";x$
system


'For NRxNC rectangle & route pair InR
'OutR (0-47 each), convert Ct$ to Pt$
Function RouteTr$(nr,nc,InR,OutR,Ct$,Pt$)

 'Create routes & put names in R$
 R$=InByRoute$(nr,nc,InR)
 R$=R$+RJust$(1+(InR\12),1)+" "
 i=1 'Save write-in route numbers
 For r=1 to nr
   For c=1 to nc
     RouteIn[i] = Sq[r,c]
     i=i+1
   Next c
 Next r

 Pt$=Space$(nr*nc) 'Pre-extend Pt$
 R$=R$+" "+InbyRoute$(nr,nc,OutR)
 R$=R$+RJust$(1+(OutR\12),1)
 i=1 'Use routes in Sq$ & RouteIn to

 For r=1 to nr   'copy letters from
   For c=1 to nc 'Ct$ into Pt$
     ch$=mid$(Ct$,RouteIn[i],1)
     mid$(Pt$,Sq[r,c],1) = Ch$
     i=i+1
   Next c
 Next r

 RouteTr$=R$
End Function  'RouteTr$

SUB DiagnoseRoute(ct$)
Ctlen = len(ct$) : PL = 40
If Ctlen < 40 then PL = Ctlen

For fact=2 to 53     'Factor Ctlen
  r = Ctlen mod fact 'r=0 for factors
  If r <> 0 then goto nextf
  nr=ctlen/fact : nc=fact
  if nc > nr then exit for
  print "Trying rectangle ";nr;"x";nc
  Npr = 1 'Number of lines printed
  for RIn = 0 to 11
   for ROut = 0 to 47
     R$=RouteTr$(nr,nc,RIn,Rout,ct$,pt$)
     eval = DiAvg(pt$,1)
     if eval > threshold then 
       Npr = Npr+1 : print eval;
       print mid$(pt$,1,PL);" ";R$
     End If
     if Npr mod 15 = 0 then 
       Npr=1 'Reset output line count
       input "<Enter> for more";x$
     End If
     if eval > hi then 'save new high
       hi = eval : hnr=nr : hnc=nc
       hiR$ = R$
       hiPt$ = Pt$
     end if
   next ROut
  next RIn
nextf:
next fact

Print 
print "Best score & routes:";hi;hiR$;
print " ";hnr;"rows and";hnc;"cols."
print "Most likely plaintext: ";hiPt$

END SUB 'DiagnoseRoute

Sub ReverseEachRow(r,c)
For ri=1 to r
  For ci=1 to c\2
    Swap sq[ri,ci],sq[ri,c-ci+1]
  Next ci
Next ri
End Sub 'ReverseEachRow

Sub ReverseEachCol(r,c)
For ci=1 to c
  For ri=1 to r\2
    Swap sq[ri,ci],sq[r-ri+1,ci]
  Next ri
Next ci
End Sub 'ReverseEachCol

Sub ReverseNto1Sq(nr,nc)
'1,2,3... are swapped with n,n-1,n-2
n = nr*nc + 1
For r=1 to nr
  For c=1 to nc
    sq[r,c] = n - sq[r,c]
  Next c
Next r
End Sub 'ReverseNto1Sq

Sub Lin(Nsq,br,bc,llen,rinc,cinc,rmin,rmax,cmin,cmax)
r=br : c=bc
For i=1 to llen 'llen is line length
  if r>=rmin and r<=rmax then
     if c>=cmin and c<=cmax then
        Sq[r,c]=Nsq
        Nsq=Nsq+1
     end if
  end if
  r = r+rinc : c = c+cinc
Next i
End Sub 'Lin


Sub Horiz(nr,nc,alt)
Nsq=1
For r=1 to nr
  if not alt then 'normal rows
     Lin Nsq,r,1,nc,0,1,1,nr,1,nc
  elseif r mod 2 then 'even row
     Lin Nsq,r,1,nc,0,1,1,nr,1,nc
  else 'reverse odd row direction
     Lin Nsq,r,nc,nc,0,-1,1,nr,1,nc
  end if
Next r
End Sub 'Horiz

Sub Vert(nr,nc,alt)
Nsq=1
For c=1 to nc
 if not alt then 'normal columns
   Lin Nsq,1,c,nr,1,0,1,nr,1,nc
 elseif c mod 2 then 'even columns
   Lin Nsq,1,c,nr,1,0,1,nr,1,nc
 else  'reverse odd column direction
   Lin Nsq,nr,c,nr,-1,0,1,nr,1,nc
 end if
Next c
End Sub 'vert

Sub Diag(nr,nc,up,alt)
Nsq=1 : Limit=nr+nc-1
for N=1 to Limit
 Nodd= -(N mod 2)
 if not alt then
   if up then 'upward diagonals
    Lin Nsq,nr,N-nr+1,nr,-1,1,1,nr,1,nc
   else       'downward diagonals
    Lin Nsq,1,N,nr,1,-1,1,nr,1,nc
   end if
 elseif (up eqv Nodd) then 'alternate
    Lin Nsq,nr,N-nr+1,nr,-1,1,1,nr,1,nc
 else
  Lin Nsq,1,N,nr,1,-1,1,nr,1,nc
 end if
Next N
End Sub 'Diag

Sub SpiralRevCW(n,rn,cn,rb,cb)
Lin n,rb,cb,cn,0,1,0,max,0,max
br=rb+rn-1 : bc=cb+cn-1 'begin r&c
if rn>1 then 
  Lin n,rb+1,bc,rn-1,1,0,0,max,0,max
  Lin n,br,bc-1,cn-1,0,-1,0,max,0,max
end if 
if cn > 1 then 
  Lin n,br-1,cb,rn-2,-1,0,0,max,0,max
end if  'finished with one revolution
End Sub 'of spiral (clockwise)

Sub SpiralRevCCW(n,rn,cn,rb,cb)
Lin n,rb,cb,rn,1,0,0,max,0,max
br=rb+rn-1 : bc=cb+cn-1 'begin r&c
if cn>1 then
  Lin n,br,cb+1,cn-1,0,1,0,max,0,max
  Lin n,br-1,bc,rn-1,-1,0,0,max,0,max
end if
if rn > 1 then 
  Lin n,rb,bc-1,cn-2,0,-1,0,max,0,max
end if  'finished with one revolution
End Sub 'of spiral (counterclockwise)

Sub SpiralCW(rn,cn)
  i=1:n=1:r=rn:c=cn
  while r>0 and c>0
    spiralRevCW n, r, c, i, i
    i=i+1: r = r-2 : c = c-2
  wend
End Sub 'SpiralCw

Sub SpiralCCW(rn,cn)
  i=1 : n=1 : r=rn : c=cn
  while r>0 and c>0
    SpiralRevCCW n, r, c, i, i
    i=i+1 : r = r-2 : c = c-2
  wend
End Sub 'SpiralCCw

Function InByRoute$(nr,nc,Rnum) Static
if T$="" then
T$="    H   AH    V   AV  CWS CCWS C"
T$=T$+"WRSCCWRS   UD   DD  AUD  ADD"
End If
Typ  = Rnum mod 12
Select Case Rnum
 case  0
   Horiz nr,nc,Not alt
 case  1
   Horiz nr,nc,alt
 case  2
   Vert nr,nc,Not alt
 case  3
   Vert nr,nc,alt
 case  4
   SpiralCW nr,nc
 case  5
   SpiralCCW nr,nc
 case  6
   SpiralCCW nr,nc
   ReverseNto1Sq nr,nc
 case  7
   SpiralCW nr,nc
   ReverseNto1Sq nr,nc
 case  8
   Diag nr, nc,up,Not alt
 case  9
   Diag nr,nc,Not up,Not alt
 case 10
   Diag nr, nc,  up, alt
 case 11
   Diag nr, nc, Not up, alt
 case Else
  rquo=Rnum\12 : rrem=Rnum mod 12
  Tmp$=InByRoute$(nr,nc,rrem)
  If (rquo=1) Then
   ReverseEachRow nr,nc
   if typ and 4 then typ=typ xor 1
   Elseif rquo=3 Then
     ReverseEachCol nr,nc
     if typ and 12 then typ=typ xor 1
   Else 
     ReverseEachRow nr,nc
     ReverseEachCol nr,nc
     if typ and 8 then typ=typ xor 1
   End if
  End Select
  InByRoute$= Mid$(T$,5*Typ+1,5) 
End Sub  'InByRoute$

    
'Corrected Nov/Dec 2001    

Function DiAvg(S$,A)    
 DLen%= Len(S$) - 1    
 If A<>1 then Dlen%=((Dlen%-1)\2)+1    
 DiAvg = Int(100*(DiSum(S$,A)/Dlen%))    
End Function 'DiAvg    
    
Function DiSum(S$,A) Static    
IF Init%=0 Then    
DIM Di%(26,26)    
d$=d$+"47874675736879373989676574742"    
d$=d$+"08111630721710653712060825273"    
d$=d$+"28727621822647613040765686558"    
d$=d$+"43665753677656062978887667458"    
d$=d$+"79775998577673745376447226538"    
d$=d$+"40757624050755475577326557527"    
d$=d$+"66635051854494348315548426576"    
d$=d$+"25050758777744258797647884735"    
d$=d$+"05500040003000005000006000005"    
d$=d$+"43274246224365313653040508557"    
d$=d$+"85448258548524666550718643842"    
d$=d$+"47104647613656140608678869684"    
d$=d$+"66568535896563626677686663678"    
d$=d$+"97729789684537333732672173276"    
d$=d$+"07666030400000000000000000000"    
d$=d$+"06000008667966583666686368865"    
d$=d$+"60718676865784666687458974706"    
d$=d$+"28665865983366596278874707266"    
d$=d$+"76646462377856088833434361008"    
d$=d$+"00070000050001021003073347328"    
d$=d$+"72244673055521403141424203510"    
d$=d$+"11035012520223066666655633565"    
d$=d$+"86357643624240005000300200300"    
d$=d$+"010200044"    
For I%=0 to 675 'Build Di% Table    
  C$=Mid$(D$,I%+1,1): V% = Val(C$)    
  Di%((I%\26)+1,(I% mod 26)+1)=V%    
Next I%    
d$="" : Init%=1 'Initialization done    
End If    
TLen%=Len(S$)-1 : Sum%=0 :Stp%=2    
If A=1 Then Stp%=1    
For I%=1 to TLen% Step Stp%    
  R%=Asc(Mid$(S$,I%,1))-64    
  C%=Asc(Mid$(S$,I%+1,1))-64    
  Sum%=Sum%+Di%(R%,C%)    
Next I%    
DiSum = Sum%    
End Function 'DiSum    
  
'Right-justify I in field of length L
Function RJust$(I,L)
  Tmp$ = Space$(L) + Ltrim$(Str$(I))
  RJust$ = Right$(Tmp$,L)
End Function 'RJust$