ANEW --FIPS181-DES--

\  *******************************************************************
\  *                                                                 *
\  *                 Data Eencryption Standard                       *
\  *                                                                 *
\  *******************************************************************
     
\                                                Wil Baden  2004-02-09
\
\  Here is my first pass at DES. 
\
\  Not dependent on cell size, although 1 byte per char is presumed.

\  DES                                                    VERSION 4.00
\
\           D A T A   E N C R Y P T I O N   S T A N D A R D
\           FEDERAL INFORMATION PROCESSING STANDARDS PUBLICATION 46-1

\  This software was produced at the National Institute of Standards 
\  and Techology (NIST) as a part of research efforts and for 
\  demonstration purposes only. Our primary goals in its design did 
\  not include widespread use outside of our own laboratories. 
\  Acceptance of this software implies that you agree to accept it as 
\  nonproprietary and unlicensed, not supported by NIST, and not 
\  carrying any warranty, either expressed or implied, as to its 
\  performance or fitness for any particular purpose. 

\  Cryptographic devices and technical data regarding them are 
\  subject to Federal Government export controls as specified in 
\  Title 22, Code of Federal Regulations, Parts 121 through 128.  
\  Cryptographic devices implementing the Data Encryption Standard 
\  (DES) and technical data regarding them must comply with these 
\  Federal regulations. 

\  Forth transcription by Wil Baden  2002-01-08.
\  R'@ fixed 2004-02-09.  Thanks to M. Gassanenko via John Peters.

\   AC-Cipher        Des-Pre-S        OOPS             RFP
\   AC-Plain         DESCALL          P                S-Box
\   AC-Validation    Descall-Key      PACK8            Set-Parity
\   ANSWER           Descall-Out      PAIR2            SETKEY
\   BYTNCPY          E                PC1              SHIFTS
\   BYTNXOR          ENCRYPT0         PC2              SINGLE1
\   CD               HAC-Decipher     PKEYLEN          Stinson-Cipher
\   DAYTIME          HAC-Encipher     Ran-Dt           Stinson-Key
\   DECRYPT1         Hex-Type         Ran-I            Stinson-Plain
\   DES              IGNORE0          Ran-J            Stinson-Validation
\   Des-Block        IP               Ran-Key          Temp-Key
\   Des-F            KRYPT            Ran-R            Unpacked-Key
\   Des-Key          Krypt-Validation  Ran-Seed
\   Des-Lr           KS               RANDOM

\  Comment out definitions that already exist.
\  Change `TRUE 0<>` to `TRUE 0=` to comment out all.

TRUE 0<> [IF]  \  Comment out redundant definitions.

    : 3DROP      2DROP DROP ;     \  Should be code definition.
    : ANDIF      S" dup IF DROP " EVALUATE ; IMMEDIATE
    : BEEP       7 EMIT ;         \  Or : BEEP ; IMMEDIATE
    : BOUNDS     over + SWAP ;
    : BUFFER:    CREATE ALLOT ;
    : third      2 PICK ;         \  Should be code definition.
    : fourth     3 PICK ;         \  Should be code definition.
    : R'@        S" 2R@ DROP " EVALUATE ; IMMEDIATE \  Should be code definition.

[THEN]

\  UNPACK8                        ( from to -- )
\     Unpack 8 bytes at 8 bits/byte into 64 bytes at 1 bit/byte.
\
\  PACK8                          ( to from -- )
\     Pack 64 bytes at 1 bit/byte into 8 bytes at 8 bits/byte.

    : C!++  ( addr char -- addr+1 )  over C!  CHAR+ ;

: UNPACK8                      ( from to -- )
    SWAP 8 BOUNDS DO                      ( to)
        0 7 DO
            J C@  I RSHIFT  1 AND  C!++
        -1 +LOOP
    LOOP  DROP ;

    : C@++  ( addr -- addr+1 char )  dup CHAR+ SWAP  C@ ;

: PACK8                        ( to from -- )
    over 8 ERASE
    SWAP 8 BOUNDS DO                           ( from)
        0 7 DO
            C@++  I LSHIFT  J C@  OR  J C!
        -1 +LOOP
    LOOP DROP ;

