|
DataMuseum.dkPresents historical artifacts from the history of: RegneCentralen RC759 "Piccoline" |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RegneCentralen RC759 "Piccoline" Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 14080 (0x3700)
Types: TextFile
Names: »LAB1.PAS«
└─⟦b301b5c1d⟧ Bits:30003931/GEM_Develop_disk_2_CDOS.imd Disketter indleveret af Steffen Jensen (Piccolo/Piccoline)
└─⟦this⟧ »LAB1.PAS«
program labyrint;
(*--------------------------------------------------+
! KURSUS.PAS 8-APR-1987 !
! !
! GEM Kursus !
! !
+--------------------------------------------------*)
(*$I gempcon.i *)
(*$I gemptype.i *)
(*$I gempvar.i *)
(*$I vdibnd *)
Type
sider = (nord,oest,syd,vest);
celler = Set Of sider;
rotte = record
x, y : integer;
retn : sider;
end;
Const
k1 = 0.05; (* styrer størrelse af fjerneste mur *)
k2 = 0.2; (* styrer bredde af første mur *)
k3 = 0.3; (* styrer placering af horisont *)
k4 = 0.6; (* forhold mellem bredde af næste og forrige mur *)
maxside = 50;
maxmur = 10;
hel:celler = (.nord,oest,syd,vest.);
tom:celler = (..);
Var
labyrint : Array (.0..maxside,0..maxside.) Of celler;
mig : rotte;
mur : array (.0..maxmur.) of record x1,y1,x2,y2 : integer end;
ude, tegn : boolean;
labxmax, labymax, maxn : integer;
intptsout : array_57;
gemglb : record
retur,
handler : integer;
vmonitor : boolean;
my_intin : intin_ARRAY;
xy4 : ARRAY_4;
end;
Procedure vislabyrint(x,y:integer);
Var
i,j : integer;
Begin
For j:=y+1 downto 0 do
Begin
for i:=0 to x+1 do
Begin
If vest In labyrint(.i,j.) then write('!') else write ('.');
If syd In labyrint(.i,j.) then write('..') else write (' ');
End;
writeln;
End;
End;
Procedure danlabyrint(xmax,ymax:integer);
Var
kandidat : Array (.1..4.) Of sider;
i,j,n : Integer;
x,y : Integer;
dx : Integer;
trin : Integer;
slut : Boolean;
Begin
(* Initialisering af labyrint *)
For j:=1 to ymax do
Begin
labyrint(.0,j.) :=(.oest.);
labyrint(.xmax+1,j.):=(.vest.);
End;
For i:=1 to xmax do
Begin
labyrint(.i,0.) :=(.nord.);
labyrint(.i,ymax+1.):=(.syd.);
For j:=1 to ymax do labyrint(.i,j.):=hel;
End;
labyrint(.0,0.):=tom;
labyrint(.xmax+1,0.):=tom;
labyrint(.0,ymax+1.):=tom;
labyrint(.xmax+1,ymax+1.):=tom;
(* Vælg midtpunkt hvorudfra labyrint dannes *)
x:= xmax div 2 + 1;
y:= ymax div 2 + 1;
n:= xmax*ymax - 1;
dx := 1;
For trin:=1 to n do
begin
repeat
slut:=false;
i:=0;
If labyrint(.x-1,y.)=hel then begin i:=i+1;kandidat(.i.):=vest; end;
If labyrint(.x+1,y.)=hel then begin i:=i+1;kandidat(.i.):=oest; end;
If labyrint(.x,y-1.)=hel then begin i:=i+1;kandidat(.i.):=syd; end;
If labyrint(.x,y+1.)=hel then begin i:=i+1;kandidat(.i.):=nord; end;
If i<>0 then
Begin
(* Vælg en retning *)
If i<>1 then i:=random(i)+1;
Case kandidat(.i.) Of
vest:
Begin
labyrint(.x,y.):=labyrint(.x,y.)-(.vest.);
x:=x-1;
labyrint(.x,y.):=labyrint(.x,y.)-(.oest.);
End;
nord:
Begin
labyrint(.x,y.):=labyrint(.x,y.)-(.nord.);
y:=y+1;
labyrint(.x,y.):=labyrint(.x,y.)-(.syd.);
End;
oest:
Begin
labyrint(.x,y.):=labyrint(.x,y.)-(.oest.);
x:=x+1;
labyrint(.x,y.):=labyrint(.x,y.)-(.vest.);
End;
syd:
Begin
labyrint(.x,y.):=labyrint(.x,y.)-(.syd.);
y:=y-1;
labyrint(.x,y.):=labyrint(.x,y.)-(.nord.);
End;
End;
slut:=TRUE;
end
else
begin
repeat
x:=x+dx ;
If x>xmax then begin y:=y+1; x:=xmax; dx :=-1; end;
If x<1 then begin y:=y+1; x:=1; dx :=1; end;
If y>ymax then begin y:=1; end;
until labyrint(.x,y.)<>hel;
end;
until slut;
end;
(* Lav en udgang ved sydmuren *)
x:=random(xmax)+1;
labyrint(.x,1.):=labyrint(.x,1.)-(.syd.);
labyrint(.x,0.):=labyrint(.x,0.)-(.nord.);
End;
procedure openws (ws : integer);
const
linetype = 1;
linecolor = 1;
coorsystem = 2; (* 0 = NDC 2 = RC *)
var
i : integer;
begin
with gemglb do
begin
for i := 0 to 11 do my_intin Æ i Å := 1;
my_intin Æ 0 Å := ws;
my_intin Æ 1 Å := linetype;
my_intin Æ 2 Å := linecolor;
my_intin Æ 10 Å := coorsystem;
retur := v_opnwk ( my_intin, handler, intptsout);
(*---------------------------------------------+
! Hvis programmet startes fra desktop benyttes !
! virtuel work station !
+---------------------------------------------*)
if my_intin Æ 0 Å = 1 then vmonitor := handler = 0;
if vmonitor then
begin
handler := 1;
retur := v_opnvwk ( my_intin, handler, intptsout);
end;
if ws = 1 then
begin
(**
xy4(.0.):=0; xy4(.1.):=0; xy4(.2.):=maxint; xy4(.3.):=maxint;
retur := v_bar (handler, xy4);
**)
end;
end;
end; (* end procedure openws *)
procedure clearws;
begin
with gemglb do retur := v_clrwk (handler);
end; (* end procedure clearws *)
procedure closews;
begin
with gemglb do
if vmonitor
then retur := v_clsvwk (handler)
else retur := v_clswk (handler);
end; (* end procedure closews *)
procedure frame (x1,y1,x2,y2 : integer);
begin
ptsin (.0.) := x1; ptsin (.1.) := y1;
ptsin (.2.) := x1; ptsin (.3.) := y2;
ptsin (.4.) := x2; ptsin (.5.) := y2;
ptsin (.6.) := x2; ptsin (.7.) := y1;
ptsin (.8.) := x1; ptsin (.9.) := y1;
with gemglb do retur := v_pline (handler, 5, ptsin);
end; (* end procedure frame *)
procedure init_rotte (var mig : rotte; xmax, ymax : integer);
begin
with mig do
begin
x := random (xmax) + 1; y := ymax; retn := sider (random (4));
end;
end; (* init_rotte *)
procedure drejhojre (var mig : rotte);
begin
with mig do if retn = vest then retn := nord else retn := succ (retn);
end; (* end drejh *)
procedure drejvenstre (var mig : rotte);
begin
with mig do if retn = nord then retn := vest else retn := pred (retn);
end; (* end drejv *)
function gaafrem (var mig : rotte) : integer;
var frem : integer;
begin
frem := 0;
with mig do
begin
if retn in labyrint (.x,y.) then frem := 1;
if (y = 1) and not (retn in labyrint (.x,y.)) then frem := 2 (* UDE !!! *)
end;
if frem = 0 then
with mig do
case retn of
nord : y := y + 1;
oest : x := x + 1;
syd : y := y - 1;
vest : x := x - 1;
end;
gaafrem := frem;
end; (* end gaafrem *)
procedure flyt (var mig : rotte;
var ude, tegn : boolean );
var
ch : char; ok : boolean; gik : integer;
begin
ude := FALSE; tegn:=TRUE;
while keypress do read (kbd,ch);
repeat
read (kbd,ch);
ok := ch in (.' ','<','>','S','s'.);
if not ok then write (chr(7));
until ok;
case ch of
'<' : drejvenstre (mig);
'>' : drejhojre (mig);
' ' : begin
gik := gaafrem (mig);
case gik of
1 : begin
write (chr (7)); tegn := FALSE;
end;
2 : ude := TRUE;
end;
end;
'S','s' : ude := TRUE;
end;
end; (* end procedure flyt *)
procedure initmur (k1, k2, k3, k4 : real;
xmin, ymin, xmax, ymax : integer;
var n : integer );
var
dx, dy1, dy2, i, yh, xmm, ymm : integer;
stop1, stop2 : boolean;
begin
xmm := xmax - xmin; ymm := ymax - ymin;
yh := round (k3 * ymm);
stop1 := FALSE; stop2 := FALSE; i := 0;
with mur (.0.) do
begin
x1 := xmin; y1 := ymin; x2 := xmax; y2 := ymax;
end;
dx := round (k2 * xmm);
repeat
dy1 := round (1.0 * dx * yh * 2 / xmm);
dy2 := round (1.0 * dx * (ymm - yh) * 2 / xmm);
i := i + 1;
with mur (. i .) do
begin
x1 := mur (.i-1.).x1 + dx;
x2 := mur (.i-1.).x2 - dx;
y1 := mur (.i-1.).y1 + dy1;
y2 := mur (.i-1.).y2 - dy2;
dx := round (k4 * dx);
stop1 := i = maxmur;
stop2 := (x2-x1) < round (k1 * xmm);
end;
until stop1 or stop2;
if stop2 then n := i - 1 else n := i;
end; (* end procedure initmur *)
procedure tegnlab (mig : rotte; maxi : integer);
var
spejder, spejder2 : rotte;
stop1, stop2 : boolean;
i, gik : integer;
procedure tegnhojre (i : integer);
begin
ptsin (.0.) := mur(.i-1.).x2; ptsin (.1.) := mur(.i-1.).y1;
ptsin (.2.) := mur(.i.).x2; ptsin (.3.) := mur(.i.).y1;
ptsin (.4.) := mur(.i.).x2; ptsin (.5.) := mur(.i.).y2;
ptsin (.6.) := mur(.i-1.).x2; ptsin (.7.) := mur(.i-1.).y2;
ptsin (.8.) := ptsin (.0.); ptsin (.9.) := ptsin (.1.);
with gemglb do
if i=1
then retur := v_pline (handler, 4, ptsin)
else retur := v_pline (handler, 5, ptsin);
end; (* end procedure tegnhojre *)
procedure tegnudhojre (i : integer);
begin
ptsin (.0.) := mur(.i-1.).x2; ptsin (.1.) := mur(.i.).y1;
ptsin (.2.) := mur(.i.).x2; ptsin (.3.) := mur(.i.).y1;
ptsin (.4.) := mur(.i.).x2; ptsin (.5.) := mur(.i.).y2;
ptsin (.6.) := mur(.i-1.).x2; ptsin (.7.) := mur(.i.).y2;
with gemglb do
retur := v_pline (handler, 4, ptsin);
end; (* end procedure tegnudhojre *)
procedure tegnvenstre (i : integer);
begin
ptsin (.0.) := mur(.i-1.).x1; ptsin (.1.) := mur(.i-1.).y1;
ptsin (.2.) := mur(.i.).x1; ptsin (.3.) := mur(.i.).y1;
ptsin (.4.) := mur(.i.).x1; ptsin (.5.) := mur(.i.).y2;
ptsin (.6.) := mur(.i-1.).x1; ptsin (.7.) := mur(.i-1.).y2;
ptsin (.8.) := ptsin (.0.); ptsin (.9.) := ptsin (.1.);
with gemglb do
if i=1
then retur := v_pline (handler, 4, ptsin)
else retur := v_pline (handler, 5, ptsin);
end; (* end procedure tegnvenstre *)
procedure tegnudvenstre (i : integer);
begin
ptsin (.0.) := mur(.i-1.).x1; ptsin (.1.) := mur(.i.).y1;
ptsin (.2.) := mur(.i.).x1; ptsin (.3.) := mur(.i.).y1;
ptsin (.4.) := mur(.i.).x1; ptsin (.5.) := mur(.i.).y2;
ptsin (.6.) := mur(.i-1.).x1; ptsin (.7.) := mur(.i.).y2;
with gemglb do
retur := v_pline (handler, 4, ptsin);
end; (* end procedure tegnudvenstre *)
procedure tegntvers (i : integer);
begin
ptsin (.0.) := mur(.i.).x1; ptsin (.1.) := mur(.i.).y1;
ptsin (.2.) := mur(.i.).x2; ptsin (.3.) := mur(.i.).y1;
ptsin (.4.) := mur(.i.).x2; ptsin (.5.) := mur(.i.).y2;
ptsin (.6.) := mur(.i.).x1; ptsin (.7.) := mur(.i.).y2;
ptsin (.8.) := ptsin (.0.); ptsin (.9.) := ptsin (.1.);
with gemglb do retur := v_pline (handler, 5, ptsin);
end; (* end procedure tegntvers *)
begin (* procedure tegnlab *)
spejder := mig; i := 0; stop1 := FALSE; stop2 := FALSE;
repeat
i := i + 1;
(*-----------------+
! se til hojre !
+-----------------*)
drejhojre (spejder);
with spejder do
if retn in labyrint (.x,y.)
then tegnhojre (i)
else begin
(*----------------------+
! kig ud til hojre !
+----------------------*)
spejder2 := spejder;
gik := gaafrem (spejder2);
if gik <> 2 then
begin
drejvenstre (spejder2);
with spejder2 do
if retn in labyrint (.x,y.) then tegnudhojre (i);
end;
end;
(*-----------------+
! se lige ud !
+-----------------*)
drejvenstre (spejder);
with spejder do
if retn in labyrint (.x,y.)
then begin
tegntvers (i); stop1 := TRUE;
end;
(*-----------------+
! se til venstre !
+-----------------*)
drejvenstre (spejder);
with spejder do
if retn in labyrint (.x,y.)
then tegnvenstre (i)
else begin
(*----------------------+
! kig ud til venstre !
+----------------------*)
spejder2 := spejder;
gik := gaafrem (spejder2);
if gik <> 2 then
begin
drejhojre (spejder2);
with spejder2 do
if retn in labyrint (.x,y.) then tegnudvenstre (i);
end;
end;
(*-----------------+
! se lige ud !
+-----------------*)
drejhojre (spejder);
if not stop1 then stop2 := gaafrem (spejder) = 2;
until (i=maxi) or stop1 or stop2;
gotoxy (38,23);
case mig.retn of
nord : write (rvson,'NORD',rvsoff);
oest : write (rvson,'ØST',rvsoff);
vest : write (rvson,'VEST',rvsoff);
syd : write (rvson,'SYD',rvsoff);
end;
end; (* end procedure tegnlab *)
procedure tegnmur (maxn : integer);
var
i : integer;
begin
for i := 0 to maxn do
with mur (.i.) do
begin
frame (x1,y1,x2,y2);
end;
end; (* end tegnmur *)
Begin
labxmax := 5; labymax := 5;
openws (1);
clearws;
gotoxy (10,10); write ('Labyrintstørrelse ? (x,y) : ');
readln (labxmax, labymax);
if labxmax < 0 then labxmax := 2;
if labxmax > maxside then labxmax := maxside;
if labymax < 0 then labymax := 2;
if labymax > maxside then labymax := maxside;
danlabyrint(labxmax, labymax);
initmur (k1, k2, k3, k4, 40, 20, 650, 320, maxn);
init_rotte (mig, labxmax, labymax);
tegn := true;
repeat
if tegn then begin clearws; tegnlab (mig, maxn); end;
flyt (mig, ude, tegn);
until ude;
clearws;
gotoxy (0,0);
vislabyrint (labxmax, labymax);
write ('Tryk RETUR');
readln;
End.