maze.pas

迷宫生成和探索程序。DOS,PASCAL

uses Graph,crt;
const
	s=9734;
   MaxFind=10;
   MaxGrow=200;
Const
{maze size}
   MaxStack=8000;
	Nxm=300;
   Nym=210;
	Nx:Integer=100;
   Ny:Integer=80;
type
	stacktype=Record
   	X,Y:Integer;
   end;
	StackArr=array[1..maxstack] of Stacktype;
const
	Idx:array[0..3] of Integer=(1,0,-1,0);
	Idy:array[0..3] of Integer=(0,-1,0,1);
var
   Nxy:LongInt;
   A: array[0..nxm,0..nym] of byte;
   {Byte Value of A (binary): [00YXcccc] }
   Xw,Yw,MaxX,MaxY:Integer;
	IColor:Byte;
	Ndelay:LongInt;
	Kcolor:Boolean;
   Stack:^StackArr;
   Istack:Integer;
	IYDoor:Integer;

procedure VgaDrive; 	external; {$L EGAVGA.OBJ }

{------ BEGIN OF STACK ADT ------ }
procedure InitStack;
begin
	New(Stack);
   Istack:=0;
end;

Procedure Push(I,j:Integer);
begin
	If Istack>=MaxStack then
   begin Writeln('Stack overflow !'); Halt; end;
	Inc(Istack);
   With Stack^[Istack] do
	begin
		X:=i; Y:=J;
	end;
end;

Procedure GetTop(var I,j:Integer);
begin
   With Stack^[Istack] do
   begin
		I:=X; J:=Y;
	end;
end;

Procedure Pop;
begin
	If IStack>0 then Dec(Istack);
end;

{------ END OF STACK ADT ------ }

procedure WaitKey(var ch:Char);
begin
   repeat  until keypressed;
   ch:=readKey;
end;

procedure GetParameters;
var
	S:String;
   C:Char;
   I:Integer;
begin
	Clrscr;
   Write('Enter Maze size_X, [3..300], (Def:',Nx,') :');
	Readln(S);
	if S<>'' then Val(S,Nx,I);
	if Nx>Nxm then Nx:=Nxm;
	if Nx<3 then Nx:=3;
	Write('Enter Maze size_Y, [3..210], (Def:',Ny,') :');
	Readln(S);
	if S<>'' then Val(S,Ny,I);
	if Ny>Nym then Ny:=Nym;
	if Ny<3 then Ny:=3;
	Nxy:=LongInt(Nx-1)*(Ny-1);
	Ndelay:=15000000 div Nxy;
	if Ndelay>30000 then Ndelay:=30000;


   Write('Color or Mono: (C/M), (Def:M) :');
	Readln(S);
   C:='M';
	if S<>'' then C:=upcase(S[1]);
   Kcolor:= (C='C');
end;

procedure NextStep(Km:Boolean; I,J:integer;
						var I1,j1:Integer; var Success:boolean);
{ Km: True=to find root, False=to find space }
var
	Ns0,NS:integer;
begin
   NS0:=Random(4);
   Ns:=Ns0;
	repeat
	   I1:=I+Idx[Ns];
		J1:=J+Idy[Ns];
      if not(Km xor (A[i1,j1]>0)) then
		begin
         Success:=True;
         Exit;
      end;
      Ns:=(Ns+1) mod 4;
   until Ns=Ns0;
   Success:=False;
end;

procedure DrawWall(i,j,i1,j1:Integer);
{precondition: (i,j) is used, (i1,j1) is space,
	then color of ground is 15 }
var
	C:Byte;
   I2,j2:Integer;
begin
	C:=A[i,j] and 15; {And 00001111}
	if C=15 then
   begin
   	C:=Icolor; Icolor:=(Icolor mod 14)+1;
	end;
   if not Kcolor then C:=15;
	SetColor(C);
	line(i*xw,j*yw,i1*xw,j1*yw);

   A[i1,j1]:=C;

   if i=i1 then
   begin
	   if J1>J then J2:=J1 else J2:=J;
      A[i,j2]:=A[i,J2] or 32;
   end else
   begin
	   if I1>I then I2:=I1 else I2:=I;
      A[I2,J]:=A[I2,J] or 16;
   end;
end;

procedure OpenDoor;
begin
	IyDoor:=(ny div 2);
   Setcolor(0);
	Line(0,iyDoor*Yw,0,(IyDoor+1)*Yw);
	Line(Nx*Xw,iyDoor*Yw,Nx*Xw,(IyDoor+1)*Yw);
   Setcolor(7);

	A[0,IyDoor+1]:=A[0,IyDoor+1] and (not 32);
	A[Nx,IyDoor+1]:=A[Nx,IyDoor+1] and (not 32);
end;

procedure GraphInit;
var
	Gd,Gm:integer;
begin
	if RegisterBGIdriver(@VGADrive) < 0 then
	begin
	  Writeln('Error registering driver: ',GraphErrorMsg(GraphResult));
	  Halt(1);
	end;
	{Gd:=DETECT;}
   gd:=VGA;
	gm:=VGAHI;
	initGraph(Gd,Gm,'');
	maxx:=GetMaxX; {GetMaxX: 639}
	maxy:=GetMaxY; {GetMaxY: 479}
	Xw:=MaxX div Nx;
	Yw:=MaxY div Ny;
end;

procedure CreateMaze;
var
	x:longInt;
	Nevent,Idelay:LongInt;
	NFind,Ngrow:Integer;
	i,j,i1,j1:Integer;
	ks:Boolean;
	ch:Char;