\  SETKEY                         ( sw1 sw2 pkey -- flag )
\     Generate key schedule for given key and type of cryption.
\     sw1  -- parity: 0=ignore,1=check.
\     sw2  -- type cryption: 0=encrypt,1=decrypt.
\     pkey -- 64-bit key packed into 8 bytes.
\
\     Double-check 'parity' parameter.
\     Double-check 'type of cryption' parameter.
\     Unpack KEY from 8 bits/byte into 1 bit/byte.
\     Check for ODD key parity.
\     Permute unpacked key with PC1 to generate C and D.
\     Rotate and permute C and D to generate 16 subkeys.
\         Rotate C and D.
\         Set order of subkeys for type of cryption.
\         Permute C and D with PC2 to generate KS[][].

    \  PERMUTED CHOICE 1 (PC1)
    CREATE PC1
        57 C, 49 C, 41 C, 33 C, 25 C, 17 C,  9 C,
         1 C, 58 C, 50 C, 42 C, 34 C, 26 C, 18 C,
        10 C,  2 C, 59 C, 51 C, 43 C, 35 C, 27 C,
        19 C, 11 C,  3 C, 60 C, 52 C, 44 C, 36 C,
        63 C, 55 C, 47 C, 39 C, 31 C, 23 C, 15 C,
         7 C, 62 C, 54 C, 46 C, 38 C, 30 C, 22 C,
        14 C,  6 C, 61 C, 53 C, 45 C, 37 C, 29 C,
        21 C, 13 C,  5 C, 28 C, 20 C, 12 C,  4 C,

    \  Schedule of left shifts for C and D blocks.
    CREATE Shifts
         1 C, 1 C, 2 C, 2 C, 2 C, 2 C, 2 C, 2 C,
         1 C, 2 C, 2 C, 2 C, 2 C, 2 C, 2 C, 1 C,

    \  PERMUTED CHOICE 2 (PC2)
    CREATE PC2
        14 C, 17 C, 11 C, 24 C,  1 C,  5 C,
         3 C, 28 C, 15 C,  6 C, 21 C, 10 C,
        23 C, 19 C, 12 C,  4 C, 26 C,  8 C,
        16 C,  7 C, 27 C, 20 C, 13 C,  2 C,
        41 C, 52 C, 31 C, 37 C, 47 C, 55 C,
        30 C, 40 C, 51 C, 45 C, 33 C, 48 C,
        44 C, 49 C, 39 C, 56 C, 34 C, 53 C,
        46 C, 42 C, 50 C, 36 C, 29 C, 32 C,

    \  Key schedule of 16 48-bit subkeys generated from 64-bit key.
    48 16 * chars BUFFER:  KS

    64 chars BUFFER:  Unpacked-Key
    56 chars BUFFER:  CD

: SETKEY                         ( sw1 sw2 pkey -- flag )

    \  Double-check 'parity' parameter.
    third 0<> ANDIF over 1 <> THEN IF
        CR BEEP ." *** SETKEY: bad parity parameter "
            third .  ." ***"  CR
        3DROP  FALSE
    EXIT THEN

    \  Double-check 'type of cryption' parameter.
    over 0<> ANDIF over 1 <> THEN IF
        CR BEEP ." *** SETKEY: bad cryption parameter "
            over .  ." ***"  CR
        3DROP  FALSE
    EXIT THEN

    \  Unpack KEY from 8 bits/byte into 1 bit/byte.
    dup Unpacked-Key UNPACK8

    \  Check for ODD key parity.
    third 1 = IF
        1 64 0 DO       ( . . . parity)
            I Unpacked-Key + C@ XOR
            I 7 AND 7 = IF
                0<> IF  ( . . .)
                    3DROP FALSE
                    UNLOOP
                EXIT THEN
                1       ( . . . parity)
            THEN
        LOOP DROP       ( sw1 sw2 pkey)
    THEN

    \  Permute unpacked key with PC1 to generate C and D.
    56 0 DO
        I PC1 + C@  1-  Unpacked-Key + C@  I CD + C!
    LOOP

    \  Rotate and permute C and D to generate 16 subkeys.
    16 0 DO
        \  Rotate C and D.
        I Shifts + C@ 0 DO
            CD  C@  >R
            CD 1+  CD  27  MOVE
            R>  CD 27 +  C!
            CD 28 +  C@  >R
            CD 29 +  CD 28 +  27  MOVE
            R>  CD 55 +  C!
        LOOP                          ( . sw2 .)
        \  Set order of subkeys for type of cryption.
        over IF  15 I -  ELSE  I  THEN
            48 *  KS +                ( . . . addr)
        \  Permute C and D with PC2 to generate KS[][].
        48 0 DO
            I PC2 + C@  1-  CD + C@  over I +  C!
        LOOP DROP                     ( . . .)
    LOOP

    3DROP  TRUE ;

