program minesweep; {*minesweeper game*}
{* (c) Dave Rusin 7/27/1993 *}

{$V-} {*allows video changes*}

const
	MAXROWS=22;
	MAXCOLS=39;
	MAXSQUARES=1000; {*=NUMROWS*NUMCOLS*}
	MAXBOMBS=300; {*a reasonable fraction of MAXSQUARES *}

type grid=array[1..MAXROWS,1..MAXCOLS] of integer;

var	hidden,known,blanksleft,bombsleft: grid;
	dead: boolean;
	numrows,numcols,numsquares,numbombs,thinkdepth,markedright,markedwrong,
		currmove,x_pos,y_pos,nummoves,success: integer;

{**************************GENERAL FUNCTIONS*********************************}
function sign(x:integer):integer;
begin
	if x=0 then sign:=0;
	if x>0 then sign:=1;
	if x<0 then sign:=-1;
end;

function InGrid(x,y:integer):boolean;
begin if (x>0) AND (x<=NUMROWS) AND (y>0) AND (y<=NUMCOLS) then InGrid:=TRUE
	else InGrid:=FALSE; end;

function isclose(a,b,c,d:integer):boolean;
begin
	isclose:=TRUE;
	if (a-c>1) or (c-a>1) or (b-d>1) or (d-b>1) then isclose:=FALSE;
end;

procedure MakeNewXY(x,y,dir: integer; var x1,y1:integer);
var     i,j:integer;
begin
	i:=0;j:=0;
	if dir<=3 then I:=1;
	if dir>=7 then i:=-1;
	if (dir=1) OR (dir=4) OR (dir=7) then j:=-1;
	if (dir=3) OR (dir=6) OR (dir=9) then j:=+1;
	x1:=x+i;
	y1:=y+j;
end;

{******************************INITIALIZE****************************************}

procedure WriteRim;
begin
	ClrScr;
	LowVideo;
	GoToXY(1,1);
	Writeln('Arrows:move; U:uncover; B:mark as bomb; H:Help; Q:quit');
	Writeln('S:all neighbors safe; A: all neighbors bombs');
	{*note: what about '?: mark as "?"; T:think' *}
	GotoXY(50,2);
	HighVideo;Writeln('You MUST push Numlock key!');LowVideo;
	GotoXY(1,23);
	Write('Bombs marked:',markedright+markedwrong);
	GotoXY(20,23);
	Write('Bombs hidden:',NUMBOMBS);
	Gotoxy(40,23);
	write('moves used:',nummoves);
end;

procedure initialize;
var     X: array[1..MAXSQUARES] of boolean;

procedure RandSet(m:integer);
var     i,j,l,k:integer;
begin
	for i:=1 to NUMSQUARES do X[i]:=FALSE;
	for i:=1 to m do begin
		k:=1+round(random(NUMSQUARES-i+1));

		if k<1 then k:=1;
		if k>NUMSQUARES then k:=NUMSQUARES;
{*kludge*}
		l:=0;
		while k>0 do begin
			l:=l+1;
			if X[l]=FALSE then k:=k-1;
			end;
		X[l]:=TRUE;
		end;
end;

procedure Convert;
var     i,j,k:integer;
begin
	for i:=1 to NUMROWS do begin
		for j:=1 to NUMCOLS do begin
			k:=j+(i-1)*NUMCOLS;
			if X[k] then hidden[i,j]:=10 else hidden[i,j]:=0;
			end;
		end;
end;

procedure FigureNumbers;
var     i,j,k,l,m:integer;
begin
	for i:=1 to NUMROWS do
		for j:=1 to NUMCOLS do
			if hidden[i,j]=10 then
				for k:=1 to 9 do if k<>5 then begin
					MakeNewXY(i,j,k,l,m);
					if (InGrid(l,m)) AND (hidden[l,m]<10) then hidden[l,m]:=hidden[l,m]+1;
					end;
	for i:=1 to NUMROWS do for j:=1 to numcols do bombsleft[i,j]:=-1;
	for i:=1 to NUMROWS do for j:=1 to numcols do blanksleft[i,j]:=8;
	for i:=1 to NUMROWS do begin blanksleft[i,1]:=5;blanksleft[i,numcols]:=5;end;
	for j:=1 to numcols do begin blanksleft[1,j]:=5;blanksleft[numrows,j]:=5;end;
	blanksleft[1,1]:=3;blanksleft[1,numcols]:=3;
	blanksleft[numrows,1]:=3;blanksleft[numrows,numcols]:=3;
