program GrandpreStack;	{ For tip placement, note that repeating cipher letters are unique, but repeating }
{			plaintext letters are NOT unique.  Get pattern word for tip-length cipher text, see if }
{			duplications hold out in tip as well. 1/1/11}
	label 13;
 const
		ns = 8;		{ side of square }
		ndl = 25;	{ number of digrams displayed per line }
		maxstack = 200;		{ depth of save stack }
 type
	sqr = array[1..ns, 1..ns] of char;
 type
  stackentry = record	{ what is saved on the stack: 1 square }
		squares: sqr;
   end;
 type
	stacktype = record	{ define stack used to save squares }
		top: 0..maxstack;	{ represents current depth of stack }
		entry: array[1..maxstack] of stackentry
	end;
	var
		str1, LINE, title, tipv, tippat, tip, test, outstr: string;
		str, sol: AnsiString;
		tipd1, tipd2: string[2];				{ digram for tip }
		i, j, r, c, k, cn, rn, lensol, nr, len, nl, nd, lt, tp: integer;
		square: sqr;		{ square array }
		fsquare: array[1..ns, 1..ns] of integer;
		tpat, cpat: array[1..500] of integer;		{ pattern words for tip dragging }
		Infile, Outfile: text;
		flag, popflag, pushflag, undoflag: boolean;
		S: stacktype;

	function score(str1:string):integer;		{ counts number of repeats in tip match }
		var
			i, j:integer;
	begin
		j := 0;
		for i := 1 to length(str1) do
			if str1[i] <> '0' then
				inc(j);
		score := j;	{ return value }
	end;	{ of function score }

	function patstr (cstr: string): string;	{	Get tip pattern word (see ND2007 Computer Column) }
		var
			i, j, ls: integer;
			dstr: string;
	begin
		ls := length(cstr);	{ get length of string }
		dstr := '';
		for i := 1 to ls - 1 do
			begin
				for j := i + 1 to ls do
					begin
						if cstr[i] = cstr[j] then
							begin
								tpat[i] := j - i;	{ gives integral distance }
								break;		{ found one for this i, don't wait for another }
							end
						else
							tpat[i] := 0;
					end;	{ of j loop}
			end;	{ of i loop }
		for i := 1 to ls - 1 do
			begin
				if tpat[i] > 9 then
					dstr := concat(dstr, chr(tpat[i] + 55))		{ letter }
				else
					dstr := concat(dstr, chr(tpat[i] + 48));	{ number }
			end;
		patstr := dstr;
	end;	{ of function patstr }

	function dipatstr (cstr: string): string;	{ gets pattern word from digrams, numbers in cpat }
		var
			i, j, ls: integer;
			dstr: string;
	begin
		ls := length(cstr);	{ get length of string, should be 2*lt }
		dstr := '';
		for i := 1 to lt - 1 do
			begin
				for j := i + 1 to lt do
					begin
						if copy(cstr, 2*i - 1, 2) = copy(cstr, 2*j - 1, 2) then	{ these are digrams }
							begin
								cpat[i] := j - i;	{ gives integral distance }
								break;		{ found one for this i, don't wait for another }
							end
						else
							cpat[i] := 0;
					end;	{ of j loop}
			end;	{ of i loop }
		for i := 1 to ls div 2 - 1 do
			begin
				if cpat[i] > 9 then
					dstr := concat(dstr, chr(cpat[i] + 55))
				else
					dstr := concat(dstr, chr(cpat[i] + 48));
			end;
		dipatstr := dstr;
	end;	{ of function dipatstr }

	procedure SolveSquare;
	var
		i, r, c: integer;
	begin
		for i := 1 to nd do
			begin
				r := ord(str[2 * i - 1]) - 48;
				c := ord(str[2 * i]) - 48;
				sol[i] := lowercase(square[r, c]);
			end;
	end;	{ of procedure SolveSquare }

procedure DisplaySquares;	{ Displays key and frequency squares }
	var
		i, j: integer;
	begin
		writeln('   Tip length = ', lt : 2,', Tip = ', tip);
		write('  ');
		for i := 1 to ns do
			write(i : 3);		{ horizontal headings for square }
		write('      ');
		for i := 1 to ns do
			write(i : 4);
		writeln;
		for i := 1 to ns do
			begin
				write(i:1,'  ');	{ vertical headings }
				for j := 1 to ns do
					if fsquare[i,j] = 0 then
						begin
							write(square[i, j]:2,' ');		{ emphasize low frequency letters }
						end
					else
						write(square[i, j]:2,' ');		{ draw square }						
				write('  ');
				write(i:1,'    ');	{ vertical headings }
				for j := 1 to ns do
					write(fsquare[i, j] : 2, '  ');
				if i = 4 then
					write(' ',upCase(str1));	{ con title }
				writeln;
			end;
		writeln;
	end;	{ of procedure DisplaySquares }

procedure DrawCipher;
	var
		i, j: integer;
begin
	for i := 1 to nl do	{ full lines }
		begin
			for j := 1 to ndl do
				write(str[2*j - 1 + 2*ndl * (i - 1)],str[2*j + 2*ndl * (i - 1)],' ');		{ 3 spaces for each digram }
			writeln('  ', ndl*i:3);	{ display number of digrams so far }
			for j := 1 to ndl do
				write(sol[j + ndl * (i - 1)], '  ');
			writeln;
			writeln;
		end;
	if nr > 0 then		{ do remainder }
		begin
			for j := 1 to nr do	{ do remainder }
				write(str[2*j - 1 + 2*ndl*nl],str[2*j + 2*ndl*nl],' ');
			writeln('  ', ndl*nl + nr);
			for j := 1 to nr do
				write(sol[j + ndl*nl], '  ');
			writeln;
			writeln;
		end;
end;	{ of procedure DrawCipher }

	procedure Stop;
	var
		i, j:integer;
	begin
		outstr := str1;
		insert('sol',outstr,pos('.txt',str1));	{ insert 'sol' before '.txt' in outstr }
		assign(Outfile, outstr);				
		rewrite(Outfile);								{ open output file }
		for i := 1 to lensol do
			write(Outfile,sol[i]);
		writeln(Outfile);
		writeln(Outfile);
		for i := 1 to ns do
			begin
				for j := 1 to ns do
					write(Outfile,square[i,j],' ');
				writeln(Outfile);
			end;
		close(Outfile);
		writeln(' Solution written to text file: ',outstr);	
		write(' Press <Enter>: ');
		readln;
		halt;
	end;	{ procedure Stop }

 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;	{ of with S loop }
 end;	{ of procedure Pop }

 procedure SaveSquare;
 var
	SE: stackentry;
 begin
		with SE do
			begin			{ load stackentry }
				squares := square;
			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!');
				stop;
			end;
		popflag := false;
 end;		{ of procedure SaveSquare }

 procedure RecallSquare;
 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 }
				square := squares;
			end;
 end;		{ of procedure RecallSquares }
 
	function ReadNumberDigram(prompt: string): string;
	const
		NumS = ['1'..chr(ns+48)];	{ set of legal input chars }	
	var		{ Checks for valid number digram entered; must be in set Nums }
		NumString: string[2];
		flag: boolean;
	begin
		repeat
			flag := true;		{ assume valid numbers }
			write(prompt);
			readln(NumString);
			if NumString = '-1' then
				stop;
			if NumString[1] = '0' then
				begin
					RecallSquare;
					SolveSquare;		{ re-solve }
					writeln;
					DisplaySquares;
					DrawCipher; 
					undoflag := true;
					continue;	{ jump to until statement }
				end;
			if not((NumString[1] in NumS) and (NumString[2] in NumS)) then
				begin
					flag := false;		{ invalid letter }
					write(chr(7));
				end;
		until flag;
		ReadNumberDigram := NumString;
	end;	{ of function ReadNumberDigram }

	function ReadTipPosition(prompt: string): integer;
	var		{ Checks for valid number digram entered; must be in set Nums }
		k: integer;
		flag: boolean;
	begin
		repeat
			flag := true;		{ assume valid numbers }
			write(prompt);
			readln(k);
			if k = -1 then
				stop;
			if k > lensol - lt + 1 then
				begin
					flag := false;		{ invalid number }
					write(chr(7));
				end;
		until flag;
		ReadTipPosition := k;
	end;	{ of function ReadTipPosition }

begin
	title := '      GRANDPRE';

{		Now get puzzle  }

	write('ENTER THE FILE NAME ("-1" to QUIT): ');
	readln(str1);
	if str1 = '-1' then
		halt;
	assign(Infile, str1);					{ open Infile with title str1 }
	{$I-}
	reset(Infile);
	{$I+}
	if IOResult <> 0 then
		begin
			writeln(' Error opening file ',str1);
			stop;
		end;
	readln(Infile, str);						{ read in puzzle into str }
	readln(Infile, tip);						{ read in tip }
	lt := length(tip);							{ length of tip }
	Write(title, '  ');
	len := length(str);
	if len mod 2 <> 0 then
		begin
			writeln('Bad input file length');
			stop;
		end;
	lensol := len div 2;			{ length of solution string }
	writeln('Input string length = ', len : 4, '  Solution length = ', lensol : 3);
	tipd1 := '  ';
	tipd2 := tipd1;
	tippat := patstr(tip);		{ get tip pattern word }
	for i := 1 to ns do
		for j := 1 to ns do
			fsquare[1, j] := 0;
	sol := '';
	nd := lensol;						{ number of digraphs }
	for i := 1 to lensol do
		sol := concat(sol, '.');		{ set up sol as string with correct length }
	nl := lensol div ndl;	{ number of full lines to be displayed }
	nr := lensol - nl*ndl;	{ number of remainder digrams }

{		Make squares }

	for i := 1 to ns do
		for j := 1 to ns do
			square[i, j] := '.';

{		Make frequency count square }

	for i := 1 to nd do
		begin
			r := ord(str[2 * i - 1]) - 48;
			c := ord(str[2 * i]) - 48;
			fsquare[r, c] := fsquare[r, c] + 1;
		end;
		
	DisplaySquares;
	DrawCipher;
	
{		Look in crib-sized pieces for duplicate digrams }

	writeln('       Tip pattern word = ', tippat);
	for i := 1 to lensol - lt + 1 do	{ i is digram number, length of ct is 2*lensol }
		begin
			tipv := '';
			flag := false;	{ no match }
			for k := 1 to 2 * lt do
				tipv := concat(tipv, str[k + 2 * i - 2]);	{ odd starting point, twice as long as tip }

{		Only compare interval numbers in ct piece that are non-zero }

			test := dipatstr(tipv);	{ get patternword of ct under test, and store interval numbers in cpat }
			for j := 1 to lt do
				if cpat[j] > 0 then
					begin
						if tip[j] = tip[j + cpat[j]] then
							flag := true
						else
							begin
								flag := false;
								break;
							end;
					end;	{ of j loop }
			if flag then
				begin
					writeln(' Tip match at digram #', i:3,' ',test,' Score = ',score(test));
				end;
		end; { of i loop}
	writeln;
	tp := ReadTipPosition(' ENTER THE TIP POSITION DIGRAM # ("-1" to quit): ');
	
{		Store tip in square and get solution }

	for i := 1 to lt do
		begin
			rn := ord(str[2*(tp+i-1)-1]) - 48;	{ row coordinate }
			cn := ord(str[2*(tp+i-1)]) - 48;	{ column coordinate }
			square[rn,cn] := lowercase(tip[i]);
		end;
	SolveSquare;
	DisplaySquares;
	DrawCipher; 

{		Main loop }

	repeat
		undoflag := false;
		LINE := ReadNumberDigram('ENTER THE CIPHER DIGRAM (TWO NUMBERS) ("-1" to QUIT, "0" to UNDO): ');
		if undoflag then
			continue;		{ go around again }
		if LINE = '-1' then
			stop;
		rn := ord(LINE[1]) - 48;	{ row coordinate }
		cn := ord(LINE[2]) - 48;	{ column coordinate }
		SaveSquare;	{ if you get here, save current square before modifying with new input }
13:
		write('ENTER THE PLAINTEXT LETTER ("-1" to quit): ');
		readln(LINE);
		if LINE = '-1' then
			stop;
		if (LINE[1] in ['a'..'z']) or (LINE[1] in ['A'..'Z']) then
			square[rn, cn] := lowercase(LINE[1])
		else
			begin
				write(chr(7));
				goto 13;	{ go around again }
			end;
		DisplaySquares;
		SolveSquare;
		DrawCipher;
	until 1 = 0		{ go forever }
end.