\  DES                            ( in out -- )
\     in -- packed 64-bit INPUT block.
\     out -- packed 64-bit OUTPUT block.
\
\     Unpack the INPUT block.
\     Permute unpacked input block with IP to generate L and R.
\     Perform 16 rounds.
\         Expand R to 48 bits with E and XOR with subkey.
\         Map 8 6-bit blocks into 8 4-bit blocks using S-Boxes.
\             Compute index t into i-th S-box.
\             Fetch t-th entry from i-th S-box.
\             Generate 4-bit block from S-box entry.
\             Copy R.
\             Permute F with P and XOR with L to generate new R.
\             Copy original R to new L.
\     Permute L and R with reverse IP-1 to generate output block.
\     Pack data into 8 bits per byte.

    \  INITIAL PERMUTATION (IP)
    CREATE  IP
        58 C, 50 C, 42 C, 34 C, 26 C, 18 C, 10 C,  2 C,
        60 C, 52 C, 44 C, 36 C, 28 C, 20 C, 12 C,  4 C,
        62 C, 54 C, 46 C, 38 C, 30 C, 22 C, 14 C,  6 C,
        64 C, 56 C, 48 C, 40 C, 32 C, 24 C, 16 C,  8 C,
        57 C, 49 C, 41 C, 33 C, 25 C, 17 C,  9 C,  1 C,
        59 C, 51 C, 43 C, 35 C, 27 C, 19 C, 11 C,  3 C,
        61 C, 53 C, 45 C, 37 C, 29 C, 21 C, 13 C,  5 C,
        63 C, 55 C, 47 C, 39 C, 31 C, 23 C, 15 C,  7 C,

    \  REVERSE FINAL PERMUTATION (IP-1)
    CREATE  RFP
         8 C, 40 C, 16 C, 48 C, 24 C, 56 C, 32 C, 64 C,
         7 C, 39 C, 15 C, 47 C, 23 C, 55 C, 31 C, 63 C,
         6 C, 38 C, 14 C, 46 C, 22 C, 54 C, 30 C, 62 C,
         5 C, 37 C, 13 C, 45 C, 21 C, 53 C, 29 C, 61 C,
         4 C, 36 C, 12 C, 44 C, 20 C, 52 C, 28 C, 60 C,
         3 C, 35 C, 11 C, 43 C, 19 C, 51 C, 27 C, 59 C,
         2 C, 34 C, 10 C, 42 C, 18 C, 50 C, 26 C, 58 C,
         1 C, 33 C,  9 C, 41 C, 17 C, 49 C, 25 C, 57 C,

    \  E BIT-SELECTION TABLE
    CREATE  E
        32 C,  1 C,  2 C,  3 C,  4 C,  5 C,  4 C,  5 C,
         6 C,  7 C,  8 C,  9 C,  8 C,  9 C, 10 C, 11 C,
        12 C, 13 C, 12 C, 13 C, 14 C, 15 C, 16 C, 17 C,
        16 C, 17 C, 18 C, 19 C, 20 C, 21 C, 20 C, 21 C,
        22 C, 23 C, 24 C, 25 C, 24 C, 25 C, 26 C, 27 C,
        28 C, 29 C, 28 C, 29 C, 30 C, 31 C, 32 C,  1 C,

    \  PERMUTATION FUNCTION P
    CREATE  P
        16 C,  7 C, 20 C, 21 C, 29 C, 12 C, 28 C, 17 C,
         1 C, 15 C, 23 C, 26 C,  5 C, 18 C, 31 C, 10 C,
         2 C,  8 C, 24 C, 14 C, 32 C, 27 C,  3 C,  9 C,
        19 C, 13 C, 30 C,  6 C, 22 C, 11 C,  4 C, 25 C,

    \  8 S-BOXES
    CREATE  S-Box
        14 C,  4 C, 13 C,  1 C,  2 C, 15 C, 11 C,  8 C,
         3 C, 10 C,  6 C, 12 C,  5 C,  9 C,  0 C,  7 C,
         0 C, 15 C,  7 C,  4 C, 14 C,  2 C, 13 C,  1 C,
        10 C,  6 C, 12 C, 11 C,  9 C,  5 C,  3 C,  8 C,
         4 C,  1 C, 14 C,  8 C, 13 C,  6 C,  2 C, 11 C,
        15 C, 12 C,  9 C,  7 C,  3 C, 10 C,  5 C,  0 C,
        15 C, 12 C,  8 C,  2 C,  4 C,  9 C,  1 C,  7 C,
         5 C, 11 C,  3 C, 14 C, 10 C,  0 C,  6 C, 13 C,

        15 C,  1 C,  8 C, 14 C,  6 C, 11 C,  3 C,  4 C,
         9 C,  7 C,  2 C, 13 C, 12 C,  0 C,  5 C, 10 C,
         3 C, 13 C,  4 C,  7 C, 15 C,  2 C,  8 C, 14 C,
        12 C,  0 C,  1 C, 10 C,  6 C,  9 C, 11 C,  5 C,
         0 C, 14 C,  7 C, 11 C, 10 C,  4 C, 13 C,  1 C,
         5 C,  8 C, 12 C,  6 C,  9 C,  3 C,  2 C, 15 C,
        13 C,  8 C, 10 C,  1 C,  3 C, 15 C,  4 C,  2 C,
        11 C,  6 C,  7 C, 12 C,  0 C,  5 C, 14 C,  9 C,

        10 C,  0 C,  9 C, 14 C,  6 C,  3 C, 15 C,  5 C,
         1 C, 13 C, 12 C,  7 C, 11 C,  4 C,  2 C,  8 C,
        13 C,  7 C,  0 C,  9 C,  3 C,  4 C,  6 C, 10 C,
         2 C,  8 C,  5 C, 14 C, 12 C, 11 C, 15 C,  1 C,
        13 C,  6 C,  4 C,  9 C,  8 C, 15 C,  3 C,  0 C,
        11 C,  1 C,  2 C, 12 C,  5 C, 10 C, 14 C,  7 C,
         1 C, 10 C, 13 C,  0 C,  6 C,  9 C,  8 C,  7 C,
         4 C, 15 C, 14 C,  3 C, 11 C,  5 C,  2 C, 12 C,

         7 C, 13 C, 14 C,  3 C,  0 C,  6 C,  9 C, 10 C,
         1 C,  2 C,  8 C,  5 C, 11 C, 12 C,  4 C, 15 C,
        13 C,  8 C, 11 C,  5 C,  6 C, 15 C,  0 C,  3 C,
         4 C,  7 C,  2 C, 12 C,  1 C, 10 C, 14 C,  9 C,
        10 C,  6 C,  9 C,  0 C, 12 C, 11 C,  7 C, 13 C,
        15 C,  1 C,  3 C, 14 C,  5 C,  2 C,  8 C,  4 C,
         3 C, 15 C,  0 C,  6 C, 10 C,  1 C, 13 C,  8 C,
         9 C,  4 C,  5 C, 11 C, 12 C,  7 C,  2 C, 14 C,

         2 C, 12 C,  4 C,  1 C,  7 C, 10 C, 11 C,  6 C,
         8 C,  5 C,  3 C, 15 C, 13 C,  0 C, 14 C,  9 C,
        14 C, 11 C,  2 C, 12 C,  4 C,  7 C, 13 C,  1 C,
         5 C,  0 C, 15 C, 10 C,  3 C,  9 C,  8 C,  6 C,
         4 C,  2 C,  1 C, 11 C, 10 C, 13 C,  7 C,  8 C,
        15 C,  9 C, 12 C,  5 C,  6 C,  3 C,  0 C, 14 C,
        11 C,  8 C, 12 C,  7 C,  1 C, 14 C,  2 C, 13 C,
         6 C, 15 C,  0 C,  9 C, 10 C,  4 C,  5 C,  3 C,

        12 C,  1 C, 10 C, 15 C,  9 C,  2 C,  6 C,  8 C,
         0 C, 13 C,  3 C,  4 C, 14 C,  7 C,  5 C, 11 C,
        10 C, 15 C,  4 C,  2 C,  7 C, 12 C,  9 C,  5 C,
         6 C,  1 C, 13 C, 14 C,  0 C, 11 C,  3 C,  8 C,
         9 C, 14 C, 15 C,  5 C,  2 C,  8 C, 12 C,  3 C,
         7 C,  0 C,  4 C, 10 C,  1 C, 13 C, 11 C,  6 C,
         4 C,  3 C,  2 C, 12 C,  9 C,  5 C, 15 C, 10 C,
        11 C, 14 C,  1 C,  7 C,  6 C,  0 C,  8 C, 13 C,

         4 C, 11 C,  2 C, 14 C, 15 C,  0 C,  8 C, 13 C,
         3 C, 12 C,  9 C,  7 C,  5 C, 10 C,  6 C,  1 C,
        13 C,  0 C, 11 C,  7 C,  4 C,  9 C,  1 C, 10 C,
        14 C,  3 C,  5 C, 12 C,  2 C, 15 C,  8 C,  6 C,
         1 C,  4 C, 11 C, 13 C, 12 C,  3 C,  7 C, 14 C,
        10 C, 15 C,  6 C,  8 C,  0 C,  5 C,  9 C,  2 C,
         6 C, 11 C, 13 C,  8 C,  1 C,  4 C, 10 C,  7 C,
         9 C,  5 C,  0 C, 15 C, 14 C,  2 C,  3 C, 12 C,

        13 C,  2 C,  8 C,  4 C,  6 C, 15 C, 11 C,  1 C,
        10 C,  9 C,  3 C, 14 C,  5 C,  0 C, 12 C,  7 C,
         1 C, 15 C, 13 C,  8 C, 10 C,  3 C,  7 C,  4 C,
        12 C,  5 C,  6 C, 11 C,  0 C, 14 C,  9 C,  2 C,
         7 C, 11 C,  4 C,  1 C,  9 C, 12 C, 14 C,  2 C,
         0 C,  6 C, 10 C, 13 C, 15 C,  3 C,  5 C,  8 C,
         2 C,  1 C, 14 C,  7 C,  4 C, 10 C,  8 C, 13 C,
        15 C, 12 C,  9 C,  0 C,  3 C,  5 C,  6 C, 11 C,

    64 chars BUFFER:  DES-Block  \  Unpacked 64-bit input/output block.
    64 chars BUFFER:  DES-LR
    32 chars BUFFER:  DES-F
    48 chars BUFFER:  DES-Pre-S

