program FourSquare;	{ ND2008 Computer Column by Cary Davids, July 2008 }
{ Undo function (enter "0") allows returning to previous state if desired. }
{ Writes solution into text file upon termination. Added manual tip entry 11/3/08 }
 label
	12, 13, 14, 15;
 const
	maxstack = 200;		{ depth of save stack }
	nc = 48;					{ number of characters/line }
 type
  frecord = record	{ letter frequency }
    fr1: integer;		{ frequency of 1st cipher letter in digram }
    fr2: integer;		{ frequency of 2nd cipher letter in digram }
    let: char				{ cipher letter }
   end;
 type
	square = array[1..5, 1..5] of char;
 type
  matchrec = record	{ match information; nm keeps track of how many }
    chi: real;			{ chisq of cipher square fit }
    tip: string;		{ tip string }
    ct: string			{ ct string }
   end;
 type
  stackentry = record	{ what is saved on the stack: 2 'next' records, 3 squares }
		ct1: square;
		ct2: square;
   end;
 type
	stacktype = record	{ define stack used to save squares and nexts }
		top: 0..maxstack;	{ represents current depth of stack }
		entry: array[1..maxstack] of stackentry
	end;
 var
  str, str1, str2, str3, tippatstr1, tippatstr2, title, sol, tip, pta, n1str, n2str, tip1, tip2, alph, zero, outstr: string;
	ptd, ctd: string[4];
	dig1, dig2: string[2];
  i, j, len, nd, nm, lt, len1, len2, lt1, lt2, nl, nr, kmax: integer;
  r1, r2, c1, c2, k, ind, kl: integer;
  sqr, ct1, ct2, square1, square2: square;
	nsqr1, nsqr2: array[1..5,1..5] of real;
	match: array [1..15] of matchrec;
	temp: matchrec;
  Infile, Outfile: text;
  freq: array[1..26] of frecord;
  Ch: char;
	flag, popflag, pushflag: boolean;		{ sort flag, stack flags }
	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 lowerc (C: char): char;	{ returns lowercase of a letter }
 begin
  lowerc := C;		
  if ord(C) > 64 then	{ only change it if it is uppercase }
		if ord(C) < 91 then
			lowerc := char(ord(C) + 32);
 end;

 function patstr (cstr: string): string;
  var
   i, j, ls: integer;
   dstr: string[255];
   tpat: array[1..50] of integer;
 begin
		dstr := '';			{ start with blank string }
		ls := length(cstr);	{ get length of string }
		for i := 1 to ls - 1 do
			for j := i + 1 to ls do
				if cstr[i] = cstr[j] then  { found a duplicate }
					begin
						tpat[i] := j - i;	  { gives integer distance }
						break;  { found one for this i, don't look further }
					end
				else
					tpat[i] := 0;	{ no duplicate found for this i }
		for i := 1 to ls - 1 do	{ ignore last position: it is 0 }
			if tpat[i] > 9 then
				dstr := concat(dstr, chr(tpat[i] + 55))		{ letter }
			else
				dstr := concat(dstr, chr(tpat[i] + 48));	{ number }
		patstr := dstr;		{ result returned by function }
 end;	{ of function patstr }

 procedure DrawCipher;
 var
 i, j: integer;
 begin
		for i := 1 to nl do
			begin
				for j := 1 to nc div 2 do		{ do full lines of cipher }
					write(str[1 + nc * (i - 1) + 2 * (j - 1)], str[nc * (i - 1) + 2 * j], ' ');
				write(i * (nc div 2) : 4);
				writeln;
				for j := 1 to nc div 2 do		{ do full lines of solution }
					write(lowerc(sol[1 + nc * (i - 1) + 2 * (j - 1)]), lowerc(sol[nc * (i - 1) + 2 * j]), ' ');
				writeln;
				writeln;
			end;
		for i := 1 to nr do		{ do remainder of cipher }
			write(str[1 + nl * nc + 2 * (i - 1)], str[nl * nc + 2 * i], ' ');
		write(nd : 4);
		writeln;
		for i := 1 to nr do		{ do remainder of solution }
			write(lowerc(sol[1 + nl * nc + 2 * (i - 1)]), lowerc(sol[nl * nc + 2 * i]), ' ');
		writeln;
		writeln;
 end;	{ of procedure DrawCipher}
 
 procedure FauxEncipher(str1: string);
 
{		We will use plaintext squares as faux cipher squares to encipher the tip.  Then we will drag }
{		the faux enciphered tip through the cipher, looking for matches.  We want pattern matches }
{		between first letters of faux ciphertext digrams and real ciphertext digrams, as well as pattern }
{		matches between 2nd letters.  dig1 is a tip digram, dig2 is the cipher of that tip digram.  ctip1 is }
{		a string of the first letters of the enciphered tip digrams, ctip2 is a string of the 2nd letters }
 var
	i, j, k, kmax, r1, r2, c1, c2: integer;
	dig1, dig2: string[2];
	ctip1, ctip2: string;
	begin
		dig2 := '  ';
		ctip1 := '';
		ctip2 := '';
		kmax := length(str1) div 2;		{ number of digrams }
		for k := 1 to kmax do
			begin
				dig1 := copy(str1, 2*k - 1, 2);		{ get tip digram }
				for i := 1 to 5 do
					for j := 1 to 5 do
						begin
							if dig1[1] = sqr[i, j] then
								begin
									r1 := i;		{ row number of first letter }
									c1 := j;		{ column number of first letter }
								end;
							if dig1[2] = sqr[i, j] then
								begin
									r2 := i;		{ row number of second letter }
									c2 := j;		{ column number of second letter }
								end;
						end;	{ of ij loop }
				dig2[1] := sqr[r1, c2];	{ faux cipher digram, letter 1 }
				dig2[2] := sqr[r2, c1];	
				ctip1 := concat(ctip1, dig2[1]);	{ build first letter string }
				ctip2 := concat(ctip2, dig2[2]);
			end;	{ of k loop }
		tippatstr1 := patstr(ctip1);
		tippatstr2 := patstr(ctip2);
	end;	{ of procedure FauxEncipher }

Procedure ChiSquare(str1, str2: string);	{ ct squares ct1 and ct2 for calculating chisq }
{ enters knowing str1 in DragTip = tip1 or tip2, str2 = ciphertext match piece }
 var
	i, j, k, kmax, r1, r2, c1, c2, n: integer;
	dig1, dig2: string[2];
	chisq: real;
	begin
		for i := 1 to 5 do
			for j := 1 to 5 do
				begin			{ start with empty squares }
					ct1[i, j] := '.';
					ct2[i, j] := '.';
				end;

{		Populate ciphertext squares ct1 and ct2 }

		kmax := length(str1) div 2;		{ number of digrams }
		for k := 1 to kmax do
			begin
				dig1 := copy(str1, 2*k - 1, 2);		{ get tip digram }
				dig2 := copy(str2, 2*k - 1, 2);		{ get matching ct digram }
				for i := 1 to 5 do
					for j := 1 to 5 do
						begin
							if dig1[1] = sqr[i, j] then
								begin
									r1 := i;		{ row number of first pt letter }
									c1 := j;		{ column number of first pt letter }
								end;
							if dig1[2] = sqr[i, j] then
								begin
									r2 := i;		{ row number of second pt letter }
									c2 := j;		{ column number of second pt letter }
								end;
						end;	{ of ij loop }
				ct1[r1,c2] := dig2[1];	{ first ct letter, goes in ct1 }
				ct2[r2,c1] := dig2[2];	{ second ct letter, goes in ct2 }
			end;	{ of k loop }

	{		Now calculate chisq }
	
		chisq := 0;
		n :=0;
		for i := 1 to 5 do
			for j := 1 to 5 do
				if ct1[i,j] <> '.' then
					for k := 1 to 26 do
						if ct1[i,j] = freq[k].let then
							begin
								chisq := chisq + (freq[k].fr1-nsqr1[i,j])*(freq[k].fr1-nsqr1[i,j])/nsqr1[i,j];
								inc(n);
							end;
		for i := 1 to 5 do
			for j := 1 to 5 do
				if ct2[i,j] <> '.' then
					for k := 1 to 26 do
						if ct2[i,j] = freq[k].let then
							begin
								chisq := chisq + (freq[k].fr2-(nsqr2[i,j]))*(freq[k].fr2-(nsqr2[i,j]))/nsqr2[i,j];
								inc(n);
							end;
		match[nm].chi := chisq/(n-1);		{ store chisq in record }
	end;	{ of procedure ChiSquare }

Procedure DragTip(str1,str3:string);	{ str1 is Tip1 or Tip2, str3 is 'Tip1' or 'Tip2' }
 var
	str2, cstr1, cstr2, chk: string;
	i, ii, imax, ltip: integer;
	mflag: boolean;
	begin
		ltip := length(str1);
		imax := ltip div 2;
		chk := copy(zero,1,imax - 1);	{ get string of zeros as long as pattern string }
		mflag := true;								{ means didn't find match }
		for ii := 1 to nd - ltip + 1 do
			begin
				str2 := copy(str, 2*ii - 1, ltip);	{ grab piece of ciphertext }
				cstr1 := '';
				cstr2 := '';
				for i := 1 to imax do
					begin
						cstr1 := concat(cstr1, str2[2*i - 1]);	{ odd letters }
						cstr2 := concat(cstr2, str2[2*i]);			{ even letters }
					end;
				if not((tippatstr1=chk) and (tippatstr2=chk)) then	{ not both non-pattern }
					if (patstr(cstr1) = tippatstr1) and (patstr(cstr2) = tippatstr2) then
						begin												{ found match }
							writeln('Match found for ',str3,' at digram #', ii : 3, ': ', str2);
							inc(nm);									{ increment match count }
							match[nm].ct := str2;			{ store ciphertext string }
							match[nm].tip := str1;		{ store tip string }
							ChiSquare(str1,str2);			{ get chisq, store in record }
							mflag := false;						{ found at least 1 match }
						end;
			end;	{ of ii loop }
		if mflag then
			writeln('No match found for ',str3);
	end;	{ of procedure DragTip }
	
 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 SaveSquares;
 var
	SE: stackentry;
 begin
		with SE do
			begin			{ load stackentry }
				ct1 := square1;
				ct2 := square2;
			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 }
				square1 := ct1;
				square2 := ct2;
			end;
 end;		{ of procedure RecallSquares }

 Procedure Stop;
 begin
		write(Outfile,sol);
		close(Outfile);
		writeln('Solution written to text file: ',outstr);	
		halt;
 end;	{ of Procedure Stop }

begin			{ main program }
	title := '      FOURSQUARE ASSISTANT';
	alph := 'ABCDEFGHIKLMNOPQRSTUVWXYZ';
	pta := 'abcdefghiklmnopqrstuvwxyz';		{ 25 letters }
	zero := '0000000000000000';		{ use to reject non-pattern words }
	n1str := '502508747775351251132400480420413402344753456302269635858486080043104168118';
	n2str := '362537932540509183255381718146452252366834466433247477789605119062076152104';

{		Set up plaintext square }

	for i := 1 to 5 do
		for j := 1 to 5 do
			sqr[i, j] := alph[j + 5 * (i - 1)];

{		Set up normal frequency squares taken from digram frequencies n1str and n2str, per 1 digram }

 for i := 0 to 24 do
			begin																				{ hundreds                   tens                        units }
				nsqr1[(i div 5)+1,(i mod 5)+1] := 0.01*(ord(n1str[3*i+1])-48 + 0.1*(ord(n1str[3*i+2])-48) + 0.01*(ord(n1str[3*i+3])-48));
				nsqr2[(i div 5)+1,(i mod 5)+1] := 0.01*(ord(n2str[3*i+1])-48 + 0.1*(ord(n2str[3*i+2])-48) + 0.01*(ord(n2str[3*i+3])-48));
			end;
			
{		Now get con  }

	write('ENTER THE FILE NAME ("-1" to quit): ');
	readln(str1);							{ read in filename }
	if str1 = '-1' then
		halt;
	assign(Infile, str1);			{ open Infile with title str1 }
	reset(Infile);	
	outstr := concat(str1,'.out');
	assign(Outfile, outstr);				
	rewrite(Outfile);					{ open output file }
	readln(Infile, str);			{ read con into str }
	readln(Infile, tip);			{ read in tip }
	len := length(str);
	if len mod 2 > 0 then
		begin
			writeln('Length of string not an even number');
			halt;
		end;
	nd := len div 2;					{ number of digrams in cipher }
	lt := length(tip);				{ length of tip }
	nl := len div nc;					{ number of lines with nc/2 digrams }
	nr := len mod nc div 2;		{ number of digrams left over }
	Writeln(title);
	Writeln('Length=', len : 3, '  Tip= ', tip, '   # of digrams in cipher=', nd : 3);
	nm := 0;									{ number of matches found }
	for i := 1 to 15 do
		match[i].chi := 10;			{ chisq score, make it large }
	pushflag := false;				{ error on push flag }
	popflag := false;					{ error on pop flag }
	S.top := 0;								{ initialize saving stack }

{		Create Expected Frequency Counts for ct1 (nsqr1) and ct2 (nsqr2) for this con }
{		and initialize ct squares with "." }

	for i := 1 to 5 do
		for j := 1 to 5 do
			begin
				nsqr1[i,j] := nd*nsqr1[i,j];
				nsqr2[i,j] := nd*nsqr2[i,j];
				square1[i, j] := '.';
				square2[i, j] := '.';
			end;
			
{		Initialize frequency records and column array }

	for i := 1 to 26 do
		begin
			freq[i].let := chr(64 + i);			{ initialize ciphertext alphabet A-Z }
			freq[i].fr1 := 0;					{ intialize frequency count }
			freq[i].fr2 := 0;					{ intialize frequency count }
		end;

{		Get puzzle frequency distribution }

	for i := 1 to nd do
		begin
			j := ord(str[2 * i - 1]) - 64;		{ get index into first character of digram }
			freq[j].fr1 := freq[j].fr1 + 1;		{ increment frequency count }
			j := ord(str[2 * i]) - 64;				{ get index into 2nd character of digram }
			freq[j].fr2 := freq[j].fr2 + 1;		{ increment frequency count }
		end;

{		Process Tip }

	if lt mod 2 > 0 then
		begin
			writeln;
			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);
	write('Tip2= ');
	for i := 1 to len2 do
		write(tip2[2 * i - 1], tip2[2 * i], ' ');	{ write out tip2 }
	writeln('  Length=', lt2 : 2);
	writeln;
	FauxEncipher(Tip1);
	DragTip(Tip1,'Tip1');
	FauxEncipher(Tip2);
	DragTip(Tip2,'Tip2');
	writeln;
	sol := '';
	for i := 1 to len do
		sol := concat(sol, '.');

