home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / turbopas / maze.lbr / MAZEG.PZS / MAZEG.PAS
Pascal/Delphi Source File  |  1987-08-19  |  14KB  |  414 lines
  1. { Kevin Smathers:1986 }
  2. program maze;
  3. {$C-}
  4. {Generic version: Turbo Pascal}
  5. {This uses routines built into Turbo Pascal for cursor positioning and other
  6. screen functions. If you can disable your cursor, you may want to do so. Also,
  7. the routines specific to the Superbrain memory mapped video, are included.
  8.     To use memory mapped video, examine the routine OUT and change ISSET to
  9. return type BYTE (for memory) rather than CHAR.
  10.  
  11. }
  12. const
  13.      ver:string[30]='OxWold presents Mazes (1.0G)';
  14.      hsize=15;
  15.      vsize=10;
  16.      cpoints=3;
  17.      points=4;      {1+cpoints}
  18. type
  19.     compass=0..cpoints;
  20.     mazetype=array[1..hsize,1..vsize] of byte;
  21.     linetype=0..18;
  22.  
  23. var
  24.    pw:string[20];
  25.    hint:integer;
  26.    ptr:integer;
  27.    x,y:integer;
  28.    gx,gy:integer;
  29.    c:char;
  30.    i:integer;
  31.    hmaze,maze:mazetype;
  32.     linesr,liness:set of linetype;
  33.    lstout:text;
  34.    cur:integer;
  35.    hdata:array[0..50] of string[6];
  36.    l:array [0..32] of string[50];
  37.  
  38. procedure help;
  39. begin
  40.      gotoxy(1,vsize+3);
  41.      writeln('Rules of the Maze:');
  42.      lowvideo;
  43.      for i:=1 to 8 do begin
  44.          if hint=i then highvideo;
  45.          case i of
  46.               1:writeln('1. You don''t get out until you find the exit');
  47.               2:writeln('2. You move forward by typing "F"');
  48.               3:writeln('3. You turn right by typing "R"');
  49.               4:writeln('4. You turn left by typing "L"');
  50.               5:writeln('5. You turn about by typeing "B"');
  51.               6:writeln('6. You have one piece of chalk, and a great deal of floor space');
  52.               7:writeln('7. You mark on the floor by typing "M"');
  53.               8:writeln('8. When the maze is finished being created, you may continue by typing anything');
  54.          end; {case}
  55.          if hint=i then lowvideo;
  56.      end;
  57.      highvideo;
  58.      Hint:=(hint+1) mod 9;
  59. end;
  60. procedure mazeinit(var maze:mazetype);
  61. var
  62.    i,j,k:integer;
  63.  
  64. begin
  65.         x:=random(hsize)+1; y:=random(vsize)+1;
  66.         gx:=random(hsize)+1; gy:=random(vsize)+1;
  67.      for i:=1 to hsize do
  68.          for j:=1 to vsize do
  69.          begin
  70.               maze[i,j]:=$FF;
  71.               hmaze[i,j]:=0;
  72.          end;
  73.      for i:=0 to 50 do hdata[i]:='      ';
  74. end;
  75. procedure move(ox,oy:integer; dir:compass; var x,y:integer);
  76. begin
  77.      x:=ox; y:=oy;
  78.      case dir of
  79.           0:y:=y-1;
  80.           1:x:=x+1;
  81.           2:y:=y+1;
  82.           3:x:=x-1;
  83.      end; {case}
  84. end; {move}
  85. function bit(t:byte; tbit:byte):boolean;
  86. begin
  87.      bit:=(t and (1 shl tbit))>0;
  88. end;
  89. procedure map(var maze:mazetype; var fil:text);
  90. var i,j:integer;
  91. begin
  92.         clrscr;
  93.         writeln(FIL,ver);
  94.       for j:=1 to hsize do write(fil,'__'); writeln(fil);
  95.       for i:=1 to vsize do
  96.       begin
  97.            for j:=1 to hsize do
  98.            begin
  99.                 if bit(maze[j,i],3) then write(fil,'I') else write(fil,'_');
  100.                 if bit(maze[j,i],2) then write(fil,'_') else write(fil,' ');
  101.            end;
  102.            writeln(fil,'I');
  103.       end;
  104. end; {map}
  105.  
  106. function empty(x,y:integer; maze:mazetype):boolean;
  107. var       i,sum:integer;
  108. begin
  109.      sum:=0;
  110.      if (x in [1..hsize]) and (y in [1..vsize]) then begin
  111.         empty:=(maze[x,y]=$ff);
  112.      end else empty:=false;
  113. end;
  114.  
  115.  
  116. procedure makedoor(var x,y:integer; dir:compass; var maze:mazetype);
  117. begin
  118.      maze[x,y]:=maze[x,y] and ($ff xor (1 shl dir));
  119.      if dir=2 then begin gotoxy(x*2,y+2); write(' '); end;
  120.      if dir=1 then begin gotoxy(x*2+1,y+2); write('_'); end;
  121.      move(x,y,dir,x,y);
  122.      dir:=(dir+2) mod points;
  123.      maze[x,y]:=maze[x,y] and ($ff xor (1 shl dir));
  124.      if dir=2 then begin; gotoxy(x*2,y+2); write(' '); end;
  125.      if dir=1 then begin; gotoxy(x*2+1,y+2); write('_'); end;
  126.  
  127. end; {makedoor}
  128.  
  129.  
  130. procedure mazefill(var maze:mazetype);
  131. var
  132.    M,x,y,ox,oy:integer;
  133.    done:boolean;
  134.    d:compass;
  135.    filled:integer;
  136. begin
  137.      filled:=1;
  138.      mazeinit(maze);     map(maze,output);
  139.         writeln;
  140.      x:=random(hsize)+1;
  141.      y:=random(vsize)+1;
  142.      help;
  143.      repeat {fill}
  144.             ox:=x; oy:=y; {save x,y}
  145.             repeat {advance}
  146.                    d:=random(cpoints);
  147.                    done:=false;
  148.                    for m:=0 to cpoints do
  149.                    begin
  150.                         move(ox,oy,(d+m) mod points,x,y);
  151.                         if empty(x,y,maze) and not(done) then
  152.                         begin
  153.                              done:=true;
  154.                              filled:=filled+1;
  155.                              makedoor(ox,oy,(d+m) mod points,maze);
  156.                         end
  157.                    end;
  158.             until not done;
  159.             d:=0; x:=ox; y:=oy;
  160.             repeat {retreat}
  161.                    done:=false;
  162.                    for m:=3 to 7 do {find an opening}
  163.                        if not bit(maze[x,y],(D+M) mod points) and not done then
  164.                        begin
  165.                             done:=true;
  166.                             d:=(d+m) mod points;
  167.                             move(x,y,d,x,y);
  168.                             write(CHR(27),'=',CHR(33+y),CHR(31+x*2));
  169.                        end;
  170.                    if not done then write('error in retreat');
  171.                    done:=false;
  172.                    for m:=0 to 3 do {is there a free space near?}
  173.                    begin
  174.                         move(x,y,m,ox,oy);
  175.                         if empty(ox,oy,maze) then done:=true;
  176.                    end;
  177.             until done or (filled=hsize*vsize);
  178.      until filled=hsize*vsize;
  179.         for ox:=0 to (hsize+vsize) do begin
  180.                 d:=random(points);
  181.                 x:=random(hsize-2)+2;
  182.                 y:=random(vsize-2)+2;
  183.                 move(x,y,d,x,y);
  184.                 if (x in [1..hsize]) and (y in [1..vsize]) then
  185.                         makedoor(x,y,(d+2) mod points,maze);
  186.         end;
  187.       repeat
  188.             help;
  189.             delay(500);
  190.       until keypressed;
  191. end; {mazefill}
  192. Function ISSET(VAR SSET:BOOLEAN; C:CHAR):char;
  193. BEGIN
  194.      IF SSET THEN ISSET:=(C) ELSE ISSET:=' ';
  195. END;
  196.  
  197. procedure out(num:integer; sset:boolean);
  198. var i,j:integer;
  199. begin
  200.      for i:=1 to length(l[num]) do BEGIN
  201.          case l[num][i] of
  202.               #0..#31: begin
  203.                    cur:=80*ord(l[num][i])+ord(l[num][i-1]);
  204.               end;
  205.               'J': cur:=cur+80;
  206.               'R': cur:=cur+78;
  207.               '=': begin
  208.                    gotoxy(cur mod 80,cur div 80);
  209.                    write(ISSET(sset,'+'));
  210.               end;
  211.               #100..#199:begin
  212.                    gotoxy(cur mod 80, cur div 80);
  213.                    for j:=1 to ord(l[num][i])-100 do begin
  214.                        write(isset(sset,'-'));
  215.                        cur:=cur+1;
  216.                        end;
  217.                    end;
  218.               #200..#299:
  219.                    for j:=1 to ord(l[num][i])-200 do begin
  220.                        gotoxy(cur mod 80, cur div 80);
  221.                        write(isset(sset,'|'));
  222.                        cur:=cur+80;
  223.                    end;
  224.               else begin
  225.                   gotoxy(cur mod 80,cur div 80);
  226.                   write(isset(sset,l[num][i]));
  227.                   cur:=cur+1;
  228.               end;
  229.          end;
  230.          END;
  231. end;
  232. {{{{{{{{{{{{{ This routine is Intertec Superbrain specific
  233. procedure out(num:integer; sset:boolean);
  234. { Memory mapped video starts at $F800 and proceeds at 80 characters
  235. per line.  The screen must first be cleared and then written to each
  236. line (to clear video blanking) The routing actually only used ~ 27
  237. characters on each line.}
  238. {{{{{{{{{{{{{
  239. var i,j:integer;
  240. begin
  241.      for i:=1 to length(l[num]) do BEGIN
  242.          case l[num][i] of
  243.               #0..#31: begin
  244.                    cur:=$f800+80*ord(l[num][i])+ord(l[num][i-1]);
  245.                    if (cur < $f800) or (cur > $f800+1920) then
  246.               end;
  247.               'J': cur:=cur+80;
  248.               'R': cur:=cur+78;
  249.               '=': mem[cur]:=ISSET(sset,'+');
  250.  
  251.               #100..#199:
  252.                    for j:=1 to ord(l[num][i])-100 do begin
  253.                        mem[cur]:=isset(sset,'-');
  254.                        cur:=cur+1;
  255.                    end;
  256.               #200..#299:
  257.                    for j:=1 to ord(l[num][i])-200 do begin
  258.                        mem[cur]:=isset(sset,'|');
  259.                        cur:=cur+80;
  260.                    end;
  261.               else begin
  262.                   mem[cur]:=isset(sset,l[num][i]);
  263.                   cur:=cur+1;
  264.               end;
  265.               END;
  266.          end;
  267. end;
  268. End of Intertec Superbrain routine
  269. {{{{{{{{{{{{{{{}
  270.  
  271. procedure outr(num:linetype);
  272. begin
  273.         if num in liness then begin
  274.                 liness:=liness-[num];
  275.                 linesr:=linesr+[num];
  276.                 out(num,false);
  277.         end;
  278. end;
  279. procedure outs(num:linetype);
  280. begin
  281.         if num in linesr then begin
  282.                 linesr:=linesr-[num];
  283.                 liness:=liness+[num];
  284.                 out(num,true);
  285.         end;
  286. end;
  287. procedure outset(k:boolean; l1,l2:linetype);
  288. begin
  289.         if k then begin
  290.                 outs(l1); outr(l2);
  291.         end else begin
  292.                 outs(l2); outr(l1);
  293.         end;
  294. end;
  295.  
  296. procedure mazeroom(var maze:mazetype; x,y:integer; d:compass);
  297. var i,tx,ty:integer;
  298.  
  299. begin
  300.         outset(bit(maze[x,y],(d+3) mod points),1,0);
  301.         outset(bit(maze[x,y],(d+1) mod points),3,2);
  302.         outs(15);
  303.         if bit(maze[x,y],d) then begin
  304.                 outs(12);
  305.                 for i:=4 to 11 do outr(i);
  306.                 for i:=13 to 14 do outr(i);
  307.                 for i:=16 to 18 do outr(i);
  308.         end else begin
  309.                 outr(12);
  310.                 move(x,y,d,tx,ty);
  311.                 if (tx=gx) and (ty=gy) then begin
  312.                    gotoxy(14,21);
  313.                    write('EXIT');
  314.                 end else begin
  315.                    gotoxy(14,21);
  316.                    write(hdata[hmaze[tx,ty]]);
  317.                 end;
  318.                 outs(16);
  319.                 outset(bit(maze[tx,ty],(d+3) mod points),5,4);
  320.                 outset(bit(maze[tx,ty],(d+1) mod points),7,6);
  321.                 if bit(maze[tx,ty],d) then begin
  322.                         outs(13);
  323.                         for i:=8 to 11 do outr(i);
  324.                         outr(14); outr(17); outr(18);
  325.                 end else begin
  326.                         outr(13);
  327.                         move(tx,ty,d,tx,ty);
  328.                         outset(bit(maze[tx,ty],(d+3) mod points),9,8);
  329.                         outset(bit(maze[tx,ty],(d+1) mod points),11,10);
  330.                         outset(bit(maze[tx,ty],d),14,18);
  331.                         outs(17);
  332.                 end;
  333.         end;
  334. end;
  335. procedure mazewander(var maze:mazetype);
  336. var
  337.         d:compass;
  338.         c:char;
  339. begin
  340.         d:=random(points);
  341.         liness:=[]; linesr:=[0..18];
  342.         repeat
  343.                 mazeroom(maze,x,y,d);
  344.                 gotoxy(35,1);
  345.                 clreol;
  346.                 write(':');
  347.                 read(kbd,c);
  348.                 write(c);
  349.                 gotoxy(35,2);
  350.                 write('     ');
  351.         case c of
  352.                 'L','l':d:=(d+3) mod points;
  353.                 'F','f':if bit(maze[x,y],d) then begin
  354.                            gotoxy(35,2);
  355.                            write('OUCH!')
  356.                         end  else move(x,y,d,x,y);
  357.                 'R','r':d:=(d+1) mod points;
  358.                 'B','b':d:=(d+2) mod points;
  359.                 'M','m':if ptr=50 then
  360.                            write('You are all out of chalk')
  361.                         else begin
  362.                              ptr:=ptr+1;
  363.                              write('Mark what?        '^h^h^h^h^h^h);
  364.                              readln(hdata[ptr]);
  365.                              hdata[ptr]:=hdata[ptr]+'      ';
  366.                              hmaze[x,y]:=ptr;
  367.                         end;
  368.         end; {case}
  369.         until ((x=gx) and (y=gy)) or (c=^^);
  370. end; {maze wander}
  371. procedure init;
  372. begin
  373. { 0..33 goto (x,y) pair with next byte
  374.   J     Line feed
  375.   R     Line feed less two spaces
  376.   others 65..99 print as is or as space depending on set or reset
  377.   100..199      N-100 horizontal
  378.   200..255      N-200 vertical
  379. }
  380.      l[00]:=#1#2'--'#1#22'--';           {Left immediate open}
  381.      l[01]:=#2#1'\'#2#23'/';             {Left immediate closed}
  382.      l[02]:=#27#2'--'#27#22'--';         {Right immediate open}
  383.      l[03]:=#27#1'/'#27#23'\';           {Right immediate closed}
  384.      l[04]:=#4#6'---'#4#18'---';         {Next left open}
  385.      l[05]:=#4#3'\J\J\'#6#19'/R/R/';     {Next left closed}
  386.      l[06]:=#23#6'---'#23#18'---';       {Next right open}
  387.      l[07]:=#25#3'/R/R/'#23#19'\J\J\';   {Next right closed}
  388.      L[08]:=#8#8'-'#8#16'-';             {Last left open}
  389.      L[09]:=#8#7'\'#8#17'/';             {Last left closed}
  390.      L[10]:=#21#8'-'#21#16'-';           {Last right open}
  391.      L[11]:=#21#7'/'#21#17'\';           {Last right closed}
  392.      L[12]:=#4#2#122#4#22#122;           {Closed immediatly ahead}
  393.      L[13]:=#8#6#114#8#18#114;           {Closed next ahead}
  394.      L[14]:=#10#8#110#10#16#110;         {Closed last ahead}
  395.      l[15]:=#3#2'=J'#219'=J'#26#2'=J'#219'=';  {end of immediate room}
  396.      l[16]:=#7#6'=J'#211'=J'#22#6'=J'#211'=';  {end of next room}
  397.      l[17]:=#9#8'=J'#207'=J'#20#8'=J'#207'=';  {end of last room}
  398.      l[18]:=#10#9'\'#10#15'/'#19#9'/'#19#15'\';{open all ahead}
  399.      ptr:=0;
  400.      hint:=0;
  401. end;
  402. begin {main}
  403.         init;
  404.       mazefill(maze);
  405.       read(kbd,c);
  406.       if c='P' then map(maze,lst);
  407.         clrscr;
  408.         for i:=1 to 23 do writeln(' ');
  409.         write(' '^h);
  410.         mazewander(maze);
  411.         clrscr;
  412.         writeln('Hurrah! You made it out!');
  413. end. {main}
  414.