: DES                            ( in out -- )

    \  Unpack the INPUT block.
    over DES-Block UNPACK8

    \  Permute unpacked input block with IP to generate L and R.
    64 0 DO
        I IP + C@  1-  DES-Block + C@  I DES-LR + C!
    LOOP

    \  Perform 16 rounds.
    KS  48 16 *  BOUNDS DO
        \  Expand R to 48 bits with E and XOR with subkey.
        48 0 DO
            I E + C@  31 +  DES-LR + C@  I J + C@  XOR  I DES-Pre-S + C!
        LOOP
        \  Map 8 6-bit blocks into 8 4-bit blocks using S-Boxes.
        8 0 DO
            \  Compute index t into i-th S-box.
            I 6 * >R                                 ( R: k)
            R@ DES-Pre-S + C@                  ( . . t)
            2*  R@ 5 +  DES-Pre-S + C@  OR
            2*  R@ 1 +  DES-Pre-S + C@  OR
            2*  R@ 2 +  DES-Pre-S + C@  OR
            2*  R@ 3 +  DES-Pre-S + C@  OR
            2*  R> 4 +  DES-Pre-S + C@  OR           ( R: )
            \  Fetch t-th entry from i-th S-box.
            I 64 * + S-Box + C@
            \  Generate 4-bit block from S-box entry.
            I 4 * >R                                 ( R: k)
            dup  3 RSHIFT  1 AND  R@ DES-F + C!
            dup  2 RSHIFT  1 AND  R@ 1+ DES-F + C!
            dup  1 RSHIFT  1 AND  R@ 2 + DES-F + C!
            1 AND  R> 3 + DES-F + C!           ( . .)( R: )
        LOOP
        32 0 DO
            \  Copy R.
            I 32 + DES-LR + C@
            \  Permute F with P and XOR with L to generate new R.
            I DES-LR + C@   I P + C@  1-  DES-F + C@  XOR
                I 32 + DES-LR + C!
            \  Copy original R to new L.
            I DES-LR + C!
         LOOP
    48 +LOOP

    \  Permute L and R with reverse IP-1 to generate output block.
    64 0 DO
        I RFP + C@  1-  DES-LR + C@
            I DES-Block + C!
    LOOP

    \  Pack data into 8 bits per byte.
    dup DES-Block PACK8

    2DROP ;