{		Sort matches by chisq value, lowest is first, or enter manually }

	if nm > 0 then	{ sort }
		begin
			repeat
				flag := false;		{ all sorted }
				for i := 1 to nm -1 do
					if match[i].chi > match[i+1].chi then
						begin
							temp := match[i];
							match[i] := match[i+1];
							match[i+1] := temp;
							flag := true;
						end;
			until flag = false;	{ all sorted }
			str1 := match[1].tip;				{ best tip form }
			str2 := match[1].ct;				{ ciphertext from match }
		end
	else		{ will enter tip manually }
		begin
			DrawCipher;
			writeln('No tip match, so form of tip and location must be given.');
15:
			write('ENTER FORM OF TIP; Tip1 or Tip2: ');
			readln(str3);
			if str3 = '-1' then
				halt;
			str3 := upperc(str3);		{ get uppercase }
			if str3 = 'TIP1' then
				str1 := Tip1					{ tip letters }
			else if str3 = 'TIP2' then
				str1 := Tip2
			else
				begin
					writeln('TIP TITLE ENTERED IN ERROR',chr(7));
					goto 15;						{ try again }
				end;
			str2 := str1;						{ strings the same length }
			write('ENTER TIP AT DIGRAM #: ');
			readln(kl);
			str2 := copy(str,2*kl-1,2*length(str1) div 2);	{ grab ct }
			writeln;
		end;
		