begin
	for i:=0 to Nx do
		for j:=0 to Ny do
			A[i,j]:=0;
   for j:=0 to ny do
	begin
  		A[ 0,j]:=A[ 0,j] or 47; { 47=15 or 32 }
  		A[Nx,j]:=A[Nx,j] or 47;
	end;
   for i:=0 to nx  do
	begin
		A[i, 0]:=A[i, 0] or 31; { 31= 15 or 16}
		A[i,Ny]:=A[i, 0] or 31;
	end;
   SetColor(15);
   Rectangle(0,0,Nx*Xw,Ny*Yw);
   repeat
	   Nevent:=0;
	   x:=0;
		repeat
	     	i:=x mod (NX-1) + 1;
			j:=x div (NX-1) + 1;
	      if A[i,j]=0 then
	      begin
				{ find root }
	         Inc(Nevent);
            NFind:=0;
		      repeat
					NextStep(True,i,j,i1,j1,Ks);
	            if not Ks  then
	            begin
				      i:=i1;
				      j:=j1;
					end;
               inc(NFind);
			   until Ks or (Nfind>=MaxFind);
            if ks then
            begin
	            DrawWall(I1,j1,i,j);
					{Grow branch}
	            NGrow:=0;
				   repeat
				   	NextStep(False,i,j,i1,j1,Ks);
				      if Ks then
						begin
			            DrawWall(i,j,I1,j1);
		               i:=i1;
					      j:=j1;
							Inc(NGrow);
			         end;
					For IDelay:=1 to Ndelay do;
 				   until (Not Ks) or (NGrow>=MaxGrow);
            end;
			end;
			x:=(x+s) mod Nxy;
		until x=0;
{      Write(Nevent,' ');}
	until	Nevent=0;
	OpenDoor;
	sound(880);   Delay(500);   Nosound;
	WaitKey(ch);
end;

Function Jy(J:Integer):Integer;
begin
 	Jy:=J*Yw+Yw div 2;
end;

Function Jx(J:Integer):Integer;
begin
  	Jx:=J*Xw+Xw div 2;
end;

Function GetWall(i,j,Id:Integer):Boolean;
var
	K:Boolean;
begin
	case Id of
   0: K:=(A[I+1,J+1] and 32)=32;
   1: K:=(A[I+1,J  ] and 16)=16;
   2: K:=(A[I  ,J+1] and 32)=32;
   3: K:=(A[I+1,J+1] and 16)=16;
   end;
   getWall:=k;
end;

procedure MouseSearch;
var
 	I,j,i1,j1,i2,j2:Integer;
   X,y,x1,y1:Integer;
   Id:Integer;
   IDelay:LongInt;
   Ch:Char;
begin
	I:=0; J:=IyDoor;
   Id:=0;
   SetColor(13);
   X:=Jx(i); Y:=Jy(j);
   Line(0,y,x,y);
   Push(-1,J);
   Repeat
      Id:=(Id+1) Mod 4;
   	While GetWall(i,j,Id) do
      begin
      	Id:=(Id+3) mod 4;  { id=id-1 }
      End;
      I1:=I+Idx[Id];
		J1:=J+Idy[Id];
      X1:=Jx(I1); Y1:=Jy(J1);
      GetTop(I2,J2);
      if (i2=i1) and (j2=J1) then
		begin
      	Pop;
			Setcolor(0);
      end Else
		begin
			Push (I,J);
			Setcolor(13);
      end;
		Line(x,y,x1,y1);
      I:=i1; J:=J1;
      X:=X1; Y:=Y1;
		For IDelay:=1 to Ndelay do;
		delay(1);
      if Keypressed then ch:=Readkey;
   until (I=Nx) or (ch=#27);
   Push(i,j);
	Sound(1340); delay(300); nosound;
end;

Procedure RedrawMaze;
var
	i,j:Integer;
begin
	ClearDevice;
	SetColor(6);
	For j:=0 to Ny do
	begin
		for i:=1 to Nx do
		begin
			if (A[i,j] and 16) =16 then
			line((i-1)*Xw,j*Yw,i*Xw,j*Yw);
		end;
		Delay(1);
	end;
	For i:=0 to Nx do
	begin
		for j:=1 to Ny do
		begin
			if (A[i,j] and 32) =32 then
         line(I*Xw,(j-1)*Yw,i*Xw,j*Yw);
      end;
		Delay(10);
	end;
end;

procedure SecondSearch;
var
	k:integer;
   i,j,i1,j1:Integer;
   ch:Char;
begin
	I:=Stack^[1].x;
	J:=Stack^[1].y;
   {Clear old path on screen}
   Setcolor(0);
   for k:=2 to Istack do
   begin
		I1:=Stack^[k].x;
		J1:=Stack^[k].y;
		line(jx(i),jy(j),jx(i1),jy(j1));
		I:=I1; J:=J1;
	end;
	{Redraw Maze}
	RedrawMaze;
	{Redraw found path}
	I:=Stack^[1].x;
	J:=Stack^[1].y;
   Setcolor(10);
   for k:=2 to Istack do
   begin
		I1:=Stack^[k].x;
		J1:=Stack^[k].y;
		line(jx(i),jy(j),jx(i1),jy(j1));
      I:=I1; J:=J1;
		delay(20);
	end;

   Sound(440); delay(300); nosound;
   WaitKey(ch);
end;

begin
   DirectVideo:=False; {enable to write text on graphic screen }
	Randomize;
	Icolor:=1;

	getParameters;
	GraphInit;
	CreateMaze;
	InitStack;
	MouseSearch;
	SecondSearch;
	closeGraph;
end.