1 CONSTANT  DECRYPT1
0 CONSTANT  ENCRYPT0

1 CONSTANT SINGLE1
2 CONSTANT PAIR2

0 CONSTANT IGNORE0
8 CONSTANT PKEYLEN

\  KRYPT                 ( sw1 sw2  sw3 kek  sw4 ikey  okey -- flag )
\     Encrypt/decrypt key or key pair.
\     sw1  -- ODD parity: 0=ignore, 1=check & report
\     sw2  -- type of cryption: 0=encrypt, 1=decrypt
\     sw3  -- length of kek: 1=single, 2=pair
\     kek  -- packed key-encrypting key
\     sw4  -- length of key: 1=single, 2=pair
\     ikey -- packed input key
\     okey -- packed output key

    PKEYLEN chars BUFFER:  Temp-Key

: KRYPT  ( sw1 sw2 sw3 kek sw4 ikey okey -- flag )

    \  DOUBLE-CHECK PARAMETERS.

    4 PICK ( sw3) SINGLE1 =  ANDIF  third ( sw4) PAIR2 =  THEN
    	IF  ABORT  THEN

    ROT                            ( . . . . ikey okey sw4)
    dup SINGLE1 <>  ANDIF  dup PAIR2 <>  THEN  IF
        ." KRYPT: bad key length "  dup .
        ABORT
    THEN

    >R 2>R                         ( sw1 sw2 sw3 kek)( R: sw4 ikey okey)

    over SINGLE1 <>  ANDIF  over PAIR2 <>  THEN  IF
        ." KRYPT: bad kek length "  over .
        ABORT
    THEN

    fourth fourth third            ( . . . . sw1 sw2 kek)
    SETKEY 0= IF
        2DROP 2DROP  2R> 2DROP  R> DROP  FALSE ( false)
    EXIT THEN                      ( sw1 sw2 sw3 kek)

    2R@ ( ikey okey) DES

    R> 2R> SWAP 2>R >R                ( R: ikey sw4 okey)
    over SINGLE1 =  R'@ SINGLE1 = AND IF  \  Single by single.
        2DROP 2DROP  2R> 2DROP  R> DROP  TRUE
    EXIT THEN

    fourth  fourth 01 XOR  third PKEYLEN +  SETKEY 0= IF
        2DROP 2DROP  2R> 2DROP  R> DROP  FALSE
    EXIT THEN

    R@ Temp-Key DES

    fourth fourth third SETKEY DROP
    Temp-Key R@ DES

    R'@ SINGLE1 = IF                    \  Single by double.
        2DROP 2DROP  2R> 2DROP  R> DROP  TRUE
    EXIT THEN

    NIP PAIR2 SWAP  SINGLE1  R>  2R> DROP  PKEYLEN +  SWAP PKEYLEN +
        RECURSE DROP                 ( )

    TRUE ;