{		Now have str1 and str2 needed to process tip letters }	
{		Populate ciphertext squares square1 and square2 from tip }

	kmax := length(str1) div 2;	{ number of digrams }
	for k := 1 to kmax do
		begin
			dig1 := copy(str1, 2*k - 1, 2);		{ get tip digram }
			dig2 := copy(str2, 2*k - 1, 2);		{ get matching ct digram }
			for i := 1 to 5 do
				for j := 1 to 5 do
					begin
						if dig1[1] = sqr[i, j] then
							begin
								r1 := i;		{ row number of first pt letter }
								c1 := j;		{ column number of first pt letter }
							end;
						if dig1[2] = sqr[i, j] then
							begin
								r2 := i;		{ row number of second pt letter }
								c2 := j;		{ column number of second pt letter }
							end;
					end;	{ of ij loop }
			square1[r1,c2] := dig2[1];	{ first ct letter, goes in square1 }
			square2[r2,c1] := dig2[2];	{ second ct letter, goes in square2 }
		end;	{ of k loop }

{		Now get input to add more letters }

	repeat

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

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

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

{		Start with first character of ct digram }

				Ch := str[2 * i - 1];			{ get first char of ct digram }
				for j := 1 to 5 do				{ find it in square }
					for k := 1 to 5 do
						if Ch = square1[j, k] then	{ found it }
							begin
								r1 := j;
								c1 := k;
							end;

