'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 Const PLUS=43,MINUS=45 Dim shared AUTO,INFOCOL 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=5 BEGINC=3: COLINC=3: INFOCOL=58:PER=4 TYPE$="V" 'Demo from JA99 article CT$="BQYONIZIWQRGRIAQMQZVJTSUJKBPRM" CT$=CT$+"AGJLGKNAFRQCGLTVZHYPBG" END SUB 'DoFirstInits SUB InitDisplay Cls: CTLEN = LEN(CT$) KEY$=STRING$(PER,"A") BEGINR = KEYR+1 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 COLB=CCOL: COLE=COLB+COLINC*(PER-1) ShowColKeyStats 1 ShowAvgIndexOfCoin ShowCipherType RCPrint KEYR,CCOL,"" END SUB 'InitDisplay SUB ProcessKey(Ky,Ky$) Select Case Ky Case ASC("A") to ASC("Z"): SetKeyLetter(Ky$) Case ASC("a") to ASC("z"): SetKeyLetter(UCase$(Ky$)) Case PLUS: ChangeCipherType Case MINUS: ChangeAutoKeyType Case LEFT : MoveCursorLeft Case RIGHT: MoveCursorRight Case DOWN : DecreaseKeyLetter Case UP : IncreaseKeyLetter Case PAGEUP: IncreasePeriod Case PAGEDOWN: DecreasePeriod Case Else End Select RCPrint KEYR,CCOL,"" END SUB 'ProcessKey 'Decodes cipher col for key KLtr$ SUB DecColToScr(Row,KLtr$,CiCol) C = CiToScrCol(CiCol) EndRow = RowsInBlock(CiCol)+Row-1 CountR = RowsInBlock(1)+1 Posn = CiCol K$ = KLtr$ 'Local copy of key ltr Color 2 'Block color = green For R=Row To EndRow Ch$=Mid$(CT$,Posn,1) Posn=Posn+PER D$=Dec$(Ch$,K$) RCPrint R,C,D$ If AUTO=1 THEN K$=D$ Next R Color 7 'Default color = white DecColStats KLtr$,CiCol,Hi,Lo 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 CCOLCOLE Then CCOL=COLB ShowColKeyStats ScrToCiCol(CCOL) 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 SUB ShowCipherType C = InfoCol Select Case Type$ Case "V": RCPrint 2,C,"Vigenere" Case "B": RCPrint 2,C,"Beaufort" Case "A": RCPrint 2,C,"Variant " Case Else: RCPrint 2,C,"Porta " End Select RCPrint 1,C," " If Auto=1 Then RCPrint 1,C,"AutoKey" END SUB 'ShowCipherType SUB ChangeCipherType T=1+(Instr("VBAP",Type$)Mod 4) Type$=Mid$("VBAP",T,1) InitDisplay END SUB 'ChangeCipherType SUB ChangeAutoKeyType Auto = Auto Xor 1 InitDisplay END SUB 'ChangeAutoKeyType Function RJust$(I,N) 'Right Justify I Temp$=Space$(N)+Ltrim$(Str$(I)) RJust$=Right$(Temp$,N) End Function 'RJust$ SUB ShowColKeyStats(CiCol) For Kltr=0 to 25 C=2+2*Kltr : KLtr$=Chr$(KLtr+65) DecColStats Kltr$,CiCol,Hi,Lo RCPrint 1,C+1,KLtr$ RCPrint 2,C,RJust$(Lo,2) RCPrint 3,C,RJust$(Hi,2) Next Kltr END SUB 'ShowColKeyStats SUB DecColStats(Kltr$,CiCol,Hi,Lo) EndRow=RowsInBlock(CiCol) Posn = CiCol : K$ = Kltr$ Hi = 0 : Lo=0 For R=1 to EndRow Ch$=Mid$(CT$,Posn,1) Posn=Posn+PER D$=Dec$(Ch$,K$) If Instr("ETAONIRS",D$) Then Hi = Hi+1 Elseif Instr("JKQXZ",D$) Then Lo = Lo+1 End If If AUTO=1 THEN K$=D$ Next R END SUB 'DecColStats SUB SetKeyLetter(K$) Col= ScrToCiCol(CCOL) Mid$(KEY$,Col,1)=UCase$(K$) DecColToScr BEGINR,K$,Col RCPrint CROW,CiToScrCol(Col),K$ END SUB 'SetKeyLetter FUNCTION ColIndexOfCoin(Col) DIM Fr%(26) For I%=Col to CTLEN STEP PER Ch%=ASC(Mid$(CT$,I%,1))-ASC("@") Fr%(Ch%)=Fr%(Ch%)+1 N% = N%+1 Next I% For I%=1 to 26 Sum = Sum + Fr%(I%)*(Fr%(I%)-1) Next I% ColIndexOfCoin=Sum/(N%*(N%-1))*1000 END SUB 'ColIndexOfCoin SUB ShowAvgIndexOfCoin If auto=1 Then 'Skip if AutoKey Else For C=1 to Per Sum = Sum+ColIndexOfCoin(C) Next C Avg = Sum\Per Avg$="Period="+RJust$(Per,2) Avg$=Avg$+" AvgIC="+RJust$(Avg,3) RCPRINT 3,InfoCol,Avg$ End If END SUB 'ShowAvgIndexOfCoin