ANEW --SOLITAIRE--                            \  Neil Bawd  2003-02-22

\  *******************************************************************
\  *                                                                 *
\  *  Neil Bawd  99-07-14                                            *
\  *                                                                 *
\  *              SOLITAIRE                                          *
\  *                                                                 *
\  *  `SOLITAIRE` is a Forth implementation of the Solitaire         *
\  *  cryptosystem, as designed by Bruce Schneier and described at   *
\  *  <http://www.counterpane.com/solitaire.html>, as well as        *
\  *  in Neil Stephenson's novel _Cryptonomicon_,                    *
\  *  ISBN 0-380-97346-4.                                            *
\  *                                                                 *
\  *******************************************************************

\  "Cheap, fast, good: choose two."

\  Alleged `RC4`, now known as `ARCFOUR`, is cheap and fast and good. 
\  It _does_ need a computer. 

\  `SOLITAIRE` is cheap and good, but it's not fast. It's very cheap; 
\  it doesn't need a computer, just a deck of cards. It's more secure 
\  than all other known paper- and-pencil ciphers other than a 
\  one-time pad. And for fast, it's as fast as an actual cipher used 
\  by a Soviet spy. This was described by David Kahn in _Kahn on 
\  Codes_. 

\  Using the Soviet cipher or `SOLITAIRE` will take an evening to 
\  encrypt or decrypt a message with paper and pencil. However one 
\  side or the other will almost always have a computer. I have the 
\  Forth code on my Palm. 

\  A deck of cards is easier to conceal than a computer or codebook. 
\  But soon the secret police will seize and torture anyone with a 
\  deck of cards. A card deck is a munition and criminal to export. 

\  The algorithm takes the normal cards of a deck as the numbers 
\  1-52, with two Jokers as 53-54. The letters of the alphabet are 
\  1-26. Adding a card number to a letter number modulo 26 enciphers 
\  a letter; subtracting a card number modulo 26 deciphers a letter. 

\  The card numbering arranges the suits in Bridge order - Clubs, 
\  Diamonds, Hearts, Spades. The suits are arranged A23456789JQK. So 
\  Clubs are 1-13, Diamonds 14-26, Hearts 27-39, Spades 40-52. The 
\  Queen of Hearts is 12+26 = 38; the Ace of Spades is 40. 

\  The two Jokers should be distinguishable. Usually one is larger 
\  than the other. 

\  If not, draw an A on one and B on the other. 

\  The key for a message is the initial arrangement of the deck. 
\  There are 54! ways to do this. 

\  A daily Bridge column in a selected newspaper could be used, with 
\  the first two cards played positioning the Jokers. Or an 
\  agreed-upon arrangement could be used, modified by a keyphrase, to 
\  stack the deck. 

\  After stacking the deck, to encipher or decipher each letter of a 
\  message: 

\  1. Find the A-Joker and move it down 1. When the A-Joker is the 
\  bottom card, move it around the top card. 

\  2. Find the B-Joker and move it down 2. When the B-Joker is one of 
\  the two bottom cards, move it around the top card. 

\  3. Exchange the cards above the first occurring Joker with the 
\  cards below the second occurring Joker. 

\  4. Count down and cut using the value in the bottom card. The 
\  bottom card stays put. 

\  5. Count down using the value in the top card. Both jokers count 
\  as `#CARDS`-1. 

\  Take the value of the next card, and add to encrypt or subtract to 
\  decrypt modulo 26 with the letter of the message. 

\  Do all this twice because it's prone to human error. 

\  *******************************************************************
\  *                                                                 *
\  *  NOTE: the Solitaire encryption algorithm is strong             *
\  *  cryptography. That means the security it affords is based      *
\  *  on the secrecy of the key rather than the secrecy of the       *
\  *  algorithm itself.  That also means that this program and       *
\  *  programs derived from it may be treated as a munition for      *
\  *  the purpose of export regulation in the United States and      *
\  *  other countries.  You are encouraged to seek competent         *
\  *  legal counsel before distributing copies of this program.      *
\  *                                                                 *
\  *******************************************************************

\  [The source code for cipher generation has been removed.]

\  *******************************************************************
\  *                         End-User Words                          *
\  *******************************************************************

\  ZAP             ( -- )
\      Put the deck in an unkeyed arrangement.  Here
\      it does the simplest arrangement: 1-54.

\  STACK             ( -- )
\      Use a keyphrase to stack the deck from its
\      unkeyed arrangement.

\  ALICE     ( str len -- )
\      Turn plaintext into ciphertext.

\  BOB       ( str len -- )
\      Turn ciphertext into plaintext.

\  There is environmental dependency on `1 CHARS` is 1.


