home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug165.arc / MAZEEDIT.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  14KB  |  419 lines
  1. program mazesolver;
  2. {.PL65}
  3. {$C-,I-}
  4. const
  5.     Xmax   = 39;
  6.     Ymax   = 23;
  7.     downwall : byte = 2;
  8.     leftwall : byte = 4;
  9.     exit : boolean  = false;
  10.     wallgraphics : array [0..95] of byte
  11.         = (0,0,0,0,0,0,0,0,0,0,$FF,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,$FF,0,0,0,0,
  12.            0,$80,$80,$80,$80,$80,$80,$80,$80,$80,$80,$80,0,0,0,0,0,0,0,0,0,0,
  13.            0,0,0,0,0,0,0,0,0,0,0,$80,$80,$80,$80,$80,$80,$80,$80,$80,$80,$FF,
  14.            0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,$FF,0,0,0,0,0);
  15.     pointergraphics : array [0..31] of byte
  16.         = (0,0,0,3,2,2,3,0,0,0,0,0,0,0,0,0,0,0,0,$E0,$20,$20,$E0,0,0,0,0,0,0,
  17.            0,0,0);
  18. type
  19.     ways        = (still,up,down,left,right);
  20.     Xcoords     = 1..Xmax;
  21.     Ycoords     = 1..Ymax;
  22.     track   = record
  23.                 X : Xcoords;
  24.                 Y : Ycoords;
  25.               end;
  26.     trackpointer    = ^track;
  27. var
  28.     maze    : array [Xcoords,Ycoords] of byte;
  29.     mazefile    : file of byte;
  30.     Xpos    : Xcoords;
  31.     Ypos    : Ycoords;
  32.     trackpos,checkpos,bottomofheap  : trackpointer;
  33.     Gcharnum,wallnumber : byte;
  34.     mempos  : integer;
  35.     key  : char;
  36.     mazesolved  : boolean;
  37.  
  38. procedure loadgraphics;
  39. begin
  40.     inline ($21/0/$F8/             {LD      HL,F800H}
  41.             $36/0/                 {C:LD    (HL),0}
  42.             $23/                   {INC     HL}
  43.             $7C/                   {LD      A,H}
  44.             $B5/                   {OR      L}
  45.             $20/$F9/               {JR      NZ,C:}
  46.             $21/wallgraphics/      {LD      HL,wallgraphics}
  47.             $11/$20/$F8/           {LD      DE,F820H}
  48.             $01/$60/0/             {LD      BC,6*16}
  49.             $ED/$B0/               {LDIR}
  50.             $21/wallgraphics/      {LD      HL,wallgraphics}
  51.             $11/$A0/$F8/           {LD      DE,F8A0H}
  52.             $01/$60/0/             {LD      BC,6*16}
  53.             $ED/$B0/               {LDIR}
  54.             $0E/4/                 {LD      C,4}
  55.             $11/$80/$F8/           {LD      DE,F880H}
  56.             $21/pointergraphics/   {A:LD    HL,pointergraphics}
  57.             $06/32/                {LD      B,32}
  58.             $1A/                   {B:LD    A,(DE)}
  59.             $B6/                   {OR      (HL)}
  60.             $12/                   {LD      (DE),A}
  61.             $23/                   {INC     HL}
  62.             $13/                   {INC     DE}
  63.             $10/$F9/               {DJNZ    B:}
  64.             $0D/                   {DEC     C}
  65.             $20/$F1);              {JR      NZ,A:}
  66. end;
  67.  
  68. procedure loadinverse; external $E02A;
  69.  
  70. procedure writemaze;
  71. begin
  72.     clrscr;
  73.     loadgraphics;
  74.     for mempos:=$F001 to $F04E do mem[mempos]:=130;
  75.     mempos:=$F051;
  76.     for Ypos:=1 to Ymax do
  77.         begin
  78.             for Xpos:=1 to Xmax do
  79.                 begin
  80.                     Gcharnum:=128+maze[Xpos,Ypos];
  81.                     mem[mempos]:=Gcharnum;
  82.                     mem[succ(mempos)]:=succ(Gcharnum);
  83.                     mempos:=mempos+2;
  84.                 end;
  85.             mempos:=mempos+2;
  86.         end;
  87.     mempos:=$F09F;
  88.     repeat
  89.         mem[mempos]:=132;
  90.         mempos:=mempos+80;
  91.     until mempos=$F7CF;
  92. end;
  93.  
  94. function confirm:boolean;
  95. begin
  96.     write(^M^J^I^I'Are you sure (Y/N) ? ');
  97.     repeat
  98.         read(kbd,key);
  99.         key:=upcase(key);
  100.     until key in ['N','Y'];
  101.     write(key,' ');
  102.     delay(500);
  103.     confirm:=(key='Y');
  104. end;
  105.  
  106. procedure killmaze;
  107. begin
  108.     for Ypos:=1 to Ymax do
  109.         for Xpos:=1 to Xmax do
  110.             begin
  111.                 wallnumber:=0;
  112.                 if Ypos=Ymax then wallnumber:=downwall;
  113.                 if Xpos=1 then wallnumber:=wallnumber or leftwall;
  114.                 maze[Xpos,Ypos]:=wallnumber;
  115.             end;
  116.     mazesolved:=false;
  117. end;
  118.  
  119. procedure pointXY(setpoint:boolean);
  120. begin
  121.     mempos:=$EFFF+Ypos*80+Xpos+Xpos;
  122.     if setpoint then
  123.         begin
  124.             mem[mempos]:=mem[mempos] or 8;
  125.             mem[succ(mempos)]:=mem[succ(mempos)] or 8;
  126.         end
  127.         else begin
  128.             mem[mempos]:=mem[mempos] and $F7;
  129.             mem[succ(mempos)]:=mem[succ(mempos)] and $F7;
  130.         end
  131. end;
  132.  
  133. procedure getfilename;
  134. var
  135.     inputfilename : string[10];
  136. begin
  137.     inputfilename:='';
  138.     write(^M^J'Enter file name (8 letters & optional drivecode,');
  139.     write(' <ESC> to quit) - ');
  140.     repeat
  141.         repeat
  142.             read(kbd,key);
  143.             key:=upcase(key);
  144.         until key in [^M,^[,'0'..'9',':','A'..'Z',#127];
  145.         if key>' ' then
  146.             if (key=#127) and (length(inputfilename)<>0) then
  147.                 begin mem[addr(inputfilename)]:=length(inputfilename)-1;
  148.                 gotoXY(67,23); write(inputfilename,' ',^H); end
  149.             else if (key<>#127)  and
  150.                  (((key=':') and (length(inputfilename)=1)) or
  151.                  ((key<>':') and ((length(inputfilename)<8) or
  152.                  (length(inputfilename)<10) and (inputfilename[2]=':')))) then
  153.                     begin write(key);
  154.                     inputfilename:=inputfilename+key; end;
  155.     until key in [^M,^[];
  156.     if key=^M then
  157.         begin
  158.             write('.MAZ');
  159.             assign(mazefile,inputfilename+'.MAZ');
  160.         end;
  161. end;
  162.  
  163. procedure waitforESC;
  164. begin
  165.     repeat read(kbd,key); until key=^[;
  166. end;
  167.  
  168. procedure editmaze;
  169.     procedure invertwall(whichwall:ways);
  170.     var
  171.         tempXpos  : Xcoords;
  172.         tempYpos  : Ycoords;
  173.     begin
  174.         tempXpos:=Xpos;
  175.         tempYpos:=Ypos;
  176.         wallnumber:=leftwall;
  177.         case whichwall of
  178.             up    : begin tempYpos:=pred(Ypos); wallnumber:=downwall; end;
  179.             down  : wallnumber:=downwall;
  180.             left  : ;
  181.             right : tempXpos:=succ(Xpos);
  182.         end;
  183.         mempos:=$EFFF+tempYpos*80+tempXpos shl 1;
  184.         maze[tempXpos,tempYpos]:=maze[tempXpos,tempYpos] xor wallnumber;
  185.         mem[mempos]:=mem[mempos] xor wallnumber;
  186.         mem[succ(mempos)]:=mem[succ(mempos)] xor wallnumber;
  187.     end;
  188. begin
  189.     writemaze;
  190.     Xpos:=1;
  191.     Ypos:=1;
  192.     pointXY(true);
  193.     repeat
  194.         read(kbd,key);
  195.         key:=upcase(key);
  196.         case key of
  197.             'I' : if Ypos>1 then invertwall(up);
  198.             'M' : if Ypos<Ymax then invertwall(down);
  199.             'J' : if Xpos>1 then invertwall(left);
  200.             'K' : if Xpos<Xmax then invertwall(right);
  201.             else if key in ['W','Z','A','S'] then
  202.                     begin
  203.                         pointXY(false);
  204.                         case key of
  205.                             'W' : if Ypos>1 then Ypos:=pred(Ypos);
  206.                             'Z' : if Ypos<Ymax then Ypos:=succ(Ypos);
  207.                             'A' : if Xpos>1 then Xpos:=pred(Xpos);
  208.                             'S' : if Xpos<Xmax then Xpos:=succ(Xpos);
  209.                         end;
  210.                         pointXY(true);
  211.                     end;
  212.         end;
  213.     until key=^[;
  214.     mazesolved:=false;
  215. end;
  216.  
  217. procedure loadmaze;
  218. begin
  219.     getfilename;
  220.     if key<>^[ then
  221.         begin
  222.             reset(mazefile);
  223.             if IOresult=0 then
  224.                 begin
  225.                     for Ypos:=1 to Ymax do
  226.                         for Xpos:=1 to Xmax do
  227.                             read(mazefile,maze[Xpos,Ypos]);
  228.                     mazesolved:=false;
  229.                     close(mazefile);
  230.                 end
  231.             else begin
  232.                     write(^I^I'File does not exist. Press <ESC>. ');
  233.                     waitforESC;
  234.                 end;
  235.         end;
  236. end;
  237.  
  238. procedure savemaze;
  239. begin
  240.     getfilename;
  241.     if key=^M then
  242.         begin
  243.             rewrite(mazefile);
  244.                 for Ypos:=1 to Ymax do
  245.                     for Xpos:=1 to Xmax do
  246.                         write(mazefile,maze[Xpos,Ypos]);
  247.             close(mazefile);
  248.         end;
  249. end;
  250.  
  251. procedure solvemaze;
  252. var
  253.     thisway : ways;
  254.     solutionfound,finished : boolean;
  255. begin
  256.     writemaze;
  257.     thisway:=right;
  258.     Xpos:=1; Ypos:=1;
  259.     pointXY(true);
  260.     release(bottomofheap);
  261.     new(trackpos);
  262.     trackpos^.X:=Xpos; trackpos^.Y:=Ypos;
  263.     repeat
  264.         case thisway of
  265.             up    : if ((maze[succ(Xpos),Ypos] and leftwall)=0) and
  266.                         (Xpos<>Xmax) then
  267.                         begin Xpos:=succ(Xpos); thisway:=right; end
  268.                     else if ((maze[Xpos,pred(Ypos)] and downwall)>0) or
  269.                         (Ypos=1) then
  270.                         thisway:=left
  271.                     else Ypos:=pred(Ypos);
  272.             down  : if ((maze[Xpos,Ypos] and leftwall)=0) and (Xpos<>1) then
  273.                         begin Xpos:=pred(Xpos); thisway:=left; end
  274.                     else if ((maze[Xpos,Ypos] and downwall)>0) then
  275.                         thisway:=right
  276.                     else Ypos:=succ(Ypos);
  277.             left  : if ((maze[Xpos,pred(Ypos)] and downwall)=0) and
  278.                         (Ypos<>1) then
  279.                         begin Ypos:=pred(Ypos); thisway:=up; end
  280.                     else if ((maze[Xpos,Ypos] and leftwall)>0) then
  281.                         thisway:=down
  282.                     else Xpos:=pred(Xpos);
  283.             right : if ((maze[Xpos,Ypos] and downwall)=0) and (Ypos<>Ymax) then
  284.                         begin Ypos:=succ(Ypos); thisway:=down; end
  285.                     else if ((maze[succ(Xpos),Ypos] and leftwall)>0) or
  286.                         (Xpos=Xmax) then
  287.                         thisway:=up
  288.                     else Xpos:=succ(Xpos);
  289.         end;
  290.         solutionfound:=(Xpos=Xmax) and (Ypos=Ymax);
  291.         finished:=solutionfound or (Xpos=1) and (Ypos=1) and (thisway=left);
  292.         new(trackpos);
  293.         trackpos^.X:=Xpos;
  294.         trackpos^.Y:=Ypos;
  295.         pointXY(true);
  296.         if not finished then
  297.             begin
  298.                 checkpos:=bottomofheap;
  299.                 while (checkpos^.X<>Xpos) and (checkpos^.Y<>Ypos) do
  300.                     checkpos:=ptr(ord(checkpos)+2);
  301.                 trackpos:=checkpos;
  302.             end;
  303.     until finished;
  304.     if solutionfound then
  305.         begin write(^G); mazesolved:=true; end
  306.     else begin
  307.             gotoXY(24,1);
  308.             write(^G'**  This maze has no solution.  **'#130);
  309.         end;
  310.     waitforESC;
  311. end;
  312.  
  313. procedure displaysolution;
  314. begin
  315.     if not mazesolved then
  316.         write(^M^J^I^I'Maze has not been solved. Press <ESC>. ')
  317.     else begin
  318.             writemaze;
  319.             release(bottomofheap);
  320.             trackpos:=bottomofheap;
  321.             repeat
  322.                 Xpos:=trackpos^.X;
  323.                 Ypos:=trackpos^.Y;
  324.                 pointXY(true);
  325.                 trackpos:=ptr(ord(trackpos)+2);
  326.             until (Xpos=Xmax) and (Ypos=Ymax);
  327.             write(^G);
  328.         end;
  329.     waitforESC;
  330. end;
  331.  
  332. procedure printmaze;
  333. const
  334.     preline : string [23] = '                  '^[#42#5#57#1;
  335. var
  336.     prtnum1,prtnum2 : byte;
  337.     i   : integer;
  338. begin
  339.     write(^M^J^I'Press <RETURN> when printer ready, or <ESC> to quit. ');
  340.     repeat read(kbd,key); until key in [^M,^[];
  341.     if key=^M then
  342.         begin
  343.             write(lst,^M^J^[#65#8);
  344.             write(lst,preline);
  345.             for i:=1 to 313 do write(lst,#1);
  346.             write(lst,^M^J'        START -->'^M);
  347.             for Ypos:=1 to Ymax do
  348.                 begin
  349.                     write(lst,preline);
  350.                     for Xpos:=1 to Xmax do
  351.                         begin
  352.                             prtnum1:=0; prtnum2:=0;
  353.                             if ((maze[Xpos,Ypos] and leftwall)>0) or
  354.                                 (Xpos=1) then
  355.                                 prtnum1:=255;
  356.                             if ((maze[Xpos,Ypos] and downwall)>0) or
  357.                                 (Ypos=Ymax) then
  358.                                 begin
  359.                                     prtnum1:=1 or prtnum1;
  360.                                     prtnum2:=1;
  361.                                 end;
  362.                             write(lst,chr(prtnum1));
  363.                             for i:=1 to 7 do write(lst,chr(prtnum2));
  364.                         end;
  365.                     if Ypos=Ymax then writeln(lst,#255' <-- FINISH')
  366.                     else writeln(lst,#255);
  367.                 end;
  368.             writeln(lst,^[#50);
  369.         end;
  370. end;
  371.  
  372. procedure helpscreen;
  373. begin
  374. end;
  375.  
  376. begin
  377.     killmaze;
  378.     mark(bottomofheap);
  379.     repeat
  380.         clrscr;
  381.         loadinverse;
  382.         writeln;
  383.         writeln(^I^I^I^H^H'+------------------------------+');
  384.         writeln(^I^I^I^H^H'|                              |');
  385.         writeln(^I^I^I^H^H'|     MAZE SOLVING PROGRAM     |');
  386.         writeln(^I^I^I^H^H'|                              |');
  387.         writeln(^I^I^I^H^H'+------------------------------+'^M^J^J);
  388.         writeln(^I^I^I^I^H^H'MAIN OPTION MENU');
  389.         writeln(^I^I^I'  ========================'^M^J);
  390.         writeln(^I^I^I'  1.  Edit maze.');
  391.         writeln(^I^I^I'  2.  Load maze from disk.');
  392.         writeln(^I^I^I'  3.  Save maze to disk.');
  393.         writeln(^I^I^I'  4.  Erase maze.');
  394.         writeln(^I^I^I'  5.  Create solution path.');
  395.         writeln(^I^I^I'  6.  Display solution path.');
  396.         writeln(^I^I^I'  7.  Print maze on printer.');
  397.         writeln(^I^I^I'  8.  Display help screen.');
  398.         writeln(^I^I^I'  9.  Quit program.'^M^J);
  399.         write(^I^I'Select option (1-9)   - ');
  400.         repeat
  401.             read(kbd,key);
  402.         until key in ['1'..'9'];
  403.         write(key,' ');
  404.         delay(500);
  405.         case key of
  406.             '1' : editmaze;
  407.             '2' : loadmaze;
  408.             '3' : savemaze;
  409.             '4' : if confirm then killmaze;
  410.             '5' : solvemaze;
  411.             '6' : displaysolution;
  412.             '7' : printmaze;
  413.             '8' : helpscreen;
  414.             '9' : exit:=confirm;
  415.         end;
  416.     until exit;
  417.     clrscr;
  418. end.
  419.