{
  Visit www.counterpane.com/solitaire.html for details!
  solitaire concept by Bruce Schneier (counterpane)
  programming in Pascal by Dave Boschma (Borland TP7 used for testing) 
}

program solitair;
uses dos,crt;
const JokerA   = 53;
      JokerB   = 54;

var deck      : array[1..54] of shortint;
    keystream : array[1..255] of shortint;
    message   : string[255];
    key       : string[255];

function mod26 (input : shortint) : shortint;
begin
  repeat
    if (input < 1) then input := input + 26;
    if (input > 26) then input := input - 26;
  until (input >= 1) and (input <= 26);
  mod26 := input;
end;

function char2sint(ch : char) : shortint;
begin
  if (upcase(ch) >= upcase('A')) and (upcase(ch) <= upcase('Z'))
  then char2sint := ord(upcase(ch))-ord(upcase('A'))+1
  else if (ch = ' ') then char2sint := 32
       else begin writeln('Error! A non-letter was found: '+ch); halt(1); end;
end;

function sint2char(input : shortint) : char;
begin
  if (input < 1) or (input > 26) then input := mod26(input);
  sint2char := chr(ord('A') + input - 1);
end;

procedure movedown(card : shortint);
var place : shortint;
    dumpint : shortint;
begin
  {step 1: find card}
  place := 1;
  while (deck[place] <> card) do inc(place);
  if place = 54 then
  {step 2a: card is last card: place behind first}
  begin
    for dumpint := 53 downto 2 do
      deck[dumpint+1] := deck[dumpint];
    deck[2] := card;
  end
  {step 2b: card is not last card: move card down one card}
  else begin
    deck[place] := deck[place+1];
    deck[place+1] := card;
  end;
end;

procedure swap1with3;
var copydeck : array[1..54] of shortint;
    placejoker1, placejoker2 : shortint;
    movecount : shortint;
    copycount : shortint;
begin
  {step 3a: find first joker (JokerA or JokerB)}
  placejoker1 := 1;
  while (deck[placejoker1] < JokerA) do inc(placejoker1);

  {step 3b: find second joker}
  placejoker2 := placejoker1 + 1;
  while (deck[placejoker2] < JokerA) do inc(placejoker2);

  {step 3c: make exact copy of deck}
  for copycount := 1 to 54 do
    copydeck[copycount] := deck[copycount];
  copycount := 1;

  {step 3d: move all cards from section3 to front of deck}
  if placejoker2 < 54 then
    for movecount := (placejoker2+1) to 54 do
    begin
      deck[copycount] := copydeck[movecount];
      inc(copycount);
    end;

  {step 3e: move all cards from section2 behind section3}
  for movecount := placejoker1 to placejoker2 do
    begin
      deck[copycount] := copydeck[movecount];
      inc(copycount);
    end;

  {step 3f: move all cards from section1 behind section2}
  if placejoker1 > 1 then
    for movecount := 1 to (placejoker1-1) do
    begin
      deck[copycount] := copydeck[movecount];
      inc(copycount);
    end;
end;

procedure printdeck;
var count : shortint;
begin
  for count := 1 to 54 do
    case deck[count] of
       1..13: write('C');
      14..26: write('D');
      27..39: write('H');
      40..52: write('S');
      53..54: write('J');
      else write('X');
    end;
  writeln;
  for count := 1 to 54 do
    case deck[count] of
      1..52: case (deck[count] mod 13) of
               0: write('K');
               1: write('A');
               2..9: write((deck[count] mod 13));
               10: write('0');
               11: write('J');
               12: write('Q');
             end;
      53   : write('a');
      54   : write('b');
      else write('X');
    end;
  writeln;
end;

procedure countcut(count : shortint);
var copydeck : array[1..54] of shortint;
    movecount : shortint;
    copycount : shortint;
begin
  {step 4a: make exact copy of deck}
  for copycount := 1 to 54 do
    copydeck[copycount] := deck[copycount];
  copycount := 1;

  {step 4b: move all cards from section2 to front of deck}
  for movecount := (count+1) to 53 do
    begin
      deck[copycount] := copydeck[movecount];
      inc(copycount);
    end;

  {step 4c: move all cards from section1 behind section2}
  for movecount := 1 to count do
    begin
      deck[copycount] := copydeck[movecount];
      inc(copycount);
    end;
end;

procedure keydeck(passphrase : string);
var passcount : shortint;
begin
  if length(passphrase) < 1 then exit;
  for passcount := 1 to length(passphrase) do
  begin
    {step 1: move Joker A one cards down}
    movedown(JokerA);
    {step 2: move Joker B two cards down}
    movedown(JokerB);
    movedown(JokerB);
    {step 3: swap section 1 and section 3}
    swap1with3;
    {step 4: count cut deck and place before last card using last card}
    if (deck[54] < JokerA) then countcut(deck[54])
      else countcut(53); {if lastcard is a joker}
    {step 5: count cut deck and place before last card using passphrase}
    countcut(char2sint(passphrase[passcount]));
  end;