\  *******************************************************************
\  *                         Implementation                          *
\  *******************************************************************

\  #CARDS    ( -- n )
\      The size of the deck: 54.

\  DECK
\      Work space for the deck: 54 characters as numbers.

\  A-Joker
\      A joker. The "little" one.

\  B-Joker
\      The other joker. The "big" one.

\  Clubs: 1-13.  Diamonds: 14-26.  Hearts: 27-39.  Spades: 40-52.

54 CONSTANT  #CARDS

CREATE DECK  #CARDS ALLOT

#CARDS 1- CONSTANT  A-Joker

#CARDS    CONSTANT  B-Joker

\  CEXCHANGE           ( addr addr -- )
\     Exchange the characters at two addresses. Used in `SREVERSE`.

\  SREVERSE            ( str len -- )
\     Reverse the order of a string of characters. Used in `SROTATE`.

\  SROTATE             ( str len k -- )
\     Rotate a string of characters. `SROTATE` splits a string into
\     two parts, reverses each part, and then reverses the whole
\     string.
\
\     `str len 1 SROTATE` moves the first char to the end.
\
\     `str len DUP 1- SROTATE` moves the last char to the
\      beginning.

    : CEXCHANGE   ( addr addr -- )
        over C@ >R  dup C@ ROT C!  R> SWAP C! ;

    : SREVERSE   ( str len -- )
        1- over +          ( str addr)
        BEGIN  2dup U< WHILE
            2dup CEXCHANGE
            1 /STRING      \  Because 1 CHARS is 1.

        REPEAT  2DROP ;

    : SROTATE   ( str len k -- )
        >R  2dup 2dup R> /STRING  ( s n  s n  s+k n-k)
        dup >R 2SWAP R> -         ( s n  s+k n-k  s k)
        SREVERSE SREVERSE SREVERSE ;

\  Find-the-A-Joker                   ( -- i )
\     Find the position of the A-Joker in the deck.
\     Used in `Move-the-A-Joker-Down-1` and
\     `Exchange-Above-and-Below-Jokers`.

\  Find-the-B-Joker                           ( -- i )
\     Find the position of the B-Joker in the deck.
\     Used in `Move-the-B-Joker-Down-2` and
\     `Exchange-Above-and-Below-Jokers`.

: Find-the-a-Joker   ( -- i )
    #CARDS 0 DO
        I DECK + C@ A-Joker = IF
            I UNLOOP
        EXIT THEN
    LOOP  TRUE ABORT" The A-Joker is missing. " ;

: Find-the-B-Joker   ( -- i )
    #CARDS 0 DO
        I DECK + C@ B-Joker = IF
            I UNLOOP
        EXIT THEN
    LOOP  TRUE ABORT" The B-Joker is missing. " ;

\  Move-the-A-Joker-Down-1  ( -- )
\     Move the A-Joker down 1. When the A-Joker is the bottom
\     card, move it around the top card. Used in `CIPHER` and
\     `STACK`.

\  Move-the-B-Joker-Down-2  ( -- )
\     Move the B-Joker down 2. When the B-Joker is one of the
\     two bottom cards, move it around the top card. Used in
\     `CIPHER` and `STACK`.

\  Exchange-Above-and-Below-Jokers  ( -- )
\     Do a triple cut. The cards above the first occurring joker
\     are exchanged with the cards below the second occurring
\     joker. Used in `CIPHER` and `STACK`.

\  Count-and-Cut-with-Bottom-Card  ( -- )
\     Count down and cut using the value in the bottom card. The
\     bottom card stays put. Used in `CIPHER` and `STACK`.

\  Count-with-Top-Card  ( -- n )
\     Find the output card by counting down using the value in
\     the top card. Both Jokers count as `#CARDS`-1. Used in
\     `CIPHER`.

: Move-the-a-Joker-Down-1   ( -- )
    Find-the-a-Joker          ( i)
    dup #CARDS 1- < IF
        DECK + 2 1 SROTATE
    ELSE  \  A-Joker is at the bottom of the deck.
        DROP DECK #CARDS 1 /STRING dup 1- SROTATE
    THEN  ( ) ;

: Move-the-B-Joker-Down-2   ( -- )
    Find-the-B-Joker          ( i)
    dup #CARDS 2 - < IF
        DECK + 3 1 SROTATE
    ELSE
    #CARDS 1- = IF  \  B-Joker is at bottom.
        DECK #CARDS 2 /STRING dup 1- SROTATE
    ELSE            \  B-Joker is next to bottom.
        DECK #CARDS 1 /STRING 1- dup 1- SROTATE
    THEN THEN ;