end;

procedure Nullknown;
var i,j:integer;
begin   for i:=1 to NUMROWS do for j:=1 to NUMCOLS do known[i,j]:=-1;
end;

begin
	dead:=false;
	markedright:=0;
	markedwrong:=0;
	x_pos:=1;
	y_pos:=1;
	numrows:=20;
	Write('how many rows? (up to 20) ');readln(numrows);
	numcols:=39;
	Write('how many columns? (up to 39) ');readln(numcols);
	numsquares:=numrows*numcols;
	numbombs:=round(numsquares/7);
	Write('how many bombs? (suggest about ',numbombs,') ');readln(numbombs);
	nummoves:=0;
	thinkdepth:=0;
	RandSet(NUMBOMBS);
	Convert;
	FigureNumbers;
	NullKnown;
	WriteRim;
end;

{********************************DISPLAY************************************}
procedure ScrJump(x,y:integer);
begin
	GotoXY(2*y-1,x+2);
end;

procedure ShowKnown(i,j:integer);
var k:integer;
begin
	k:=known[i,j];
	if k=-1 then write('?');
	if k=10 then write('B');
	if k=0 then write(' ');
	if (k>0) AND (k<10) then write(k);
end;

procedure display;
var     i,j,k:integer;
begin
	ScrJump(1,1);
	for i:=1 to NUMROWS do begin
		for j:=1 to NUMCOLS do begin
			ShowKnown(i,j);
			write(' ');
			end;
		writeln;
		end;
	{*now higlight current position and neighbors?*}
	ScrJump(x_pos,y_pos);
end;


procedure reviseDisplay;
var     i,x,y:integer;
begin
	HighVideo;
	for i:=1 to 9 do begin
		makenewxy(x_pos,y_pos,i,x,y);
		if ingrid(x,y) then begin
			ScrJump(x,y);
			ShowKnown(x,y);
			end;
		end;
	SCrJump(x_pos,y_pos);
	LowVideo;
end;

procedure Unhighlight;
var     i,x,y:integer;
begin
	LowVideo; {*should be unnecessary*}
	for i:=1 to 9 do begin
		makenewxy(x_pos,y_pos,i,x,y);
		if ingrid(x,y) then begin
			ScrJump(x,y);
			ShowKnown(x,y);
			end;
		end;
	ScrJump(x_pos,y_pos);
end;

procedure DrawBoundary;
var	i,j,x_root,y_root,ord:integer;
	order,pred_x,pred_y,last:grid;

procedure findnextcomponent;
var	x,y:integer;
begin
	x:=x_root;y:=y_root;
	while (x<=numrows) AND (order[x,y]<>0) do begin
		if y<numcols then y:=y+1 else begin y:=1; x:=x+1;end;
		end;
	ord:=ord+1;
	order[x,y]:=ord;
	last[x,y]:=0;
	x_root:=x;y_root:=y;
end;

procedure newspot(x,y,i:integer; var x1,y1:integer);
var 	j,a,b,a1,b1:integer;
begin
	a:=1; b:=0;
	for j:=1 to i do begin
		a1:=a-b;
		b1:=a+b;
		a:=sign(a1);
		b:=sign(b1);
		end;
	x1:=x+a;y1:=y+b;
end;

procedure successor(x,y:integer; var x1,y1:integer);
var	done:boolean;
begin
	i:=0;
	done:=false;
	while (i<8) and not done do begin
		NewSpot(x,y,last[x,y]+i,x1,y1);
		if ingrid(x1,y1) then if order[x1,y1]=0 then done:=true;
		i:=i+1;
		end;
	if done then begin
		ord:=ord+1;
		order[x1,y1]:=ord;
		last[x1,y1]:=last[x,y]+i-1;
		if last[x1,y1]>8 then last[x1,y1]:=last[x1,y1]-8; {*now reverse direction:*}
		last[x1,y1]:=last[x1,y1]+3;
		if last[x1,y1]>8 then last[x1,y1]:=last[x1,y1]-8;
		pred_x[x1,y1]:=x;
		pred_y[x1,y1]:=y;
		end
	else begin
		x1:=pred_x[x,y];
		y1:=pred_y[x,y];
		end;
end;