\  BYTNCPY                        ( dest source len -- dest )
\     Copy block of packed BYTEs.
\
\  BYTNXOR                        ( dest src1 src2 len -- dest )
\     XOR blocks of packed BYTEs.
\
\  DAYTIME                        ( dt -- )
\     dt[8] = 64-bit block based on date & time.
\
\  SET-PARITY                     { key len/8 -- )
\     Set ODD parity.

: BYTNCPY                      ( dest source len -- dest )
    ROT dup >R SWAP ( source dest len) MOVE R> ;

: BYTNXOR                      ( dest src1 src2 len -- dest )
    fourth >R
    BOUNDS ?DO                 ( dest src1)
        I C@                   ( dest src1 byte)
        SWAP dup >R C@ XOR     ( dest byte)
        over C!                ( dest)
        CHAR+  R> CHAR+        ( dest src1)
    LOOP 2DROP                 ( )
    R> ;

: DAYTIME                      ( dt -- )
    >R  0 0 TIME&DATE 1900 -  R>  8 0 DO
        TUCK  C!  CHAR+
    	LOOP DROP ;

: Set-Parity                   ( key len/8 -- )
    3 LSHIFT BOUNDS DO
        I C@
        dup 4 RSHIFT XOR
        dup 2 RSHIFT XOR
        dup 1 RSHIFT XOR
        1 AND 0= IF  I C@  128 XOR  I C!  THEN
    LOOP ;