: Exchange-Above-and-Below-Jokers   ( -- )
    Find-the-a-Joker  Find-the-B-Joker  ( A B)
    2dup  MAX >R  MIN >R                ( )( R: max min)
    DECK #CARDS R@ /STRING  2R@ - 1+ SROTATE
    DECK #CARDS R> SROTATE  R> DROP ;

: Count-and-Cut-with-Bottom-Card
    DECK #CARDS 1- 2dup + C@ over MIN SROTATE ;

: Count-with-Top-Card   ( -- n )
    DECK C@ #CARDS 1- MIN DECK + C@ ;

\  *******************************************************************
\  *                             CIPHER                              *
\  *******************************************************************

\  CIPHER
\     Finds the next output card in the deck.   ( -- n )
\     The jokers are skipped.

\     Used in:  `ENCIPHER`  `DECIPHER`

\  `CIPHER`  will do the following:

\   * Move the A Joker Down 1
\   * Move the B Joker Down 2
\   * Exchange Above and Below Jokers
\   * Count and Cut with Bottom Card
\   * Count with Top Card
\   * If the next card is a Joker, i.e. > `#CARDS`-2, then
\     skip it and repeat from the beginning

: CIPHER
    \   ###   #####  #   #   ###    ###   ####   #####  ####
    \  #   #  #      #   #  #   #  #   #  #   #  #       #  #
    \  #      #      ##  #  #      #   #  #   #  #       #  #
    \  #      ####   # # #   ###   #   #  ####   ####    #  #
    \  #      #      #  ##      #  #   #  # #    #       #  #
    \  #   #  #      #   #  #   #  #   #  #  #   #       #  #
    \   ###   #####  #   #   ###    ###   #   #  #####  ####
    ;

\  Stack-Cut      ( n -- )
\     Cut the deck according to the next character in
\     the keyphrase.  The bottom card stays put.
\     Used in `STACK`.

\  Is-Alpha        ( char -- flag )
\     Test a character for alphabetic.

\  Alpha>Num       ( char -- n )
\     Convert a letter to a number 1--26.

\  Num>Alpha       ( n -- char )
\     Convert a number 1--78 to a letter.

: Stack-Cut   ( n -- )  DECK #CARDS 1- ROT SROTATE ;
: Is-Alpha    ( char -- flag )  32 OR  [char] a -  26 U< ;
: Alpha>Num   ( char -- n )  32 OR  [char] a 1- - ;
: Num>Alpha   ( n -- char )  1- 26 MOD [char] A + ;

\  COL                 ( -- addr )
\     Counter for columns that have been written.
\     Used in `.CIPHER` and `ZAP`.

\  .CIPHER             ( char -- )
\     Display a character with a space after every
\     five characters. Used in `ENCIPHER` and `DECIPHER`.

\  ENCIPHER            ( char -- )
\     Turn a plaintext character into ciphertext.
\     Used in `ALICE`.

\  DECIPHER            ( char -- )
\     Turn a ciphertext character into plaintext.
\     Used in `BOB`.

\  Now legal.

: CIPHER                                            ( -- n )
    BEGIN
        Move-the-A-Joker-Down-1
        Move-the-B-Joker-Down-2
        Exchange-Above-and-Below-Jokers
        Count-and-Cut-with-Bottom-Card
        Count-with-Top-Card                             ( n)
        dup #CARDS 2 - >
    WHILE  DROP  REPEAT ;

VARIABLE COL

: .CIPHER   ( char -- )
    EMIT  1 COL +!        ( )
    COL @ 1+ 6 MOD 0= IF
        SPACE  1 COL +!
        COL @ 60 = IF  CR  0 COL !  THEN
    THEN ;

: ENCIPHER   ( char -- )
    Alpha>Num CIPHER + 1- 26 MOD 1+ Num>Alpha
    .CIPHER ;

: DECIPHER   ( char -- )
    Alpha>Num CIPHER - 51 + 26 MOD 1+ Num>Alpha 32 OR
    .CIPHER ;

\  *******************************************************************
\  *                    ZAP   STACK   ALICE   BOB                    *
\  *******************************************************************

: ZAP   ( -- )
    #CARDS 0 DO  I 1+  I DECK + C!  LOOP
    0 COL ! ;

: STACK   ( str len -- )
    ZAP
    BEGIN  dup WHILE
        Move-the-a-Joker-Down-1
        Move-the-B-Joker-Down-2
        Exchange-Above-and-Below-Jokers
        Count-and-Cut-with-Bottom-Card
        over C@ Alpha>Num Stack-Cut
        1 /STRING
    REPEAT  2DROP ;