procedure buildtrees;
var	x,y,x1,y1:integer;
begin
	Successor(x_root,y_root,x,y);
	while (x<>x_root) or (y<>y_root) do begin
		successor(x,y,x1,y1);
		x:=x1;y:=y1;
		end;
end;

procedure DrawTrees;
var	i,j:integer;
begin
	for i:=1 to numrows do for j:=1 to numcols do if order[i,j]>0 then begin
		scrJump(i,j);write('*');
		end;
end;

procedure drop(i,j,goal:integer);
begin
	if (known[i,j]>-1) or (blanksleft[i,j]=goal) then order[i,j]:=-1;
end;

begin
	x_root:=1;y_root:=1;ord:=0;order[x_root,y_root]:=1;
	for i:=1 to numrows do for j:=1 to numcols do begin 
		order[i,j]:=0;last[i,j]:=0;
		pred_x[i,j]:=i;
		pred_y[i,j]:=j;
		Drop(i,j,8);
		end;
	for i:=1 to numrows do begin
		Drop(i,1,5);
		Drop(i,numcols,5);
		end;
	for j:=1 to numcols do begin
		drop(1,j,5);
		drop(numrows,j,5);
		end;
	drop(1,1,3);drop(1,numcols,3);drop(numrows,1,3);drop(numrows,numcols,3);
	FindNextComponent;
	while x_root<=numrows do begin
		BuildTrees;
		FindNextComponent;
		end;
	DrawTrees;	