{		Now do second character of ct digram }

				Ch := str[2 * i];					{ get second char of ct digram }
				for j := 1 to 5 do				{ find it in square }
					for k := 1 to 5 do
						if Ch = square2[j, k] then	{ found it }
							begin
								r2 := j;
								c2 := k;
							end;

{		Do valid letters in rectangular relationship }

				if r1 * r2 * c1 * c2 > 0 then	{ all are present! }
					begin
						sol[2 * i - 1] := pta[5 * (r1 - 1) + c2];
						sol[2 * i] := pta[5 * (r2 - 1) + c1];
					end;
			end;	{ of i loop }

{		Draw cipher and solution in digram form }

		DrawCipher;

{		Draw ptsquare1 and ctsquare1 }

		for i := 1 to 5 do
			begin
				for j := 1 to 5 do
					write(pta[j + 5 * (i - 1)], ' ');
				write('| ');						{ vertical divider }
				for j := 1 to 5 do
					write(square1[i, j], ' ');
				writeln;
			end;	{ of i loop }

{		Draw horizontal divider }

		for i := 1 to 21 do
			write('-');
		writeln;

{		Draw ctsquare2 and ptsquare2 }

		for i := 1 to 5 do
			begin
				for j := 1 to 5 do
					write(square2[i, j], ' ');
				write('| ');
				for j := 1 to 5 do
					write(pta[j + 5 * (i - 1)], ' ');
				writeln;
			end;
		