\  RANDOM                   ( dest odd -- )
\     Pseudorandom KEY and IV Generator.
\     dest -- destination for random KEY or IV
\     odd  -- generate ODD parity? 0=no, 1=yes

\  Random Key

CREATE Ran-Key
    HEX
    0E0 C, 09A C, 0A8 C, 00F C, 0AB C, 072 C, 01C C, 03D C,
    08F C, 07D C, 0C9 C, 09E C, 08F C, 002 C, 0B6 C, 02A C,
    DECIMAL

\  Ran-Seed

CREATE Ran-Seed
    HEX
    0CF C, 065 C, 0AE C, 07F C, 0B1 C, 079 C, 0BB C, 0E3 C,
    DECIMAL

    PKEYLEN BUFFER:  Ran-Dt  \  date/time vector
    PKEYLEN BUFFER:  Ran-I
    PKEYLEN BUFFER:  Ran-J
    PKEYLEN BUFFER:  Ran-R

: RANDOM                   ( dest odd -- )

	\  DOUBLE-CHECK PARAMETERS.
	dup  ANDIF  dup TRUE <>  ANDIF  dup 1 <>  THEN THEN  IF
		CR ." RANDOM: bad generate parity option "  dup .
		ABORT
	THEN

    \  Get date/time vector.
    Ran-Dt DAYTIME

    \  I = encrypt(DT)
    IGNORE0 ENCRYPT0 PAIR2 Ran-Key SINGLE1 Ran-Dt Ran-I KRYPT DROP

    \  R = encrypt(I xor V)
    Ran-J Ran-I Ran-Seed PKEYLEN BYTNXOR DROP
    IGNORE0 ENCRYPT0 PAIR2 Ran-Key SINGLE1 Ran-J Ran-R KRYPT DROP

    \  new seed = encrypt(R xor I)
    Ran-J Ran-I Ran-R PKEYLEN BYTNXOR DROP
    IGNORE0 ENCRYPT0 PAIR2 Ran-Key SINGLE1 Ran-J Ran-Seed KRYPT DROP

    \  GENERATE ODD PARITY, IF NEEDED.
    dup IF  Ran-R SINGLE1 Set-Parity  THEN

    over Ran-R PKEYLEN BYTNCPY DROP

    2DROP ;

\  ANSWER                        ( out n -- ans )
\     ANSWER takes the array out and creates sum by adding certain values
\     within the array together. To get a number from 0 to n-1, it returns
\     sum mod n (sum%n).

: ANSWER                        ( out n -- ans )
   \  Every time this function is called, it adds the first three
   \  positions of out to get sum.

    >R  dup C@  over 1+ C@  +  SWAP 2 + C@  +  R>  MOD ;

\  DESCALL                        ( password n -- ans )
\     DESCALL calls the pseudorandom key generator, RANDOM, described in
\     Appendix C of ANSI 9.17 and puts the resulting value into the array
\     Descall-Key The arguments of RANDOM indicate that odd parity should
\     be generated and that the input string is eight bytes in length. The
\     DES routine, which uses Descall-Key and the old password as
\     arguments, is then called. The output from DES, Descall-Out is then
\     sent to the routine, ANSWER, for processing.

    8 chars BUFFER:  Descall-Key
    8 chars BUFFER:  Descall-Out

