################################################################
# transp.pl : Transposition cipher over the alphabet [A..Z]    #
#    Input from STDIN : plaintext                              #
#    Output to STDOUT : ciphertext                             #
#    Key from command line :                                   #
#       determines the permutation of the colums.              #
#            Example: key = "SECRET" gives the permutation     #
#                            CEERST = 214305                   #
#    If there is a second argument in the command line         #
#      the cipher is a simple columnar transposition,          #
#      else it is a simple block transposition.                #
#--------------------------------------------------------------#
# Technical remark: Because Perl doesn't allow easy access to  #
#   the single letters of a string all the strings are         #
#   transformed into lists.                                    #
# The main program is quite verbose to show what's going on.   #
#   You may wish to comment out all print statements except    #
#   the final output of the ciphertext.                        #
#--------------------------------------------------------------#
# Klaus Pommerening 23. September 1997                         #
#                                                              #
# This program is freeware. Use it as you like.                #
# Usual disclaimers apply.                                     #
################################################################

# Our standard alphabet
@alphabet = ("A","B","C","D","E","F","G","H","I","J","K","L","M",
             "N","O","P","Q","R","S","T","U","V","W","X","Y","Z");

$key = &to26($ARGV[0]);             # Get keys from command line
                                    #   and transform to upper case.
$option = $ARGV[1];
$l = length($key);
print "Length of key: $l --- "; 
@keylist = split(//, $key);   # Split key into single
                                    #   characters.
print "Key: ";
foreach $k (@keylist) {print "$k ";}
print "\n";

$permut[0] = 0;
for ($i = 1; $i < $l; $i++) {
  $j = 0;
  $found = 0;
  while (!$found) {
    if (($j >= $i) || ($keylist[$i] lt $keylist[$permut[$j]])) {
      splice(@permut, $j, 0, $i);    # Insert $i at position $j
      $found = 1;}
    else {$j++;}
    }
  }
print "Permutation:";
foreach $p (@permut) {print " $p";}
print "\n";

chop(@inputlist = <STDIN>);         # Read input line by line,
                                    #   chop trailing CR.
foreach $m (@inputlist) {           # Change each line
  $m = &to26($m);                   #   to Alphabet [A..Z].
  }
$plaintext = join("",@inputlist);   # Join lines as 1 string.
$r = length($plaintext);
print "Length of plaintext: $r\n"; 
@plainlist = split(//, $plaintext); # Split string as list
                                    #   of characters.
$q = int($r/$l);
$s = $r - $q*$l;
print "Number of complete rows: $q --- remainder: $s\n";
if ($s > 0) {$qq = $q+1;}
else        {$qq = $q;}
$rr = $qq*$l;
print "Number of rows: $qq -- size of tableau: $rr\n";
for ($i = $r; $i < $rr; $i++) {$plainlist[$i] = "0";}

print "Arrangement of plaintext in columns:\n";
for ($i = 0; $i < $qq; $i++) {
  for ($j = 0; $j < $l; $j++) {
    print "$plainlist[$l*$i + $j] ";
    }
  print "\n";
  }
print "Option $option = ";
if ($option) {
  print "columnar transposition\n";
  print "Ciphertext:\n";
  for ($j = 0; $j < $l; $j++) {
    for ($i = 0; $i < $qq; $i++) {
      if ($c = $plainlist[$l*$i + $permut[$j]]) {
        print "$c";}
      }
    }
  }
else {
  print "block transposition\n";
  print "Ciphertext:\n";
  for ($i = 0; $i < $qq; $i++) {
    for ($j = 0; $j < $l; $j++) {
      if ($c = $plainlist[$l*$i + $permut[$j]]) {
        print "$c";}
      }
    }
  }
print "\n";

################################################################
# Subroutine to26                                              #
#   Input:  a string of ISO-LATIN-1 characters                 #
#   Output: a string transscribed to alphabet [A..Z]           #
# Some characters are ignored.                                 #
# Some characters are replaced by GERMAN description.          #
#   To use other languages modify replacement expressions.     #
################################################################
sub to26 {
  local($mytext) = $_[0];         # Get input string.
  $mytext =~ tr/a-z/A-Z/;         # Translate to upper case.
  $mytext =~ s/0/NULL/g;          # Numbers to verbal description.
  $mytext =~ s/1/EINS/g;
  $mytext =~ s/2/ZWEI/g;
  $mytext =~ s/3/DREI/g;
  $mytext =~ s/4/VIER/g;
  $mytext =~ s/5/FUENF/g;
  $mytext =~ s/6/SECHS/g;
  $mytext =~ s/7/SIEBEN/g;
  $mytext =~ s/8/ACHT/g;
  $mytext =~ s/9/NEUN/g;
  $mytext =~ s/\$/DOLLAR/g;       # Some special characters
  $mytext =~ s/%/PROZENT/g;
  $mytext =~ s/&/UND/g;
  $mytext =~ s/\+/PLUS/g;
  $mytext =~ s/=/ISTGLEICH/g;
  $mytext =~ s/¢/CENT/g;
  $mytext =~ s/£/PFUND/g;
  $mytext =~ s/¥/YEN/g;
  $mytext =~ s/§/PARAGRAPH/g;
  $mytext =~ s/¼/EINVIERTEL/g;
  $mytext =~ s/½/EINHALB/g;
  $mytext =~ s/¾/DREIVIERTEL/g;
  $mytext =~ s/ß/SS/g;
  $mytext =~ s/[ÀÁÂÃÅàáâãå]/A/g;  # Expand diacritical marks.
  $mytext =~ s/[ÄÆäæ]/AE/g;
  $mytext =~ s/[Çç]/C/g;
  $mytext =~ s/[ÈÉÊËèéêë]/E/g;
  $mytext =~ s/[ÌÍÎÏìíîï]/I/g;
  $mytext =~ s/[Ññ]/NN/g;
  $mytext =~ s/[ÒÓÔÕòóôõ]/O/g;
  $mytext =~ s/[ÖØöø]/OE/g;
  $mytext =~ s/[ÚÙÛùúû]/U/g;
  $mytext =~ s/[Üü]/UE/g;
  $mytext =~ tr/A-Z/x/c;          # Remaining characters
  $mytext =~ s/x//g;              #   are ignored.
  return $mytext;
  } #--- to26 --------------------------------------------------
