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

'Vigenere/Variant/Beaufort/Porta Solver
'Global values are in upper case
Const ESC=27, LEFT=331, RIGHT=333
Const UP=328, DOWN=336, PAGEUP=329
Const PAGEDOWN=337,DEL=339,INS=338
Dim shared CT$,PER,CTLEN,TYPE$,CCOL
Dim Shared CROW,COLB,COLE,KEY$,BEGINR
Dim shared PERIODMAX,PERIODMIN
Dim shared KEYR,BEGINC,COLINC

DoFirstInits        'Done only once
InitDisplay         '  more than once
GetKey Ky,Ky$       'The main program
Do While Ky<>ESC    'processing loop
  ProcessKey Ky,Ky$ 'acts on each key
  GetKey Ky,Ky$     'pressed by user
Loop                '& exits on ESC

SUB DoFirstInits
 PERIODMAX=25 : PERIODMIN=3: KEYR=1
 BEGINC=3     : COLINC=3
 PER=7     'For: E-7 ND98 (Variant)
 TYPE$="A" 'Type A means Variant
 CT$="PQKPIBWNNUCLOADHVLLLJQBKZSUXA"
 CT$=CT$+"MKQWYIEWKATFWZMOKYAKCNZEW"
 CT$=CT$+"YPDNYREZKBCNBKXQWAKPGMPDN"
 CT$=CT$+"UQZLNPFUPAKAOXLQZLPNRGKYSA"
END SUB 'DoFirstInits

SUB InitDisplay
  CTLEN = LEN(CT$)
  KEY$=STRING$(PER,"A")
  BEGINR = KEYR+1
  Cls
  For  Col=1 to PER
    DecColToScr BEGINR,"A",Col
  Next Col
  CCOL=CiToScrCol(1) : CROW=KEYR
  For I=1 to PER
    RCPrint KEYR,CiToScrCol(I),"A"
  Next I
  RCPrint KEYR,CCOL,""
  COLB=CCOL
  COLE=COLB+COLINC*(PER-1)
END SUB 'InitDisplay

SUB ProcessKey(Ky,Ky$)
Select Case Ky
  Case LEFT :    MoveCursorLeft
  Case RIGHT:    MoveCursorRight
  Case DOWN :    DecreaseKeyLetter
  Case UP   :    IncreaseKeyLetter
  Case PAGEUP:   IncreasePeriod
  Case PAGEDOWN: DecreasePeriod
  Case Else
End Select
END SUB

'Decodes cipher col for key KLtr$
SUB DecColToScr(Row,KLtr$,CiCol)
  C = CiToScrCol(CiCol)
  EndRow = RowsInBlock(CiCol)+Row-1
  Posn = CiCol
  Color 2  'Block color = green
  For R=Row To EndRow
    Ch$=Mid$(CT$,Posn,1)
    Posn=Posn+PER
    RCPrint R,C,Dec$(Ch$,KLtr$)
  Next R
  Color 7  'Default color = white
END SUB 'DecColToScr

'Returns num of rows in col CiCol
FUNCTION RowsInBlock(CiCol)
  NRows=CTLEN\PER  'Integer Division
  NRem=CTLEN mod PER
  IF CiCol<=NRem THEN NRows=NRows+1
  RowsInBlock = NRows
END FUNCTION 'RowsInBlock

'Returns screen col given cipher col
FUNCTION CiToScrCol(CiCol)
 CiToScrCol= COLINC*(CiCol-1)+BEGINC
END FUNCTION 'CiToScrCol

'Returns cipher col Given screen col
FUNCTION ScrToCiCol(ScrCol)
 ScrToCiCol= 1+(ScrCol-BEGINC)/COLINC
END FUNCTION 'ScrToCiCol

SUB RCPrint(R,C,Ch$)
  If R < 26 and C < 80 then
    LOCATE R,C,1,30,31
    PRINT  Ch$;
    LOCATE R,C,1,30,31
  End If
END SUB 'RCPrint

'Returns pt ltr given Ct Ltr, Key &
'type = V/B/A/P = Vig/Beau/Var/Porta
FUNCTION Dec$(CLtr$,KLtr$)
  C=ASC(CLtr$)-65 : K=ASC(KLtr$)-65
  Select Case TYPE$
    Case "V" : D = (C-K+26) mod 26
    Case "B" : D = (K-C+26) mod 26
    Case "A" : D = (C+K) mod 26
    Case Else' Any other case=Porta
       K = K\2 : D = C
       If D < 13 Then
         D=D+K : If D<13 Then D=D+13
       Else
         D=D-K : If D>12 Then D=D-13
       End If
  End Select
  Dec$ = CHR$(D+65)
END FUNCTION 'Dec$

SUB GetKey(Ky,Ky$)
  Ky$=""
  Do While KY$=""
     Ky$=InKey$
  Loop
  If Len(Ky$)=1 Then
     Ky=Asc(Ky$)
  Else
     Ky=Asc(Right$(Ky$,1))
     Ky=Ky+256
     Ky$=""
  End If
END SUB 'GetKey

SUB MoveCursorLeft
  CCOL=CCOL-COLINC
  If CCOL<COLB Then CCOL=COLE
  RCPrint CROW,CCOL,""
END SUB 'MoveCursorLeft

SUB MoveCursorRight
  CCOL=CCOL+COLINC
  If CCOL>COLE Then CCOL=COLB
  RCPrint CROW,CCOL,""
END SUB 'MoveCursorRight

FUNCTION Scr$(ScrRow,ScrCol)
  Scr$ = Chr$(Screen(ScrRow,ScrCol))
END FUNCTION 'Scr$

SUB DecreaseKeyLetter
  K$= Scr$(CROW,CCOL) 'Read key from
  K$= Chr$(Asc(K$)-1) 'screen, change
  If K$<"A" Then K$= "Z" 'it in KEY$
  Col= ScrToCiCol(CCOL)  '& on screen
  Mid$(KEY$,Col,1)=K$    '& redecrypt
  DecColToScr BEGINR,K$,Col 'column
  RCPrint CROW,CiToScrCol(Col),K$
END SUB 'DecreaseKeyLetter

SUB IncreaseKeyLetter ' See comments
  K$= Scr$(CROW,CCOL) ' in previous
  K$= Chr$(Asc(K$)+1) ' function.
  If K$ > "Z"  Then  K$ = "A"
  Col= ScrToCiCol(CCOL)
  Mid$(KEY$,Col,1)=K$
  DecColToScr BEGINR,K$,Col
  RCPrint CROW,CiToScrCol(Col),K$
END SUB 'IncreaseKeyLetter

SUB IncreasePeriod
  If PER>=PERIODMAX Then 'do nothing
     Else PER=PER+1 : InitDisplay
  Endif
END SUB 'IncreasePeriod

SUB DecreasePeriod
  If PER<=PERIODMIN Then 'do nothing
     Else PER=PER-1 : InitDisplay
  Endif
END SUB 'DecreasePeriod