program TwoSquare;	{ p1,c2 in left, p2,c1 in right. WINDOWS VERSION }
	{		Calculates number of reverses expected in a given tip position }
uses math;					{ math unit has maxintvalue function Nove28, 2008 }
 label
	12, 13, 14;
 const
  ns = 16;					{ size of square }
  nc = 48;					{ number of characters/line = 2X number of digrams/line }
	maxstack = 200;		{ size of save stack }
 type
  next = record
    row: integer;
    col: integer;
   end;
 type
	square = array[1..ns, 1..ns] of char;
 type
  stackentry = record	{ what is saved on the stack: 2 'next' records, 2 squares }
    next1s: next;
    next2s: next;
		lefts: square;
		rights: square;
   end;
 type
	stacktype = record	{ create stack to save squares and nexts }
		top: 0..maxstack;
		entry: array[1..maxstack] of stackentry
	end;
 type
  matchrec = record	{ match information; nm keeps track of how many }
    tip: string;		{ tip string }
    ct: string			{ ct string }
   end;

 var
  str, str1, str2, str3, str4, outstr, sol, title, tip, ctd, ptd, tip1, tip2: string[255];
  tipd, citd: string[2];				{ digram for tip, pt, ct }
  i, j, r1, r2, c1, c2, k, p1r, p1c, c1r, c1c, p2r, p2c, c2r, c2c: integer;
  left, right: square;		{ square arrays }
	match: array [1..50] of matchrec;
  next1, next2: next;	{ next free slots in squares }
  dig: array[1..26, 1..26] of integer;		{ stores digram frequency }
  Infile, Outfile: text;
  nr, len, nl, nm, kmax, nd, lt, lt1, lt2, len1, len2: integer;
  p1fnd, p2fnd, c1fnd, c2fnd, fndindex: integer;
  Ch: char;
	manflag, popflag, pushflag, repflag: boolean;
	S: stacktype;	
 
 function upperc(str7: string): string;	{ returns uppercase of a string }
 var
	i, len: integer;
	str1: string[255];
 begin
	str1 := str7;					{ assume already uppercase }
	len := length(str7);
	for i := 1 to len do		
		if( ord(str7[i]) > 96) and (ord(str7[i]) < 123) then	{ only change it if it is lowercase }
			str1[i] := upCase(str1[i]);		{ change letter by letter }
	upperc := str1;
 end;

 function dpatstr (cstr: string): string;	{ makes pattern string for repeat digrams }
  var
   i, j, ls, nds: integer;
	 tipd: string[2];	{ digram }
   dstr: string[255];
   ppat: array[1..50] of integer;	{ repeats }
 begin
		dstr := '';					{ start with blank string }
		ls := length(cstr);	{ get length of string }
		nds := ls div 2;		{ number of digrams in cstr }
		for i := 1 to nds - 1 do
			begin
				tipd := copy(cstr, 2 * i - 1, 2);	{ get digram }
				for j := i + 1 to nds do	{ look for repeated digrams }
					if (tipd[1] = cstr[2 * j - 1]) and (tipd[2] = cstr[2 * j]) then
						begin
							ppat[i] := j - i;	  { gives integer distance of repeat }
						{	writeln('Found repeat at digrams',i:3,' and',j:3);}
							repflag := true;
							break;  { found one for this i, don't look further }
						end
					else
						ppat[i] := 0;	{ no duplicate found for this i }
			end;		{ of i loop }
		for i := 1 to nds - 1 do	{ ignore last position: it is 0 }
				if ppat[i] > 9 then			{ repeats }
					dstr := concat(dstr, chr(ppat[i] + 55))		{ letter }
				else				
					dstr := concat(dstr, chr(ppat[i] + 48));		{ number }
		dpatstr := dstr;		{ result returned by function }
 end;	{ of function dpatstr }
	
 function CheckLeft: boolean;		{ Counts the number of characters }
		{ in the cols and rows of the left square, returns true if more than 5 }
  var
   i, j, k: integer;
 begin
  CheckLeft := false;	{ assume it is OK }
  for j := 1 to ns do	{ do each column }
		begin
			k := 0;				{ start with 0 }
			for i := 1 to ns do
				if ord(left[i, j]) > 64 then
					k := k + 1;
			if k > 5 then
				begin
					CheckLeft := true;
					exit;	{ get out }
				end;
		end;	{ of j loop }
  for i := 1 to ns do	{ do each row }
		begin
			k := 0;				{ start with 0 }
			for j := 1 to ns do
				if ord(left[i, j]) > 64 then
					k := k + 1;
			if k > 5 then
				begin
					CheckLeft := true;
					exit;	{ get out }
				end;
		end;	{ of i loop }
 end; { of function CheckLeft }

 function CheckRight: boolean;		{ Counts the number of characters }
{ in the cols and rows of the right square, returns true if more than 5 }
  var
   i, j, k: integer;
 begin
  CheckRight := false;	{ assume it is OK }
  for j := 1 to ns do	{ do each column }
		begin
			k := 0;				{ start with 0 }
			for i := 1 to ns do
				if ord(right[i, j]) > 64 then
					k := k + 1;
			if k > 5 then
				begin
					CheckRight := true;
					exit;	{ get out }
				end;
		end;	{ of j loop }
  for i := 1 to ns do	{ do each row }
		begin
			k := 0;				{ start with 0 }
			for j := 1 to ns do
				if ord(right[i, j]) > 64 then
					k := k + 1;
			if k > 5 then
				begin
					CheckRight := true;
					exit;	{ get out }
				end;
		end;	{ of i loop }
 end; { of function CheckRight }

 procedure Push(x: stackentry; var S: stacktype);	{ push stackentry to stack }
 begin
		with S do
			if top = maxstack then
				begin
					writeln('ERROR: Attempt to push an entry onto a full stack');
					pushflag := true;
				end
			else
				begin
					inc(top);
					entry[top] := x;		{ really means S.entry[S.top] := x }
				end;
 end;	{ of procedure Push }

 procedure Pop(var x: stackentry; var S: stacktype);	{ pop stackentry off stack }
 begin
		with S do
			begin
				if top = 0 then
					begin
						writeln('ERROR: Attempt to pop an entry from an empty stack');
						popflag := true;
						exit
					end
				else
					begin
						x := entry[top];		{ really means x := S.entry[S.top] }
						dec(top);
					end;
			end;
 end;	{ of procedure Pop }

 procedure SaveSquares;
 var
	SE: stackentry;
 begin
		with SE do
			begin			{ load stackentry }
				lefts := left;		{ means SE.lefts := left }
				rights := right;
				next1s := next1;
				next2s := next2;
			end;
		Push(SE,S);					{ push this stackentry SE onto stack S }
		if pushflag then		{ pushflag raised in push if stack is full }
			begin
				writeln('Exiting program because stack is full!');
				halt;
			end;
		popflag := false;
 end;		{ of procedure SaveSquares }

 procedure RecallSquares;
 var
	SE: stackentry;
 begin
		Pop(SE,S);
		if popflag then			{ popflag raised in pop if stack is empty }
			begin
				writeln('No more undos possible');
				write(chr(7));		{ beep }
				exit;
			end;
		pushflag := false;
		with SE do
			begin			{ retrieve stackentry }
				left := lefts;
				right := rights;
				next1 := next1s;
				next2 := next2s;
			end;
 end;		{ of procedure RecallSquares }

 procedure DrawSquares;
  var
   i, j: integer;
 begin
		for i := 1 to next1.row + 1 do
			begin
				write(' ');				{ space }
				for j := ns downto 1 do
					write(left[i, j], ' ');
				write('| ');
				for j := 1 to ns do
					write(right[i, j], ' ');
				if i =1 then
					write('  ',upcase(str4));		{ tag with name of con }
				writeln;
			end;
 end;		{ of procedure DrawSquares }

 function lowerc (C: char): char;	{ returns lowercase of a letter }
 begin
  lowerc := C;		{ only change it if it is a capital letter }
  if ord(C) > 64 then
   if ord(C) < 91 then
    lowerc := char(ord(C) + 32);
 end;	{ of function lowerc }

 procedure CombRows (r1, r2: integer);
  var
   org, dest, j: integer;
 begin
  if r1 < r2 then
   begin	{ move all to row r1 from row r2 }
    org := r2;
    dest := r1;
   end
  else
   begin	{ move all to row r2 from row r1 }
    org := r1;
    dest := r2;
   end;
  for j := 1 to ns do
   begin
    if ord(left[org, j]) > 64 then
     begin
      left[dest, j] := left[org, j];
      left[org, j] := '.';
     end;
    if ord(right[org, j]) > 64 then
     begin
      right[dest, j] := right[org, j];
      right[org, j] := '.';
     end;
   end;	{ of j-loop }
{		Now clean up vacant rows by bringing last row down to empty one }
  for j := 1 to ns do
   begin
    if ord(left[next1.row - 1, j]) > 64 then		{ last row in this square }
     begin
      left[org, j] := left[next1.row - 1, j];
      left[next1.row - 1, j] := '.';
     end;
    if ord(right[next2.row - 1, j]) > 64 then		{ last row in this square }
     begin
      right[org, j] := right[next2.row - 1, j];
      right[next2.row - 1, j] := '.';
     end;
   end;	{ of j-loop }
{		Reset next.row }
  next1.row := next1.row - 1;
  next2.row := next2.row - 1;
 end;	{ of procedure CombRows }

 procedure CombCols1 (c1, c2: integer);	{ combine columns in left }
  var
   org, dest, j: integer;
 begin
  if c1 < c2 then
   begin	{ move all to col c1 from col c2 }
    org := c2;
    dest := c1;
   end
  else
   begin	{ move all to col c2 from col c1 }
    org := c1;
    dest := c2;
   end;
  for j := 1 to ns do
   begin
    if ord(left[j, org]) > 64 then
     begin
      left[j, dest] := left[j, org];
      left[j, org] := '.';
     end;
   end;	{ of j-loop }
{		Now clean up vacant columns by bringing last column down to empty one }
  for j := 1 to ns do
   if ord(left[j, next1.col - 1]) > 64 then		{ last col in this square }
    begin
     left[j, org] := left[j, next1.col - 1];
     left[j, next1.col - 1] := '.';
    end;
{		Reset next.col }
  next1.col := next1.col - 1;
 end;	{ of procedure CombCols1 }

 procedure CombCols2 (c1, c2: integer);	{ combine columns in right }
  var
   org, dest, j: integer;
 begin
  if c1 < c2 then
   begin	{ move all to col c1 from col c2 }
    org := c2;
    dest := c1;
   end
  else
   begin	{ move all to col c2 from col c1 }
    org := c1;
    dest := c2;
   end;
  for j := 1 to ns do
   begin
    if ord(right[j, org]) > 64 then {letter is here }
     begin
      right[j, dest] := right[j, org];
      right[j, org] := '.';
     end;
   end;	{ of j-loop }
{		Now clean up vacant columns by bringing last column down to empty one }
  for j := 1 to ns do
   if ord(right[j, next2.col - 1]) > 64 then		{ last col in this square }
    begin
     right[j, org] := right[j, next2.col - 1];
     right[j, next2.col - 1] := '.';
    end;
{		Reset next.col }
  next2.col := next2.col - 1;
 end;	{ of procedure CombCols2 }

 procedure DrawReverseCipher;
  var
   i, j: integer;
 begin
		writeln(' REVERSED CIPHER:');
		for i := 1 to nl do
			begin
				write(' ');				{ space }
				for j := 1 to nc div 2 do
					write(str[nc * (i - 1) + 2 * j], str[1 + nc * (i - 1) + 2 * (j - 1)], ' ');
				writeln(i * nc div 2 : 3);
			end;
		if nr > 0 then
			begin
				write(' ');				{ space }
				for i := 1 to nr do		{ do remainder }
					write(str[nl * nc + 2 * i], str[1 + nl * nc + 2 * (i - 1)], ' ');
				writeln(nr + nl * nc div 2 : 3);
			end;
 end;		{ of procedure DrawReverseCipher }

 procedure DrawCipher;
  var
   i, j: integer;
 begin
		writeln;
		for i := 1 to nl do
			begin
				write(' ');				{ space }
				for j := 1 to nc div 2 do	{ write cipher }
					write(str[1 + nc * (i - 1) + 2 * (j - 1)], str[nc * (i - 1) + 2 * j], ' ');
				writeln(i * nc div 2 : 3);	{ last digram label }
				write(' ');				{ space }
				for j := 1 to nc div 2 do	{ write sol }
					write(lowerc(sol[1 + nc * (i - 1) + 2 * (j - 1)]), lowerc(sol[nc * (i - 1) + 2 * j]), ' ');
				writeln;
				writeln;
			end;
		if nr > 0 then
			begin
				write(' ');				{ space }
				for i := 1 to nr do		{ do cipher remainder }
					write(str[1 + nl * nc + 2 * (i - 1)], str[nl * nc + 2 * i], ' ');
				writeln(nr + nl * nc div 2 : 3);
				write(' ');				{ space }
				for i := 1 to nr do		{ do sol remainder }
					write(lowerc(sol[1 + nl * nc + 2 * (i - 1)]), lowerc(sol[nl * nc + 2 * i]), ' ');
				writeln;
				writeln;
		end;
 end;		{ of procedure DrawCipher }

 procedure ProcessDigrams (ptd, ctd: string);
  var
   j, k: integer;
   rflag: boolean;		{ true if ct=reverse of pt }
 begin

{		Check to see if this is a digram where ct=reverse of pt }

  rflag := false;						{ start off no reversal }
  if (ptd[1] = ctd[2]) or (ptd[2] = ctd[1]) then
   rflag := true;

{ 		Check for presence of any of the 4letters }

  p1fnd := 0;							{ first pt letter not here already }
  p2fnd := 0;							{ second pt letter not here already }
  c1fnd := 0;							{ first ct letter not here already }
  c2fnd := 0;							{ second ct letter not here already }
  for j := 1 to ns do			{ look in each row }
   for k := 1 to ns do		{ look at all columns }
    if ptd[1] = left[j, k] then	{ p1 here already }
     begin
      p1fnd := 1;					{ found this letter already placed }
      p1r := j;						{ save its row number }
      p1c := k;						{ save its column number }
     end;		{ of j,k loop }
  for j := 1 to ns do			{ look in each row }
   for k := 1 to ns do		{ look at all columns }
    if ctd[2] = left[j, k] then	{ c2 here already }
     begin
      c2fnd := 1;					{ found this letter already placed }
      c2r := j;						{ save its row number }
      c2c := k;						{ save its column number }
     end;		{ of j,k loop }
  for j := 1 to ns do			{ look in each row }
   for k := 1 to ns do		{ look at all columns }
    if ptd[2] = right[j, k] then	{ p2 here already }
     begin
      p2fnd := 1;					{ found this letter already placed }
      p2r := j;						{ save its row number }
      p2c := k;						{ save its column number }
     end;		{ of j,k loop }
  for j := 1 to ns do			{ look in each row }
   for k := 1 to ns do		{ look at all columns }
    if ctd[1] = right[j, k] then	{ c1 here already }
     begin
      c1fnd := 1;					{ found this letter already placed }
      c1r := j;						{ save its row number }
      c1c := k;						{ save its column number }
     end;		{ of j,k loop }

{		There are 16 possible conditions. Calculate fndindex=binary combination of 4 bits.}
{		Enter having values of c1r,c1c,c2r,c2c,p1r,p1c,p2r,p2c for found letters }

  fndindex := p1fnd + 2 * p2fnd + 4 * c1fnd + 8 * c2fnd;
  case fndindex of
   0: 	{ found no letters }
    begin
     left[next1.row, next1.col] := ptd[1];	{ put first pt letter in left square }
     right[next2.row, next2.col] := ctd[1];	{ put first ct letter in right square }
     next1.row := next1.row + 1;		{ increase row number for next letter }
     next2.row := next2.row + 1;		{ increase row number for next letter }
     if rflag = false then					{ not inverse }
      begin
       left[next1.row, next1.col] := ctd[2];	{ put second ct letter in left square }
       right[next2.row, next2.col] := ptd[2];	{ put second pt letter in right square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       next2.row := next2.row + 1;		{ increase row number for next letter }
      end;
     next1.col := next1.col + 1;		{ increase column number for next letter }
     next2.col := next2.col + 1;		{ increase column number for next letter }
    end;
   1: 	{ found p1 }
    begin
     right[p1r, next2.col] := ctd[1];	{ put first ct letter in right square }
     if rflag = false then
      begin
       left[next1.row, p1c] := ctd[2];	{ put second ct letter in left square }
       right[next2.row, next2.col] := ptd[2];	{ put second pt letter in right square }
       next2.row := next2.row + 1;		{ increase row number for next letter }
       next1.row := next1.row + 1;		{ increase row number for next letter }
      end;
     next2.col := next2.col + 1;		{ increase column number for next letter }
    end;
   2: 	{ found p2 }
    begin
     if rflag then
      left[p2r, next1.col] := ptd[1]	{ put first pt letter in left square }
     else
      begin
       left[next1.row, next1.col] := ptd[1];	{ put first pt letter in left square }
       right[next2.row, p2c] := ctd[1];	{ put first ct letter in right square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       next2.row := next2.row + 1;		{ increase row number for next letter }
       left[p2r, next1.col] := ctd[2];	{ put second ct letter in left square }
      end;
     next1.col := next1.col + 1;		{ increase column number for next letter }
    end;
   3: 	{ found p1 and p2 }
    begin		{ assume rflag=false}
     right[p1r, p2c] := ctd[1];	{ put first ct letter in right square }
     left[p2r, p1c] := ctd[2];	{ put second ct letter in left square }
    end;
   4: 	{ found c1 }
    begin
     left[c1r, next1.col] := ptd[1];	{ put first pt letter in left square }
     if rflag = false then
      begin
       left[next1.row, next1.col] := ctd[2];	{ put second ct letter in left square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       right[next2.row, c1c] := ptd[2];	{ put second pt letter in right square }
       next2.row := next2.row + 1;		{ increase row number for next letter }
      end;
     next1.col := next1.col + 1;		{ increase column number for next letter }
    end;
   5: 	{ found p1 and c1 }
    begin
     if p1r <> c1r then
      CombRows(p1r, c1r);
     if rflag = false then
      begin
       left[next1.row, p1c] := ctd[2];	{ put second ct letter in left square }
       right[next2.row, c1c] := ptd[2];	{ put second pt letter in right square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       next2.row := next2.row + 1;		{ increase row number for next letter }
      end;
    end;
   6: 	{ found c1 and p2 }
    begin
     if p2c <> c1c then		{ are they in the same column in right square? }
      CombCols2(p2c, c1c);
     if rflag then		{ they are the same letter }
      left[p2r, next1.col] := ptd[1]	{ put first pt letter in left square }
     else
      begin
       left[c1r, next1.col] := ptd[1];	{ put first pt letter in left square }
       left[p2r, next1.col] := ctd[2];	{ put second ct letter in left square }
      end;
     next1.col := next1.col + 1;			{ increase column number for next letter }
    end;
   7: 	{ found p1,p2,c1, MISSING C2 IN SQUARE 1 }
    begin	{ Must check that p2c=c1c, c1r=p1r }
     if p2c <> c1c then
      CombCols2(p2c, c1c);
     left[p2r, p1c] := ctd[2];	{ put second ct letter in left square }
     if c1r <> p1r then
      CombRows(c1r, p1r);
    end;
   8: 	{ found c2 }
    begin
     right[c2r, next2.col] := ptd[2];	{ put second pt letter in right square }
     if rflag = false then
      begin
       left[next1.row, c2c] := ptd[1];	{ put first pt letter in left square }
       right[next2.row, next2.col] := ctd[1];	{ put first ct letter in right square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       next2.row := next2.row + 1;		{ increase row number for next letter }
      end;
     next2.col := next2.col + 1;		{ increase column number for next letter }
    end;
   9: 	{ found p1 and c2 }
    begin
     if p1c <> c2c then		{ are they in the same column in left square? }
      CombCols1(p1c, c2c);
     if rflag then		{ they are the same letter }
      right[c2r, next2.col] := ctd[1]	{ put first ct letter in right square }
     else
      begin
       right[p1r, next2.col] := ctd[1];	{ put first ct letter in right square }
       right[c2r, next2.col] := ptd[2];	{ put second pt letter in right square }
      end;
     next2.col := next2.col + 1;		{ increase column number for next letter }
    end;
   10: 	{ found c2 and p2 }
    begin
     if c2r <> p2r then	{ are they in the same row? }
      CombRows(c2r, p2r);
     if rflag = false then					{ not a reverse; add other letters }
      begin
       left[next1.row, c2c] := ptd[1];	{ put first pt letter in left square }
       right[next2.row, p2c] := ctd[1];	{ put first ct letter in right square }
       next1.row := next1.row + 1;		{ increase row number for next letter }
       next2.row := next2.row + 1;		{ increase row number for next letter }
      end;
    end;	{ of fndindex=10 }
   11: 	{ found p1,p2,c2 }
    begin	{ Must check that p1c=c2c, c2r=p2r, p1r<>c2r }
     if p1c <> c2c then
      CombCols1(p1c, c2c);
     right[p1r, p2c] := ctd[1];	{ put first ct letter in right square }
     if c2r <> p2r then		{ reversed order of sq= and combRows 10/1/08 }
      CombRows(c2r, p2r);
    end;
   12: 	{ found c1 and c2 }
    begin		{ assume rflag=false}
     left[c1r, c2c] := ptd[1];	{ put first pt letter in left square }
     right[c2r, c1c] := ptd[2];	{ put second pt letter in right square }
    end;
   13: 	{ found p1,c1,c2 }
    begin	{ Must check that p1c=c2c, c1r=p1r }
     right[c2r, c1c] := ptd[2];	{ put second pt letter in right square }
     if p1c <> c2c then
      CombCols1(p1c, c2c);
     if c1r <> p1r then
      CombRows(c1r, p1r);
    end;
   14: 	{ found p2,c1,c2 }
    begin	{ Must check that p2c=c1c, c2r=p2r}
     left[c1r, c2c] := ptd[1];	{ put first pt letter in left square }
     if p2c <> c1c then
      CombCols2(p2c, c1c);
     if c2r <> p2r then
      CombRows(c2r, p2r);
    end;
   15:	{ found all 4 }
    begin
     if rflag then { this is reversal }
				if p1r <> c1r then
					Combrows(p1r, c1r);
     if rflag = false then
				begin
					if p1c <> c2c then
						CombCols1(p1c, c2c);
					if p2c <> c1c then
						CombCols2(p2c, c1c);

{		Must move lowest row first.  If an inner row is moved first, then lowest row is }
{		brought in to replace it.  If it is one that is supposed to be moved, its coordinates are lost. }
					if (maxintvalue([p1r,c1r,p2r,c2r]) = p2r) or (maxintvalue([p1r,c1r,p2r,c2r]) = c2r) then
						begin											{ order is important }
							if p2r <> c2r then				
								CombRows(p2r, c2r);		{ do this one first, it is lower }
							if p1r <> c1r then
								CombRows(p1r, c1r);
						end
					else
						begin
							if p1r <> c1r then
								CombRows(p1r, c1r);
							if p2r <> c2r then
								CombRows(p2r, c2r);
						end;
				end;	{ of rflag = false }
    end;	{ of case 15 }
  end;	{ of case }
 end;	{ of procedure ProcessDigrams }

 procedure DisplaySolution;
  var
   i: integer;
 begin
		for i := 1 to nl do
			begin
				write(' ');			{ space }
				writeln(copy(sol,1 + 78*(i - 1),78));
			end;
		write(' ',copy(sol,78*nl+1,nr));	{ remainder }
		writeln;
 end;	{ of procedure DisplaySolution }

 procedure SolveCipher;
  var
   i, j, k: integer;
 begin

{		Start with sol blank, in case a '.' was input to clear that value }

  sol := '';
  for i := 1 to len do
   sol := concat(sol, '.');

  for i := 1 to nd do					{ get solution for this square: nd digraphs }
   begin
    r1 := 0;					{ start with zeros }
    c1 := 0;
    r2 := 0;
    c2 := 0;

{		Start with first character of digram }

    Ch := str[2 * i - 1];			{ get first char of digraph }
    for j := 1 to ns do				{ find it in square 2 }
     for k := 1 to ns do
      if Ch = right[j, k] then	{ found it }
       begin
       r2 := j;
       c2 := k;
{    writedraw(ch, r1 : 1, c1 : 1, ' ');}
       end;

{		Now do second character of digram }

    Ch := str[2 * i];				{ get second char of digraph }
    for j := 1 to ns do				{ find it in square 1 }
     for k := 1 to ns do
      if Ch = left[j, k] then	{ found it }
       begin
       r1 := j;
       c1 := k;
{    writedraw(ch, r2 : 1, c2 : 1, ' ');}
       end;

{		Do letters in the same row  }

    if ((r1 = r2) and (r1 > 0)) then		{ valid numbers in same row, i is digram number }
     begin
      sol[2 * i - 1] := left[r1, c1];		{ first pt letter  }
      sol[2 * i] := right[r2, c2];
{    writedraw(sol[2 * i - 1], sol[2 * i]);}
     end

{		Do valid letters in rectangular relationship }

    else if r1 * r2 * c1 * c2 > 0 then
     begin
      sol[2 * i - 1] := left[r2, c1];
      sol[2 * i] := right[r1, c2];
{    writedraw(sol[2 * i - 1], sol[2 * i]);}
     end;
   end; { of i loop }
 end;	{ of procedure SolveCipher }

 procedure ProcTip(str1,str3:string);	{ str1 is Tip1 or Tip2, str3 is 'Tip1' or 'Tip2' }
  var
	 pd, cd: string[2];		{ pt, ct digram }
	 tippat, ctip: string;
   ii, kl, i, j, imax, ltip, rev: integer;
	 mflag: boolean;
 begin
		ltip := length(str1);
		imax := ltip div 2;						{ number of digrams in tip }
		mflag := true;								{ means didn't find match }
		repflag := false;							{ assume no repeat digrams in tip }
		tippat := dpatstr(str1);			{ if there is a repeat digram, repflag is set }
		for ii := 1 to nd - imax + 1 do	{ number of unique starting positions for the tip to fit }
			begin
				kl := 2 * ii - 1;					{ starting position of ct digram }

{		Initialize squares and sol }

				for i := 1 to 2 * nd do
					sol[i] := '.';
				for i := 1 to ns do					{ construct alphabet squares }
					for j := 1 to ns do
						begin
							left[i, j] := '.';
							right[i, j] := '.';
						end;
				next1.row := 1;
				next1.col := 1;
				next2.row := 1;
				next2.col := 1;

{		Process tip: get letters for left and right squares.  First search to see if letter is already there. }

				for i := 1 to imax do
					begin
						pd := copy(str1, 2 * i - 1, 2);			{ get pt digram from tip }
						cd := copy(str,kl + 2*(i-1),2);			{ get ct digram from str }
						ProcessDigrams(pd, cd);
					end;	{ of i loop }
				SolveCipher;
				ctip := copy(str,kl,2*imax);		{ get the whole ct tip }
				if pos(str1, sol) > 0 then			{ tip survived loading all letters: Test #1 }
					if CheckLeft = false then			{ Didn't find more than 5 in left: Test #2 }
						if CheckRight = false then	{ Didn't find more than 5 in right: Test #3 }
							if (repflag and (dpatstr(ctip) = tippat)) or (repflag = false) then	{ tip has repeat digram: Test #4 }
								begin
									write(' Tip placement for ',str3,' at digram #', (kl+1) div 2 : 3);
									inc(nm);								{ increment match count }
									match[nm].ct := ctip;		{ store ciphertext string }
									match[nm].tip := str1;	{ store tip string }
									if repflag then					{ give repeat digrams }
										for i := 1 to imax do
											if ord(tippat[i]) > 48 then
												begin
													j := i + ord(tippat[i]) - 48;
													write(', Repeat at digrams ',i,' and ',j);
													break;					{ get out of i loop }
												end;	{ of i loop }
					{ calculate number of reverses here }
									rev := 0;
									for i := 1 to imax do
										begin
											pd := copy(str1, 2 * i - 1, 2);		{ get tip digram }
											cd := copy(match[nm].ct,2*i-1,2);	{ get ct digram }
											if (pd[1] = cd[2]) and (pd[2] = cd[1]) then
												inc(rev);												{ count reverses }
										end;	{ of i loop }
									if rev > 0 then
										writeln(', Reverses = ',rev)
									else
										writeln;
									mflag := false;				{ found at least 1 match }
								end;	{ of 4 ifs }
			end;	{ of ii loop }
		if mflag then
			writeln(' No match found for ',str3);
 end;	{of procecdure ProcTip }
 
 Procedure Swap;	{ 3 operations: columns in left, columns in right, rows }
 label
		12, 13;
 var
	i, k, r1, r2, c1, c2, S, RC: integer;
	C, D: char;
	templ, tempr: array[1..ns] of char;
 begin
 12:
		write(' ENTER SQUARE [L(LEFT), R(RIGHT)], ("-1" to CANCEL): ');
		readln(C);
		if C = '-' then
			exit;							{ go back to main program }
		C := upCase(C);			{ uppercase }
		if not((C ='L') or (C = 'R')) then
			begin
				writeln(' BAD SQUARE ENTRY; TRY AGAIN');
				goto 12;
			end;
		S := ord(C) - 64;	{ L=12, R=18 }
 13:
		write(' ENTER R(ROWS) or C(COLUMNS) ("-1" to CANCEL): ');
		readln(D);
		if D = '-' then
			exit;							{ go back to main program }
		D := upCase(D);			{ uppercase }
		if not((D ='R') or (D = 'C')) then
			begin
				writeln(' BAD ROW/COLUMN ENTRY; TRY AGAIN');
				goto 13;
			end;
		RC := ord(D) - 64;	{ R=18, C=3 }
		k := S + RC;				{ index into combinations }
		if k = 36 then
			k := 30;					{ equivalent: left rows, right row }
		case k of
			15: begin					{ LEFT COLUMNS }
						write(' ENTER FIRST COLUMN # ("-1" to CANCEL) (count LEFT from VERTICAL DIVIDER): ');
						readln(c1);
						if c1 = -1 then
							exit;
						write(' ENTER SECOND COLUMN # ("-1" to CANCEL) (count LEFT from VERTICAL DIVIDER): ');
						readln(c2);
						if c2 = -1 then
							exit;
						if ((c1 = next1.col) or (c2 = next1.col)) then
							begin
								writeln(' Wait until column ',next1.col,' is populated before swapping!');
								write(chr(7));
								exit;
							end;
						for i := 1 to ns do
							templ[i] := left[i,c1];		{ buffer first column }
						for i := 1 to ns do							{ swap columns }
							begin
								left[i,c1] := left[i,c2];
								left[i,c2] := templ[i];
							end;
				 end;
		 21: begin					{ RIGHT COLUMNS }
						write(' ENTER FIRST COLUMN # ("-1" to CANCEL) (count RIGHT from VERTICAL DIVIDER): ');
						readln(c1);
						if c1 = -1 then
							exit;
						write(' ENTER SECOND COLUMN # ("-1" to CANCEL) (count RIGHT from VERTICAL DIVIDER): ');
						readln(c2);
						if c2 = -1 then
							exit;
						if ((c1 = next2.col) or (c2 = next2.col)) then
							begin
								writeln(' Wait until column ',next2.col,' is populated before swapping!');
								write(chr(7));
								exit;
							end;
						for i := 1 to ns do
							tempr[i] := right[i,c1];		{ buffer first column }
						for i := 1 to ns do
							begin													{ swap columns }
								right[i,c1] := right[i,c2];
								right[i,c2] := tempr[i];
							end;
		     end;
		 30: begin					{ ROWS }
						write(' ENTER FIRST ROW # ("-1" to CANCEL) (count DOWN from TOP): ');
						readln(r1);
						if r1 = -1 then
							exit;
						write(' ENTER SECOND ROW # ("-1" to CANCEL) (count DOWN from TOP): ');
						readln(r2);
						if r2 = -1 then
							exit;
						if ((r1 = next1.row) or (r1 = next2.row) or (r2 = next1.row) or (r2 = next2.row)) then
							begin
								writeln(' Wait until the next available row is populated before swapping!');
								write(chr(7));
								exit;
							end;
						for i := 1 to ns do
							begin
							templ[i] := left[r1,i];
							tempr[i] := right[r1,i];
						end;
						for i := 1 to ns do						{ swap rows }
							begin
								left[r1,i] := left[r2,i];
								left[r2,i] := templ[i];
								right[r1,i] := right[r2,i];
								right[r2,i] := tempr[i];
							end;
				 end;
		end;	{ of case }
  SolveCipher;
	DrawReverseCipher;
	DrawCipher;
	DrawSquares;
	writeln;
	DisplaySolution;
 end;	{ of Procedure Swap }

 Procedure Stop;
 var
	i,j: integer;
 begin
		for i := 1 to nl do					{ write complete lines of sol }
			begin
				write(Outfile,' ');			{ space }
				writeln(Outfile,copy(sol,1 + 78*(i - 1),78));
			end;
		writeln(Outfile,' ',copy(sol,78*nl+1,nr));	{ remainder }
			for i := 1 to next1.row -1 do
				begin 
					for j := next1.col - 1 downto 1 do
						write(Outfile,' ',left[i,j]);
					write(Outfile,'   ');
					for j := 1 to next2.col - 1 do
						write(Outfile,' ',right[i,j]);
					writeln(Outfile);
				end;
		close(Outfile);
		writeln(' Solution written to text file: ',outstr);	
		write(' Press <Enter>: ');
		readln;
		halt;
 end;	{ of Procedure Stop }

begin	{ main program }
  title := ' TWO-SQUARE ASSISTANT';
  writeln(title);
	write(' ENTER CON FILE NAME ("-1" TO QUIT): ');
	readln(str1);
	if str1 = '-1' then
		halt;
  assign(Infile,str1);
	{$I-}
	reset(Infile);
	{$I+}
	if IOResult <> 0 then
		begin
			writeln(' Error opening file ',str1);
			write(' Press <Enter>: ');
			readln;
			halt;
		end;
	str4 := str1;								{ save for later }
	insert('sol',str1,pos('.txt',str1));	{ insert 'sol' before '.txt' in str1 }
	outstr := str1;
  assign(Outfile,outstr);
  rewrite(Outfile);						{ open output file }
  readln(Infile, str);				{ read in con into str }
  readln(Infile, tip);				{ read in tip }
  len := length(str);
  nd := len div 2;						{ number of digrams in con }
  lt := length(tip);					{ length of tip }
  nm := 0;										{ no matches }
  repflag := false;						{ no repeats in tip }
  pushflag := false;					{ error on push flag }
  popflag := false;						{ error on pop flag }
  manflag := false;						{ tip will be entered by matching }
  S.top := 0;									{ initialize saving stack }
  next1.row := 1;
  next1.col := 1;
  next2.row := 1;
  next2.col := 1;
  if len mod 2 > 0 then
		begin
			write(' Length of string not an even number.');
			halt;
		end;

{		Get digram frequencies }

  for i := 1 to 26 do
		for j := 1 to 26 do
			dig[i, j] := 0;

  for i := 1 to nd do
		begin
			tipd := copy(str, 2 * i - 1, 2);	{ get digram }
			j := ord(tipd[1]) - 64;						{ row coordinate }
			k := ord(tipd[2]) - 64;						{ column coordinate }
			dig[j, k] := dig[j, k] + 1;				{ add one }
		end;
  write(' HF digrams: ');
  for i := 1 to 26 do
		for j := 1 to 26 do
			if dig[i, j] > 1 then
				write(chr(i + 64), chr(j + 64),':', dig[i, j] : 1, ', ');

	writeln;
  writeln(' Length=', len : 3, '  nd=', nd : 3, ',  tip = ', tip, ', tip length =', lt : 3);
  if lt mod 2 > 0 then		{ tip is odd length }
		begin
			tip1 := copy(tip, 1, lt - 1);		{ get even-numbered tip length starting with position 1 }
			tip2 := copy(tip, 2, lt - 1);		{ get even-numbered tip length starting with position 2 }
		end
	else
		begin
			tip1 := tip;										{ get even-numbered tip length starting with position 1 }
			tip2 := copy(tip, 2, lt - 2);		{ get even numbered tip - 2 length starting with position 2 }
		end;
	lt1 := length(tip1);
	lt2 := length(tip2);
	len1 := lt1 div 2;		{ half-length of tip1 and number of digrams }
	len2 := lt2 div 2;		{ half-length of tip2 }
	write(' Tip1= ');
	for i := 1 to len1 do
		write(tip1[2 * i - 1], tip1[2 * i], ' ');	{ write out tip1 as digrams }
	writeln(' Length=', lt1 : 2,', # of Reverses expected: ',(lt1+5) div 10);
	write(' Tip2= ');
	for i := 1 to len2 do
		write(tip2[2 * i - 1], tip2[2 * i], ' ');	{ write out tip2 }
	writeln(' Length=', lt2 : 2,', # of Reverses expected: ',(lt2+5) div 10);
	ProcTip(Tip1,'Tip1');				{ drag Tip1 }
	ProcTip(Tip2,'Tip2');				{ drag Tip2 }
	if nm > 1 then							{ more than 1 match found }
		begin
			writeln(' ',nm,' matches found');
			manflag := true;				{ tip to be entered manually }
14:
			write(' ENTER FORM OF TIP; Tip1 or Tip2 ("-1" TO QUIT): ');
			readln(str3);
			str3 := upperc(str3);		{ get uppercase }
			if  str3 = '-1' then
				halt;
			if str3 = 'TIP1' then
				str1 := Tip1					{ tip letters }
			else if str3 = 'TIP2' then
				str1 := Tip2
			else
				begin
					writeln(' TIP TITLE ENTERED IN ERROR');
					goto 14;						{ try again }
				end;
			str2 := str1;						{ strings the same length }
			write(' ENTER TIP AT DIGRAM #: ');
			readln(k);
			str2 := copy(str,2*k-1,length(str1));	{ grab ct }
			
{		Now have str1 and str2 needed to process tip letters }

		end;	{ of nm > 1 }

{	populate ciphertext squares left and right from tip }

	if not manflag then
		begin
			str1 := match[1].tip;				{ tip form from match }
			str2 := match[1].ct;				{ ciphertext from match }
		end;
	kmax := length(str1) div 2;	{ number of digrams in tip }

{		Initialize squares and sol }

	for i := 1 to 2 * nd do
		sol[i] := '.';
	for i := 1 to ns do					{ construct alphabet squares }
		for j := 1 to ns do
			begin
				left[i, j] := '.';
				right[i, j] := '.';
			end;
	next1.row := 1;
	next1.col := 1;
	next2.row := 1;
	next2.col := 1;
	for k := 1 to kmax do
		begin
			ptd := copy(str1, 2*k - 1, 2);		{ get tip digram }
			ctd := copy(str2, 2*k - 1, 2);		{ get matching ct digram }
			ProcessDigrams(ptd, ctd);
		end;	{ of k loop }
  nl := len div nc;				{ number of lines with nc/2 digrams }
  nr := len mod nc div 2;	{ number of digrams left over }

{		Look for reversed digrams }

	write(' Reverse tip digrams: ');
	for i := 1 to kmax do		{ kmax digrams }
		begin
			tipd := copy(str1, 2*i-1, 2);
			Ch := tipd[2];
			tipd[2] := tipd[1];
			tipd[1] := Ch;		{ tipd is now reversed digram of tip }
			for j := 1 to nd do
				begin
					citd := copy(str, 2 * j - 1, 2);		{ get ct digram }
					if citd = tipd then
						write(tipd, ' @', j : 3,', ');
				end;
		end;	{ of i-loop }
	writeln;
  SolveCipher;		{ sol not good here }
  writeln;
  DrawReverseCipher;
  DrawCipher;
  DrawSquares;
  writeln;
  DisplaySolution;

  repeat
12:
		write(' ENTER PLAINTEXT DIGRAM ("-1" to QUIT,"0" to UNDO,"1" to SWAP ROWS/COLUMNS): ');
		readln(ptd);
		ptd := upcase(ptd);
		if ptd = '-1' then
			stop;								{ write out sol and halt }
		if ptd = '0' then
			begin
				RecallSquares;		{ revert to previous squares }
				goto 13;					{ clean up }
			end;
		if ptd = '1' then
				begin
					SaveSquares;
					Swap;
					goto 12;				{ start over }
				end;
		if length(ptd) <> 2 then
			goto 12;					{ try again }
		SaveSquares;	{ if you get here, save current squares before modifying with new input }
		write(' ENTER THE CIPHERTEXT DIGRAM ("-1" to quit): ');
		readln(ctd);
		ctd := upcase(ctd);
		if ctd = '-1' then
			stop;								{ write sol and halt }
		writeln;
		ProcessDigrams(ptd, ctd);
13:
		if (CheckLeft = false) and (CheckRight = false) then
			begin
				SolveCipher;
				DrawReverseCipher;
				DrawCipher;
				DrawSquares;
				writeln;
				DisplaySolution;
			end
		else
			begin
				writeln(' BAD ENTRY; TRY AGAIN');
				RecallSquares;
				write(chr(7));		{ beep }
				write(chr(7));		{ beep }
			end;
  until 1 = 0;
end.