end;

procedure initdeck;
var count: shortint;
begin
  for count := 1 to 54 do
    deck[count] := count;
end;

procedure makekeystream(count :integer);
var streamcount : integer;
    found : integer;
begin
  streamcount := 1;
  write('Keystream: ');
  repeat
    {step 1: move Joker A one cards down}
    movedown(JokerA);
    {step 2: move Joker B two cards down}
    movedown(JokerB);
    movedown(JokerB);
    {step 3: swap section 1 and section 3}
    swap1with3;
    {step 4: count cut deck and place before last card using last cards value}
    if (deck[54] < JokerA) then countcut(deck[54])
      else countcut(53); {if lastcard is a joker}
    {step 5: find next key by counting from top using value of top card}
    if (deck[1] < JokerA) then found := deck[deck[1]+1]
      else found := deck[54]; {if topcard is a joker}
    case found of
       1..52: begin write(found); keystream[streamcount] := found; inc(streamcount); end;
      53..54: write('(53)');
    end;
    write(' ');
  until streamcount > count;
  writeln;
end;

function encrypt(originalmsg : string): string;
var dumpstr,msg  : string[255];
    msgcount     : integer;
    msgarr       : array[1..255] of shortint;
begin
  {step 1: eliminate spaces and find nonletters}
  dumpstr := '';
  msg := originalmsg;
  for msgcount := 1 to length(msg) do
    case upcase(msg[msgcount]) of
      'A'..'Z': dumpstr := dumpstr + upcase(msg[msgcount]);
      else; {do nothing: invallid character}
    end;
  msg := dumpstr;
  {step 2: make length of message a multiple of five}
  case (length(msg) mod 5) of
    0: ; {do nothing}
    1: msg := msg + 'XXXX'; {add four extra character}
    2: msg := msg + 'XXX'; {add three extra character}
    3: msg := msg + 'XX'; {add two extra character}
    4: msg := msg + 'X'; {add one extra character}
  end;

  {step 3: convert to an array of numbers}
  for msgcount := 1 to length(msg) do
    msgarr[msgcount] := char2sint(msg[msgcount]);

  {step 4: create keydeck}
  initdeck;
  keydeck(key);
  writeln;
  writeln('Deck:');
  printdeck;
  makekeystream(length(msg));

  {step 5: encrypt!}
  for msgcount := 1 to length(msg) do
    msgarr[msgcount] := msgarr[msgcount]+keystream[msgcount];

  {step 6: convert encrypted array to encrypte string}
  for msgcount := 1 to length(msg) do
    msg[msgcount] := sint2char(msgarr[msgcount]);

  {step 7: make blocks of 5 characters}
  dumpstr := '';
  for msgcount := 1 to length(msg) do
    if ((msgcount mod 5) = 0) then dumpstr := dumpstr + msg[msgcount] + ' '
      else dumpstr := dumpstr + msg[msgcount];

  encrypt := dumpstr;
end;

function decrypt(originalmsg : string): string;
var dumpstr,msg  : string[255];
    msgcount     : integer;
    msgarr       : array[1..255] of shortint;
begin
  {step 1: eliminate spaces}
  dumpstr := '';
  msg := originalmsg;
  for msgcount := 1 to length(msg) do
    case upcase(msg[msgcount]) of
      'A'..'Z': dumpstr := dumpstr + upcase(msg[msgcount]);
      else; {do nothing: invallid character}
    end;
  msg := dumpstr;

  {step 2: convert to an array of numbers}
  for msgcount := 1 to length(msg) do
    msgarr[msgcount] := char2sint(msg[msgcount]);

  {step 3: create a keydeck}
  initdeck;
  keydeck(key);
  writeln;
  writeln('Deck:');
  printdeck;
  makekeystream(length(msg));

  {step 4: decrypt!}
  for msgcount := 1 to length(msg) do
    msgarr[msgcount] := msgarr[msgcount]-keystream[msgcount];

  {step 5: convert encrypted array to encrypte string}
  for msgcount := 1 to length(msg) do
    msg[msgcount] := sint2char(msgarr[msgcount]);

  {step 6: make blocks of 5 characters}
  dumpstr := '';
  for msgcount := 1 to length(msg) do
    if ((msgcount mod 5) = 0) then dumpstr := dumpstr + msg[msgcount] + ' '
      else dumpstr := dumpstr + msg[msgcount];

  decrypt := dumpstr;
end;

begin
  clrscr;
  writeln('Solitaire Encryption/Decryption v1.0');
  writeln;

  message := 'a sample message to demonstrate the algorithm of Solitaire';
  key     := 'Cryptonomicon';  {Leave empty for null-deck}

  writeln('Original message: '+message);
  writeln('Key: '+key);
  message := encrypt(message);
  writeln('Encrypted as: '+message);

  message := decrypt(message);
  writeln('Decrypted as: '+message);
end.