10 '***  KEYPHRAS.ENC *** NOV 1 87a ibm version Oct 1989r
15 'by Mike Barlow, Montreal, Canada
16 'crib encipherment not activated at line 4000 but OK.
20 KEY OFF:GOTO 9000
500 '
     --- encipher PT$ with key KP$ ---
510 CT$="":FOR N=1 TO LEN(PT$)
520  T$=MID$(PT$,N,1):IF T$=" " THEN CT$=CT$+" ":GOTO 550
530  X=INSTR(AL$,T$)                  'get posn of pt letter in alphabet
540  CT$=CT$+MID$(KP$,X,1)            'add corresp letter in key
550 NEXT:RETURN
600 '   --- SUB: force ZZ$ to upper case ---
610 OP$=""
620 FOR N=1 TO LEN(ZZ$)
630  X$=MID$(ZZ$,N,1): IF X$=" " THEN OP$=OP$+" ":GOTO 650
640  OP$=OP$+CHR$(ASC(X$) AND 223)      'force u.c
650 NEXT:ZZ$=OP$
660 RETURN
999 '
           --------> misc subs <--------
1000 CLS:PRINT DATE$: LOCATE 1,31:PRINT "KEYPHRASE ENCIPHERER":LOCATE 2,31:PRINT STRING$(20,"-")
1010 LOCATE 4,34:PRINT "By Mike Barlow":RETURN
1020 LOCATE 23,1:PRINT SPC(79);:LOCATE 23,29:PRINT "Press <ENTER> to proceed: ";:LINE INPUT Q$: LOCATE 23,1:PRINT SPC(79);:RETURN
1050 FOR N=1 TO D9:NEXT:RETURN  'delay
4000 '
   --- Caesar the crib (limited +/- 4) ---
4010 CLS:PRINT"What is the plaintext crib? (UPPER CASE):";:LINE INPUT A$
4020 FOR N=-4 TO +4
4030   PRINT N
4050   FOR K = 1 TO LEN(A$)
4060     T$=MID$(A$,K,1)'   process each letter in turn
4080     CD=ASC(T$)+N:IF CD>90 THEN CD=CD-26
4081     IF CD<65 THEN CD=CD+26
4090     NU$=CHR$(CD):PRINT NU$;
4100   NEXT
4110 NEXT:PRINT
4120 PRINT"Choose the enciphered crib (UPPER CASE): ";:LINE INPUT CB$:IF LEN(CB$)<>LEN(A$)THEN PRINT"** ERROR ** Try again.":GOSUB 1020:GOTO 4120
4130 CLS:LOCATE 1,46:PRINT"Crib: "CB$;
4140 RETURN
7000 '
           ---->  HELP routine <----
7010 GOSUB 1000:PRINT:PRINT"  The Keyphrase cipher is similar to a regular Aristocrat except that there can be several cipher equivalents for each plaintext letter, and a letter can stand for itself."
7020 PRINT:PRINT"  For maximum difficulty of solution, choose a crib word that has a length equalto at least 2, preferably more, of the other textwords, and avoid repeating let-ters that allow a pattern check.   The crib does not need to be ";
7030 PRINT CHR$(34)"Caesared"CHR$(34)"for publication in The Cryptogram."
7050 GOSUB 1020:RETURN
8999 '
             ----> initialisation <----
