|
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: 15360 (0x3c00)
Types: TextFile
Names: »LABYRINT.PAS«
└─⟦b301b5c1d⟧ Bits:30003931/GEM_Develop_disk_2_CDOS.imd Disketter indleveret af Steffen Jensen (Piccolo/Piccoline)
└─⟦this⟧ »LABYRINT.PAS«
(* ******************************************************************* *)
(* *)
(* P R O G R A M L A B Y R I N T *)
(* *)
(* Dette program laver en labyrint efter de indtastede mål, og *)
(* du skal så prøve at finde ud ad denne labyrint. *)
(* *)
(* ******************************************************************* *)
(*$Igempcon.i*)
(*$Igemptype.i*)
(*$Igempvar.i*)
(*$Ivdibnd.pas*)
CONST
msize = 50;
TYPE
str4 = string(. 4 .);
regpack = RECORD
ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
End;
VAR
work_in : intin_ARRAY;
work_out : ARRAY_57;
status,dummy,handle : integer;
pxyarray : ptsin_ARRAY;
max_length : integer;
echo_mode : integer;
str,echo_xy: Charstring;
i:integer;
oldx,oldy : real;
xmin,xfak : real;
ymin,yfak : real;
kby : integer;
svar : string(.1.);
FUNCTION atpos(x,y:integer):str4;
Begin
atpos:=@27'Y'+chr(y+32)+chr(x+32)
end;
FUNCTION bdosb(f,p:integer):integer;
Var
regs : regpack;
Begin
regs.cx:=f;
regs.dx:=p;
swint(224,regs);
bdosb:=regs.ax;
End;
PROCEDURE sound;
Begin
write(@7)
end;
PROCEDURE OPEN_WORKSTATION(n:integer);
BEGIN
for i:=0 to 10 do work_in(.i.):=0;
work_in(.0.):=1;
work_in(.1.):=1;
work_in(.2.):=1;
work_in(.5.):=1;
work_in(.6.):=1;
work_in(.7.):=2;
work_in(.8.):=3;
work_in(.9.):=1;
dummy:=v_opnwk(work_in,handle,work_out);
dummy:=vsl_width(handle,200);
dummy:=vsl_ends(handle,2,2);
END;
PROCEDURE window(x1,x2,y1,y2:real);
Begin
xmin:=x1;
xfak:=32767/(x2-x1);
ymin:=y1;
yfak:=32767/(y2-y1);
end;
PROCEDURE moveto(x,y:real);
Begin
oldx:=x;oldy:=y;
end;
PROCEDURE drawto(x,y:real);
Begin
pxyarray(.0.):=round((oldx-xmin)*xfak);
pxyarray(.1.):=round((oldy-ymin)*yfak);
pxyarray(.2.):=round((x-xmin)*xfak);
pxyarray(.3.):=round((y-ymin)*yfak);
dummy:=v_pline(handle,2,pxyarray);
oldx:=x;oldy:=y;
end;
PROCEDURE move(x,y:real);
Begin
oldx:=oldx+x;oldy:=oldy+y;
end;
PROCEDURE draw(x,y:real);
Begin
pxyarray(.0.):=round((oldx-xmin)*xfak);
pxyarray(.1.):=round((oldy-ymin)*yfak);
pxyarray(.2.):=round((oldx+x-xmin)*xfak);
pxyarray(.3.):=round((oldy+y-ymin)*yfak);
dummy:=v_pline(handle,2,pxyarray);
oldx:=oldx+x;oldy:=oldy+y;
end;
PROCEDURE clear;
Begin
dummy:=v_clrwk(handle);
end;
PROCEDURE pencolor(n:integer);
Begin
dummy:=vsl_color(handle,n);
end;
PROCEDURE do_maze ;
Var
walk : array (. 1..1000 .) of Integer;
i,j,sx,sy,n,h,v,x,y,vx,vy,mx,my : Integer;
t,k,f,h1,v1,mh,mv,r,s,z,d : Integer;
ox,oy : Integer;
a,b,ff : Integer;
wx,wy : Integer;
maze : array(. 1..msize,1..msize .) of Integer;
dx,yu,yd : array (. 1..8 .) of Integer;
cut : array (. 1..4 .) of Integer;
i_gaaet : integer;
done,quit : boolean;
last,nm : integer;
PROCEDURE sw;
Var i:integer;
Begin
FOR i:= 1 TO 1000 DO Write(walk(.i.));
End;
PROCEDURE closed_side(n,rl:integer);
Begin
pxyarray(.0.):=round((vx+rl*dx(.n-1.)-xmin)*xfak);
pxyarray(.1.):=round((yu(.n-1.)-ymin)*yfak);
pxyarray(.2.):=round((vx+rl*dx(.n.)-xmin)*xfak);
pxyarray(.3.):=round((yu(.n.)-ymin)*yfak);
pxyarray(.4.):=round((vx+rl*dx(.n.)-xmin)*xfak);
pxyarray(.5.):=round((yd(.n.)-ymin)*yfak);
pxyarray(.6.):=round((vx+rl*dx(.n-1.)-xmin)*xfak);
pxyarray(.7.):=round((yd(.n-1.)-ymin)*yfak);
IF n>2 THEN
Begin
pxyarray(.8.):=round((vx+rl*dx(.n-1.)-xmin)*xfak);
pxyarray(.9.):=round((yu(.n-1.)-ymin)*yfak);
dummy:=v_pline(handle,5,pxyarray);
End
else dummy:=v_pline(handle,4,pxyarray);
End;
PROCEDURE open_side(n,rl:integer);
Begin
pxyarray(.0.):=round((vx+rl*dx(.n-1.)-xmin)*xfak);
pxyarray(.1.):=round((yu(.n.)-ymin)*yfak);
pxyarray(.2.):=round((vx+rl*dx(.n.)-xmin)*xfak);
pxyarray(.3.):=round((yu(.n.)-ymin)*yfak);
pxyarray(.4.):=round((vx+rl*dx(.n.)-xmin)*xfak);
pxyarray(.5.):=round((yd(.n.)-ymin)*yfak);
pxyarray(.6.):=round((vx+rl*dx(.n-1.)-xmin)*xfak);
pxyarray(.7.):=round((yd(.n.)-ymin)*yfak);
dummy:=v_pline(handle,4,pxyarray);
End;
PROCEDURE back_end(n:integer);
Begin
pxyarray(.0.):=round((vx+dx(.n.)-xmin)*xfak);
pxyarray(.1.):=round((yu(.n.)-ymin)*yfak);
pxyarray(.2.):=round((vx+dx(.n.)-xmin)*xfak);
pxyarray(.3.):=round((yd(.n.)-ymin)*yfak);
pxyarray(.4.):=round((vx-dx(.n.)-xmin)*xfak);
pxyarray(.5.):=round((yd(.n.)-ymin)*yfak);
pxyarray(.6.):=round((vx-dx(.n.)-xmin)*xfak);
pxyarray(.7.):=round((yu(.n.)-ymin)*yfak);
pxyarray(.8.):=round((vx+dx(.n.)-xmin)*xfak);
pxyarray(.9.):=round((yu(.n.)-ymin)*yfak);
dummy:=v_pline(handle,5,pxyarray);
End;
PROCEDURE top_view;
Begin
CLEAR ;
WINDOW (sx+2,1,0,sy+3);
FOR i:= sy+1 DOWNTO 1 DO
Begin
FOR j:= sx+1 DOWNTO 1 DO
Begin
MOVETO (j,i);
z:= maze(.j,i.);
IF (z MOD 2)<>0 THEN (* make left wall *)
DRAW (0,1)
ELSE
MOVE (0,1);
IF (z DIV 2 MOD 2)<>0 THEN (* make bottom *)
DRAW (1,0)
ELSE
MOVE (1,0);
End;
End;
End;
PROCEDURE mark(x,y:real);
Begin
PENCOLOR (1);
MOVETO(x+0.25,y+0.5);
DRAW (0.5,0);
MOVE (-0.25,-0.25);
DRAW (0,0.5);
End;
PROCEDURE unmark(x,y:real);
Begin
PENCOLOR (0);
MOVETO (x+0.25,y+0.5);
DRAW (0.5,0);
MOVE (-0.25,-0.25);
DRAW (0,0.5);
End;
PROCEDURE draw_it;
Begin
n:= 2; a:= h; b:= v; ff:= 1 SHL (f-1);
CLEAR ;
REPEAT
z:= maze(.a,b.)*ff;
(* *)
(* Left Side *)
(* *)
IF z DIV 16 MOD 2 <> 0 THEN
closed_side(n,-1)
ELSE
Begin
IF (maze(.a+s,b-r.)*ff) DIV 128 MOD 2 <>0 THEN open_side(n,-1);
(* EXEC open_side(n,-1) *)
END;
(* *)
(* Right side *)
(* *)
IF z DIV 64 MOD 2 <>0 THEN
closed_side(n,1)
ELSE
Begin
IF maze(.a-s,b+r.)*ff DIV 128 MOD 2 <>0 THEN open_side(n,1);
(* EXEC open_side(n,1) *)
END;
(* *)
(* Back *)
(* *)
IF z DIV 128 MOD 2 <> 0 THEN
Begin
back_end(n);
n:= 999;
end
ELSE
Begin
n:= n+1;
a:= a+r; b:= b+s;
END;
UNTIL (n>8) OR (b<2);
End;
PROCEDURE show_walk;
Begin
last:= nm;
IF last>1000 THEN last:= 1000;
x:= h1; y:= v1;
mark(x,y);
FOR i:= 1 TO last DO
Begin
ox:= x;
oy:= y;
Case walk(.i.) of
1: y:=y-1;
2: x:=x+1;
3: y:=y+1;
4: x:=x-1;
end;
unmark(ox,oy);
mark(x,y);
End;
End;
Begin
dummy:=v_gtext(handle,10,25000,
'Indtast labyrintens størrelse, som er 2 tal mellem 1 og 20 !');
REPEAT
dummy:=v_gtext(handle,10,20000,
'Labyrint størrelse (x,y) ? ');
Readln(sx,sy);
UNTIL (sx>0) AND (sx<21) AND (sy>0) AND (sy<21);
(* 'labyrintens størrelse bliver (',sx,',',sy,')');*)
RANDOMIZE;
n:= sx*sy-1; sx:= sx+1; sy:= sy+1;
h:= sx; v:= sy; wx:= 279; wy:= 157; mx:= wx; my:= wy;
vx:= mx DIV 2; vy:= my DIV 2+40; x:= vx;
WINDOW(-10,wx+10,-10,wy+10);
FOR i:= 1 TO 8 DO (* compute perspective points *)
Begin
dx(.i.):= ROUND(x);
yu(.i.):= ROUND(vy-x*vy/vx);
yd(.i.):= ROUND(vy+x*(my-vy)/vx);
x:= ROUND(x*7/10);
End;
FOR i:= 1 TO sy+1 DO
Begin
maze(.1,i.):= 4; maze(.sx+1,i.):= 1
end;
FOR i:= 2 TO sx DO
Begin
maze(.i,sy+1.):= 8; maze(.i,1.):= 2;
FOR j:= 2 TO sy DO maze(.i,j.):= 15;
end;
maze(.1,1.):= 0;
maze(.1,sy+1.):= 0;
maze(.sx+1,1.):= 0;
maze(.sx+1,sy+1.):= 0;
(* maze values *)
(* *)
(* 8 = top wall *)
(* 4 = right wall *)
(* 2 = bottom wall *)
(* 1 = left wall *)
(* *)
(* Face Top Riht Botm Left *)
(* N 8 4 2 1 *)
(* E 4 2 1 8 *)
(* S 2 1 8 4 *)
(* W 1 8 4 2 *)
(* *)
r:= h DIV 2+1; s:= v DIV 2+1; maze(.r,s.):= 15; z:= 0; d:= 1;
Writeln;
Write('Labyrinten bliver lavet !');
sound;
(* *)
(* Generate random maze *)
(* algorithm here from rogers and strassberg *)
(* *)
FOR i_gaaet:= 1 TO n DO
Begin
REPEAT (* for this point nr *)
done:= FALSE;
i:= 0;
IF maze(.r-1,s.)>=15 THEN Begin i:= i+1; cut(.i.):= 1 end;
IF maze(.r,s-1.)>=15 THEN Begin i:= i+1; cut(.i.):= 2 end;
IF maze(.r+1,s.)>=15 THEN Begin i:= i+1; cut(.i.):= 3 end;
IF maze(.r,s+1.)>=15 THEN Begin i:= i+1; cut(.i.):= 4 end;
IF i<>0 THEN
Begin
IF i<>1 THEN i:= RANDOM(i)+1;
CASE cut(.i.) OF
1: (* move west *)
Begin
maze(.r,s.):= maze(.r,s.)-maze(.r,s.) MOD 2;
r:= r-1;
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 4) MOD 2)*4;
End;
2: (* move north *)
Begin
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 8) MOD 2)*8;
s:= s-1;
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 2) MOD 2)*2;
End;
3: (* move east *)
Begin
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 4) MOD 2)*4;
r:= r+1;
maze(.r,s.):= maze(.r,s.)-(maze(.r,s.) MOD 2);
End;
4: (* move south *)
Begin
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 2) MOD 2)*2;
s:= s+1;
maze(.r,s.):= maze(.r,s.)-((maze(.r,s.) DIV 8) MOD 2)*8;
End;
END;
done:= TRUE
end
ELSE (* scan for unused points *)
Begin
RANDOMIZE;
REPEAT
IF d=1 THEN
Begin
IF r=h THEN
Begin
IF s=v THEN
Begin
r:= 2; s:= 2
end
ELSE
Begin
s:= s+1; d:= -d
END;
End
ELSE
Begin
r:= r+d
END;
End
ELSE
Begin
IF r=2 THEN
Begin
IF s=v THEN
Begin
r:= h; s:= 2
End
ELSE
Begin
s:= s+1; d:= -d
End;
End
ELSE
Begin
r:= r+d
END;
END;
UNTIL maze(.r,s.)<>15;
END;
UNTIL done;
Write('.');
end;
mh:= h; mv:= v;
(* random point at south *)
i:= RANDOM(mh-2)+2;
maze(.i,1.):= 0;
maze(.i,2.):= maze(.i,2.)-((maze(.i,2.) DIV 8) MOD 2)*8;
h:= RANDOM(mh-2)+2;
h1:= h; v1:= v;
Write ('Labyrinten er nu lavet');
sound;
(* *)
(* Add redundant bits *)
FOR x:= 1 TO mh DO
Begin
FOR y:= 1 TO mv DO maze(.x,y.):= maze(.x,y.)+maze(.x,y.)*16
End;
f:= RANDOM(3)+1;
CASE f OF
1 :
Begin
r:= 0; s:= -1
End;
2 :
Begin
r:= 1; s:= 0
End;
3 :
Begin
r:= 0; s:= 1
End;
4 :
Begin
r:= -1; s:= 0
End;
END;
done:= FALSE; quit:= FALSE; nm:= 0; kby:= 0;
draw_it;
REPEAT
dummy:=v_gtext(handle,10,1000,
'Tryk "Blank" for at gå frem, > og < for at dreje');
k:= kby; kby:= 0;
if k=0 THEN
begin
max_length := 1;
echo_mode:=0;
dummy:=vrq_string(handle,max_length,echo_mode,12000,12000,str);
k:=ord(str(.1.));
end;
CASE k OF
44: (* ',' left arrow *)
Begin
f:= f-1;
IF f<1 THEN f:= 4;
CASE f OF
1:
Begin r:= 0; s:= -1 end;
2:
Begin r:= 1; s:= 0 end;
3:
Begin r:= 0; s:= 1 end;
4:
Begin r:= -1; s:= 0 end;
END;
draw_it;
End;
46: (* right arrow *)
Begin
f:= f+1;
IF f>4 THEN f:= 1;
CASE f OF
1:
Begin r:= 0; s:= -1 end;
2:
Begin r:= 1; s:= 0 end;
3:
Begin r:= 0; s:= 1 end;
4:
Begin r:= -1; s:= 0 end;
END;
draw_it;
End;
13,32: (* Forward *)
Begin
z:= maze(.h,v.);
t:= z*(1 SHL (f-1)) DIV 128 MOD 2;
IF t<>0 THEN (* Hit a wall *)
sound
ELSE
Begin
nm:= nm+1;
IF nm<=1000 THEN walk(.nm.):= f;
h:= h+r; v:= v+s;
IF v<2 THEN done:= TRUE;
draw_it;
END;
End;
81,113:
Begin
quit:= TRUE; done:= TRUE
End;
83:
Begin
top_view;
mark(h,v);
Gotoxy(10,1);
Write ('Du har brugt ',nm,'træk');
k:= kby; kby:= 0;
if k=0 THEN k:= bdosb(6,253);
CLEAR ;
WINDOW (0,wx,0,wy);
draw_it;
End;
OTHERWISE
sound;
END;
UNTIL done;
top_view;
show_walk;
Gotoxy(10,1);
Write ('Du har brugt ',nm,'træk');
End;
Begin
OPEN_WORKSTATION(1);
REPEAT
do_maze;
REPEAT
Gotoxy(40,1);Write('Vil du prøve igen (ja/nej) ? ');
Readln(svar);
IF svar='J' THEN svar:= 'j';
IF svar='N' THEN svar:= 'n';
UNTIL (svar='j') OR (svar='n');
UNTIL svar='n';
dummy:=v_clswk(handle);
End.