: ALICE   ( str len -- )
    BEGIN  dup WHILE
        over C@ Is-Alpha IF
            over C@ ENCIPHER
        THEN
        1 /STRING
    REPEAT  2DROP
    BEGIN  COL @ 6 MOD WHILE
        [char] X ENCIPHER
    REPEAT ;

: BOB   ( str len -- )
    BEGIN  dup WHILE
        over C@ Is-Alpha IF
            over C@ DECIPHER
        THEN
        1 /STRING
    REPEAT 2DROP ;

MARKER TESTING

: PLAINTEXT:     BL WORD COUNT  PAD 2dup C!  1+ SWAP MOVE ;
: KEY:           BL WORD COUNT over C@ [char] ' = IF
                    1 /STRING 1- STACK
                 ELSE   2DROP  postpone \
                    ZAP
                 THEN ;
: OUTPUT:        postpone \ ;
: CIPHERTEXT:    postpone \   CR  PAD COUNT ALICE ;

Plaintext:  AAAAAAAAAAAAAAA
Key: <null key>
Output: 4 49 10 53 24 8 51 44 6 4 33 20 39 19 34 42
Ciphertext: EXKYI ZSGEH UNTIQ

Plaintext:  AAAAAAAAAAAAAAA
Key: 'f'
Output: 49 24 8 46 16 1 12 33 10 10 9 27 4 32 24
Ciphertext: XYIUQ BMHKK JBEGY

Plaintext: AAAAAAAAAAAAAAA
Key: 'fo'
Output:  19 46 9 24 12 1 4 43 11 32 23 39 29 34 22
Ciphertext:  TUJYM BERLG XNDIW

Plaintext: AAAAAAAAAAAAAAA
Key: 'foo'
Output: 8 19 7 25 20 53 9 8 22 32 43 5 26 17 53 38 48
Ciphertext: ITHZU JIWGR FARMW

Plaintext:  AAAAAAAAAAAAAAA
Key:  'a'
Output:  49 14 3 26 11 32 18 2 46 37 34 42 13 18 28
Ciphertext:  XODAL GSCUL IQNSC


Plaintext:  AAAAAAAAAAAAAAA
Key: 'aa'
Output:  14 7 32 22 38 23 23 2 26 8 12 2 34 16 15
Ciphertext:  OHGWM XXCAI MCIQP

Plaintext:  AAAAAAAAAAAAAAA
Key: 'aaa'
Output:  3 28 18 42 24 33 1 16 51 53 39 6 29 43 46 45
Ciphertext: DCSQY HBQZN GDRUT

Plaintext:  AAAAAAAAAAAAAAA
Key: 'b'
Output:  49 16 4 30 12 40 8 19 37 25 47 29 18 16 18
Ciphertext:  XQEEM OITLZ VDSQS

Plaintext:  AAAAAAAAAAAAAAA
Key:  'bc'
Output:  16 13 32 17 10 42 34 7 2 37 6 48 44 28 53 4
Ciphertext:  QNGRK QIHCL GWSCE

Plaintext:  AAAAAAAAAAAAAAA
Key:  'bcd'
Output:  5 38 20 27 50 1 38 26 49 33 39 42 49 2 35
Ciphertext:  FMUBY BMAXH NQXCJ

Plaintext:  AAAAAAAAAAAAAAAAAAAAAAAAA
Key: 'cryptonomicon'
Ciphertext:  SUGSR SXSWQ RMXOH IPBFP XARYQ

Plaintext: SOLITAIRE
Key:  'cryptonomicon'
Ciphertext:  KIRAK SFJAN

( END ) TESTING

\  *******************************************************************
\  *                                                                 *
\  *              Eight Kings                                        *
\  *                                                                 *
\  *  The following is a version of ZAP that arranges the deck in    *
\  *  Eight Kings sequence.                                          *
\  *                                                                 *
\  *  Eight-Kings     	( -- addr )                                  *
\  *     The pattern for the Eight Kings card sequence:              *
\  *                                                                 *
\  *     Eight kings threaten to save 95 queens for one sick knave.  *
\  *                                                                 *
\  *  ZAP            		( -- )                                   *
\  *     Initialize the deck to the Eight Kings card sequence.       *
\  *                                                                 *
\  *******************************************************************

CREATE Eight-Kings
    8 C, 13 C, 3 C, 10 C, 2 C, 7 C,
    9 C, 5 C, 12 C, 4 C, 1 C, 6 C, 10 C,

: ZAP   			( -- )
    DECK 52 0 DO
        I 13 MOD Eight-Kings + C@
        I 4 MOD 13 * +
        OVER C! 1+
    LOOP
    53 OVER C! 1+  54 SWAP C! ;

\\   //   \\   //   \\   //   \\   //   \\   //   \\   //   \\   //   \\