{		Draw solution as a continuous string }

		writeln;
		for i := 1 to 80 do
			if i <= len then
				write(sol[i]);
		writeln;
		if len > 80 then
			for i := 81 to 160 do
				if i <= len then
					write(sol[i]);
		writeln;
		if len > 160 then
			for i := 161 to 240 do
				if i <= len then
					write(sol[i]);
		writeln;
		if len > 240 then
			for i := 241 to len do
				write(sol[i]);
				
{		Now get input: plaintext and ciphertext digrams }

12:
		write('ENTER THE PLAINTEXT DIGRAM  ("-1" to quit,"0" to undo last entry): ');
		readln(ptd);
		if ptd = '-1' then
			stop;
		if ptd = '0' then
			begin
				RecallSquares;
				goto 14;
			end;
		if length(ptd) <> 2 then
			begin
				write(chr(7));
				goto 12;
			end;
		ptd := concat(lowerc(ptd[1]),lowerc(ptd[2]));     { work with lowercase }
		ind := pos(ptd[1],pta);				{ index into 25-letter pt alphabet }
		r1 := (ind-1) div 5 + 1;			{ row number in pt1 square }
		c1 := (ind-1) mod 5 + 1;			{ column number in pt1 square }
		ind := pos(ptd[2],pta);				{ index into 25-letter pt alphabet }
		r2 := (ind-1) div 5 + 1;			{ row number in pt1 square }
		c2 := (ind-1) mod 5 + 1;			{ column number in pt1 square }
		SaveSquares;	{ if you get here, save current squares before modifying with new input }

{		We now have row and column info for the pt digram.  Get ct digram and store }

13:
		write('ENTER THE CIPHERTEXT DIGRAM ("-1" to quit): ');
		readln(ctd);
		if ctd = '-1' then
			stop;
		if length(ctd) <> 2 then
			begin
				write(chr(7));
				goto 13;
			end;
		square1[r1,c2] := upCase(ctd[1]);			{ store 1st letter of ct digram }
		square2[r2,c1] := upCase(ctd[2]);			{ store 2nd letter of ct digram }
		writeln;
14:
  until 1 = 0;										{ do forever }
end.