9000 CLS:CLEAR :DEFINT A-Z
9030 DIM C(90), X$(90)
9040 AL$="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
9090 GOSUB 1000                 'title
9100 GOSUB 20000                'pick up default example
9120 LOCATE 9,33: PRINT "Need Help? (Y/N*): ";:LINE INPUT Q$: IF Q$="Y" OR Q$="y" THEN NH=1:GOTO 7000
9140 :
9150 GOSUB 1000:KP$="":LOCATE 6,1:PRINT"Enter the key phrase (either case, 26 letters, a complete phrase, no spaces or punctuation; repeating letters allowed): "
9151 LOCATE 9,1:PRINT STRING$(26,"-"):LOCATE 9,1:LINE INPUT KP$
9160 IF KP$=""THEN KP$=XKP$:LOCATE 9,1: PRINT KP$
9170 PRINT:PRINT"Key phrase has"LEN(KP$)"characters";:IF LEN(KP$)<>26 THEN PRINT" ** NOT 26 LETTERS ** - try again: ":GOSUB 1020:GOTO 9150
9180 GOSUB 1020:ZZ$=KP$:GOSUB 600:KP$=ZZ$:GOSUB 1000    'force U.C
9190 LOCATE 5,1:COLOR 0,7:PRINT " Keyphrase is: ":COLOR 7,0:PRINT KP$
9200 GOTO 9500
9210 :
9250 '
9260 LOCATE 23,1:PRINT"Do you wish to <P*>rint this for the Cm, do <A>nother, or <Q>uit? ";:LINE INPUT Q$
9270 ON INSTR("PpAaQq",Q$)GOTO 9280,9280,10,10,9390,9390:GOTO 9260
9280 ON ERROR GOTO 18000
9290 WIDTH "lpt1:",255                          'needed by GWBASIC
9300 EM(0)=-12971:EM(1)=23813:EM(2)=-28469
9310 X=VARPTR(EM(0))
9320 CALL X
9340 FOR N=1 TO 20:LPRINT:NEXT                  'space to bottom of page
9350 LPRINT TYPE$(NS) "KEYPHRASE encipherment by Mike Barlow   "DATE$:LPRINT
9360 LPRINT OP$
9370 ON ERROR GOTO 0
9380 LPRINT CHR$(12):GOTO 9260
9390 LOCATE 23,1:PRINT SPC(79):LOCATE 23,39:PRINT "end":LOCATE 23,1:END
9410 :
9500 PT$="":LOCATE 8,1:PRINT "Enter the plaintext (either case, with spaces, no punctuation, 75-100 letters):":LINE INPUT PT$
9510 IF PT$="" THEN PT$=XPT$:PRINT PT$
9520 PRINT:PRINT"Plaintext has"LEN(PT$)"characters"
9530 GOSUB 1020
9540 ZZ$=PT$:GOSUB 600:PT$=ZZ$
9550 LOCATE 8,1: FOR N=1 TO 6: PRINT SPC(79):NEXT    'clear some space
9560 LOCATE 8,1: COLOR 0,7:PRINT" Plaintext is: ":COLOR 7,0:PRINT PT$
9570 PRINT:PRINT"Plaintext has"LEN(PT$)"characters":PRINT
9580 :
9600 Z=1:PRINT"Word lengths are: ";
9610 X=INSTR(Z,PT$+" "," "):IF X=0 THEN 9700
9620 L=X-Z:PRINT L;
9630 Z=X+1:GOTO 9610
9640 :
9700 PRINT:PRINT:COLOR 0,7:PRINT" Ciphertext is: ":COLOR 7,0:GOSUB 500:PRINT CT$;:OP$=CT$:GOTO 9260
18000 '   --- printer error trap ---
18010 IF ERR=24 OR ERR=25 OR ERR=27 THEN LOCATE 23,1:PRINT SPC(79):LOCATE 23,15: PRINT "Printer not ready; press <ENTER> to proceed: ";:LINE INPUT Q$:LOCATE 23,1:PRINT SPC(79):RESUME
18020 ON ERROR GOTO 0:STOP
19999 '
            ----> examples <----
20000 XPT$="A CIPHERTEXT LETTER MAY STAND FOR MORE THAN ONE PLAINTEXT LETTER":XKP$="GIVEMELIBERTYORGIVEMEDEATH":XB$="PLAINTEXT" 'ACA&U P37
20050 RETURN
65000 SAVE"keyphras.enc",A