: DESCALL                        ( password n -- ans )
    Descall-Key 1 RANDOM
    0 0 Descall-Key SETKEY DROP
    SWAP Descall-Out DES             ( n)
    Descall-Out SWAP ANSWER          ( ans)
    ;

\                                              Wil Baden  2002-01-15
\
\          TESTING

\  HEX-TYPE  ( addr len -- )  Display a byte array in hex.

: Hex-Type             ( addr len -- )
    BASE @ >R  HEX
    BOUNDS ?DO                     ( )
        I C@  0 <# # # #> TYPE
    LOOP
    R> BASE ! ;

: OOPS ABORT" Uh-Oh " ;

CREATE  DES-Key
    HEX 001 C, 023 C, 045 C, 067 C, 089 C, 0AB C, 0CD C, 0EF C, DECIMAL

\  Test vectors from _Handbook of Applied Cryptography_, Menezes et al.

: HAC-Encipher                 ( -- )
    CR ." \ 3FA40E8A984D4815 6A271787AB8883F9 893D51EC4B563B53 should be "
    CR ." \ "
    0 ENCRYPT0 DES-Key SETKEY 0= OOPS
    S" Now is the time for all " 0 DO  ( addr)
        \  ECB Electronic Code Book Mode.
        dup I +  PAD I +  DES
        PAD I +  8  Hex-Type SPACE
    8 +LOOP DROP ;

: HAC-Decipher                 ( -- )
    CR ." \ Now is the time for all  should be "
    CR ." \ "
    1 DECRYPT1 DES-Key SETKEY 0= OOPS
    PAD 24 BOUNDS DO
        \  ECB Electronic Code Book Mode.
        I  PAD 24 + DES
        PAD 24 +  8  TYPE
    8 +LOOP ;

HAC-Encipher  HAC-Decipher

\  Validation Set from _Applied Cryptography_, Schneier.

CREATE AC-Plain
    HEX 001 C, 023 C, 045 C, 067 C, 089 C, 0AB C, 0CD C, 0E7 C, DECIMAL

CREATE AC-Cipher
    HEX 0C9 C, 057 C, 044 C, 025 C, 06A C, 05E C, 0D3 C, 01D C, DECIMAL

: AC-Validation                ( -- )
    CR ." \ C95744256A5ED31D 0123456789ABCDE7 should be "
    CR ." \ "
    0 ENCRYPT0 DES-Key SETKEY 0= OOPS
    AC-Plain PAD DES
    PAD 8 Hex-Type
    SPACE
    1 DECRYPT1 DES-Key SETKEY 0= OOPS
    AC-Cipher PAD DES
    PAD 8 Hex-Type
    ;

AC-Validation

: Krypt-Validation                ( -- )
    CR ." \ C95744256A5ED31D 0123456789ABCDE7 should be "
    CR ." \ "
    0 ENCRYPT0 SINGLE1 DES-Key SINGLE1 AC-Plain PAD KRYPT DROP
    PAD 8 Hex-Type
    SPACE
    1 DECRYPT1 SINGLE1 DES-Key SINGLE1 AC-Cipher PAD KRYPT DROP
  	PAD 8 Hex-Type
    ;

Krypt-Validation

CREATE  Stinson-Key
	HEX
	013 C, 034 C, 057 C, 079 C, 09B C, 0BC C, 0DF C, 0F1 C,
	DECIMAL

CREATE  Stinson-Plain
	HEX
	001 C, 023 C, 045 C, 067 C, 089 C, 0AB C, 0CD C, 0EF C,
	DECIMAL

CREATE  Stinson-Cipher
	HEX
	085 C, 0E8 C, 013 C, 054 C, 00F C, 00A C, 0B4 C, 005 C,
	DECIMAL

: Stinson-Validation                ( -- )
    CR ." \ 85E813540F0AB405 0123456789ABCDEF should be "
    CR ." \ "
    0 ENCRYPT0 SINGLE1 Stinson-Key SINGLE1 Stinson-Plain PAD KRYPT DROP
    PAD 8 Hex-Type
    SPACE
    1 DECRYPT1 SINGLE1 Stinson-Key SINGLE1 Stinson-Cipher PAD KRYPT DROP
  	PAD 8 Hex-Type
    ;

Stinson-Validation

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