end;
{********************************GETINPUT**************************************}
procedure getinput;
var     ch:char;
begin
	currmove:=0;
	{*default  - for invalid moves *}
	Read(kbd,ch);
	if (ch='1') then currmove:=1;
	if (ch='2') then currmove:=2;
	if (ch='3') then currmove:=3;
	if (ch='4') then currmove:=4;
	if (ch='5') then currmove:=5;
	if (ch='6') then currmove:=6;
	if (ch='7') then currmove:=7;
	if (ch='8') then currmove:=8;
	if (ch='9') then currmove:=9;
	if (ch='u') or (ch='U') or (ch=#10) or (ch=#13) then currmove:=10;
	if (ch='b') or (ch='B') then currmove:=11;
	{* if ch=? currmove=13; ...*}
	if (ch='s') or (ch='S') then currmove:=14;
	if (ch='a') or (ch='A') then currmove:=16;
	if (ch='d') or (ch='D') then currmove:=20;
	if (ch='t') or (ch='T') then currmove:=80;
	if (ch='x') or (ch='X') then currmove:=85;
	if (ch='h') or (ch='H') then currmove:=90;
	if (ch='q') or (ch='Q') or (ch=#27) then currmove:=99;
end;
{*******************************GIVEHELP***************************************}
procedure GiveHelp;
var     ch:char;
begin
	ClrScr;
	writeln('There are bombs hidden behind some of the question marks. Use the arrow keys');
	writeln('to move around; when you think you know where a bomb is, mark the location ');
	writeln('with a B. When you have marked all bombs and nothing but bombs, you win.');
	writeln('You  can unmark squares by hitting B again.');
	writeln('At the bottom of the screen is the number of bombs you have marked. Also there');
	writeln('is the number of moves you have taken. You can quit by hitting Q.');
	writeln('');
	writeln('You can uncover squares by hitting U. If there is a bomb there, you lose. If');
	writeln('not, you will see a number which is the number of the 8 adjacent squares which');
	writeln('have bombs. This is the information you should use to figure out where the');
	writeln('bombs are. (If there is no number that means there are no bombs in adjacent');
	writeln('squares. In this case the computer will uncvoer all adjacent squares too.).');
	writeln('');
	writeln('If you have marked as many bombs adjacent to a square as the number in the');
	writeln('square, you can hit S and the computer will uncover all the unmarked adjacent');
	writeln('squares -- if you marked correctly, these will all be safe. This can save you');
	writeln('some time thinking. You can also hit A to mark all remaining neighbors as bombs.');
	writeln('');
	writeln('Hit any key to resume the game.');
	writeln('');
	read(kbd,ch);
	WriteRim;
	Display;
end;
{********************************UPDATE**************************************}
procedure Movepos(n:integer);
var     x_new,y_new:integer;
begin
	MakeNewXY(X_pos,y_pos,n,x_new,y_new);
	if InGrid(x_new,y_new) then begin
		Unhighlight;
		x_pos:=x_new;
		y_pos:=y_new;
		end;
end;

procedure ChgBlanks(x,y,z:integer;bomb:boolean);
var     i,x1,y1:integer;
begin
	for i:=1 to 9 do if i<>5 then begin
		makenewxy(x,y,i,x1,y1);
		if Ingrid(x1,y1) then begin
			blanksleft[x1,y1]:=blanksleft[x1,y1]+z;
			if bomb and (known[x1,y1]>-1) and (known[x1,y1]<10) then bombsleft[x1,y1]:=bombsleft[x1,y1]+z;
			end;
		end;
end;

procedure Uncover; {*I may be assuming square is currently covered!*}
var i,x,y,x1,y1:integer;
begin
	if hidden[x_pos,y_pos]=10 then dead:=TRUE;
	known[x_pos,y_pos]:=hidden[x_pos,y_pos];
	bombsleft[x_pos,y_pos]:=hidden[x_pos,y_pos];
	for i:=1 to 9 do if i<>5 then begin
		makenewxy(x_pos,y_pos,i,x,y);
		if ingrid(x,y) then if (known[x,y]=10) then bombsleft[x_pos,y_pos]:=bombsleft[x_pos,y_pos]-1;
		end;
	ChgBlanks(x_pos,y_pos,-1,FALSE);
	thinkdepth:=thinkdepth+1;
	ScrJump(x_pos,y_pos);ShowKnown(x_pos,y_pos);
	if hidden[x_pos,y_pos]=0 then begin
		for i:=1 to 9 do if i<>5 then begin
			makenewxy(x_pos,y_pos,i,x,y);
			if inGrid(x,y) then if known[x,y]=-1 then begin
				x1:=x_pos;y1:=y_pos;x_pos:=x;y_pos:=y;Uncover;x_pos:=x1;y_pos:=y1;end;
			end;
		end;
end;

procedure MarkBomb;
	var k,s:integer;
begin
	k:=known[x_pos,y_pos];
	if (k=-1) or (k=+10) then begin
		s:=sign(k);
		known[x_pos,y_pos]:=9-k;
		ChgBlanks(x_pos,y_pos,s,TRUE);
		if hidden[x_pos,y_pos]=10 then markedright:=markedright-s else
			markedwrong:=markedwrong-s;
		ScrJump(x_pos,y_pos);
		if s=1 then write('?') else Write('B');
		thinkdepth:=thinkdepth+1;
		end;
	gotoxy(14,23);write(markedright+markedwrong);
	if (markedright=NUMBOMBS) and (markedwrong=0) then dead:=TRUE;
end;

procedure AllNbrBombs;
var     i,k,x,y,x1,y1:integer;
begin
	k:=bombsleft[x_pos,y_pos]-blanksleft[x_pos,y_pos];
	if k=0 then begin
	x1:=x_pos;y1:=y_pos;
	for i:=1 to 9 do if i<> 5 then begin
		makenewxy(x_pos,y_pos,i,x,y);
		if ingrid(x,y) then if known[x,y]=-1 then begin
			x_pos:=x;y_pos:=y;MarkBomb;x_pos:=x1;y_pos:=y1;
			end;
		end;
	end;
end;

procedure NoNbrBombs;
var     i,k,x,y,x1,y1:integer;
begin
	k:=bombsleft[x_pos,y_pos];
	if k=0 then begin
	x1:=x_pos;y1:=y_pos;
	for i:=1 to 9 do if i<> 5 then begin
		makenewxy(x_pos,y_pos,i,x,y);
		if ingrid(x,y) then if known[x,y]=-1 then begin
			x_pos:=x;y_pos:=y;Uncover;x_pos:=x1;y_pos:=y1;
			end;
		end;
	end;
end;

procedure ThinkAhead;
var x,y,i,j:integer;
begin
	thinkdepth:=0;
	x:=x_pos;y:=y_pos;
	for i:=1 to NUMROWS do for j:=1 to NUMCOLS do
		if (blanksleft[i,j]>0) and (blanksleft[i,j]<8) then begin
			x_pos:=i;y_pos:=j;
			NoNbrBombs;
			AllNbrBombs;
			end;
	x_pos:=x;y_pos:=y;
	if thinkdepth>0 then ThinkAhead;
end;

Function common(x,y,x1,y1:integer):integer;
var	c,i,j,x2,y2,x3,y3:integer;
begin
	c:=0;
	for j:=1 to 9 do if j<>5 then begin
		makenewxy(x1,y1,j,x2,y2);
		if ingrid(x2,y2) and isclose(x2,y2,x,y) then if known[x2,y2]=-1 then c:=c+1;
		end;
	common:=c;
end;

procedure markbomb2(x,y:integer);
var	u,v:integer;
begin
	if known[x,y]=-1 then begin
		u:=x_pos;v:=y_pos;x_pos:=x;y_pos:=y;
		markbomb;
		x_pos:=u;y_pos:=v;
		end;
end;

procedure uncover2(x,y:integer);
var	u,v:integer;
begin
	u:=x_pos;v:=y_pos;x_pos:=x;y_pos:=y;
	uncover;
	x_pos:=u;y_pos:=v;
end;

procedure favor(x,y,x1,y1:integer);
var	i,x2,y2:integer;
begin
	success:=1;
	for i:=1 to 9 do if i<>5 then begin
		makenewxy(x,y,i,x2,y2);
		if ingrid(x2,y2) then if not isclose(x2,y2,x1,y1) then Markbomb2(x2,y2);
		end;
	for i:=1 to 9 do if i<>5 then begin
		makenewxy(x1,y1,i,x2,y2);
		if ingrid(x2,y2) then if not isclose(x2,y2,x,y) and (known[x2,y2]=-1) then Uncover2(x2,y2);
		end;				
end;

function Helpful(i,j:integer):boolean;
var	t:boolean;
begin
	t:=ingrid(i,j);
	if t then if (blanksleft[i,j]>0) AND (known[i,j]<10) and (known[i,j]>-1) 
		then t:=TRUE else t:=FALSE;
	helpful:=t;
end;

procedure ActWith(i,j,i1,j1,c:integer);
begin
	{*have boxes of capacities a,c,b, filled with a',c',b' bombs;
	given a'+c', b'+c'=bombsleft. Goal is to show some boxes empty or full
	of bombs.
	If (a'+c')-(b'+c')>(a+c)-c , then  a'-b'>a >=a'>=a'-b', contrad (b'>=0).
	Similarly, if equality holds, b'=0 and a=a': one full box, one empty *}

	if blanksleft[i,j]-c=bombsleft[i,j]-bombsleft[i1,j1] then Favor(i,j,i1,j1);
	if blanksleft[i1,j1]-c=bombsleft[i1,j1]-bombsleft[i,j] then Favor(i1,j1,i,j);
end;

procedure xpert;
var	i,j,k,l,c,i1,j1,i2,j2:integer;
begin
	success:=0;
	for i:=1 to NUMROWS do for j:=1 to NUMCOLS do if (known[i,j]=-1) and (blanksleft[i,j]<=6) then begin
		for k:=1 to 9 do if k<>5 then begin
			makenewxy(i,j,k,i1,j1);
			if helpful(i1,j1) then for l:=1 to 9 do if (l<>5) AND (l<>k) then begin
			makenewxy(i,j,l,i2,j2);
			if helpful(i2,j2) then begin
				c:=common(i1,j1,i2,j2);
				ActWith(i1,j1,i2,j2,c);
				end;
			end;
			end;
		end;
	if success>0 then ThinkAhead;
end;

procedure update;
begin
	nummoves:=nummoves+1;
	gotoxy(51,23);write(nummoves);
	{*if currmove =0 then do nothing*}
	if (currmove >0) AND (currmove <10) then Movepos(currmove);
	if currmove=10 then Uncover;
	if currmove=11 then Markbomb;
	{* if currmove=13 then MarkQuest; ...*}
	if currmove=14 then begin NoNbrBombs;{* display*}; end;
	if currmove=16 then begin AllNbrBombs;{* display*}; end;
	if currmove=20 then DrawBoundary;
	if currmove=80 then ThinkAhead;
	if currmove=85 then Xpert;
	if currmove=90 then GiveHelp;
	if currmove=99 then dead:=true;
end;
{********************************CONCLUDE************************************}
procedure conclude;
begin
	GotoXY(60,23);
	if (markedwrong=0) AND (markedright=NUMBOMBS) then writeln('Congrats! Found all')
		else writeln('Sorry. Blown up');
	{*Guess I should display bomb locations -- after request?*}
end;

{********************************main loop******************************}
begin
	initialize;
	display;
	while not dead do begin
		revisedisplay;
		getinput;
		update;
		end;
	conclude;
end.
I