home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / GOMOKU.ZIP / GOMOKU.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  12.6 KB  |  416 lines
  1. program gomoku;
  2. {
  3.            JUNE 28, 1984
  4.  
  5.            Author:       Unknown
  6.  
  7.  
  8.            converted     Todd Little
  9.            to TURBO      1318 Bullock
  10.            by:           Houston, TX  77055
  11.                          713-984-2055 h
  12.                              578-3210 w
  13.  
  14. }
  15.  
  16. type
  17.   cell = record image: char; color: byte; end;
  18.   block = record leftc: char; lefta: byte; rightc: char; righta: byte; end;
  19.   possibilities = array[0..2] of block;
  20.   dtype = array[1..4] of integer;
  21.   ctype = array[1..7] of integer;
  22. const
  23.   normal = 7; inverse = 112;
  24.   empty : block =(leftc:'∙'; lefta:normal; rightc:' '; righta:normal);
  25.   player : block =(leftc:'O'; lefta:normal; rightc:' '; righta:normal);
  26.   machine : block =(leftc:'X'; lefta:normal; rightc:' '; righta:normal);
  27.   upperleft : block =(leftc:'╔'; lefta:normal; rightc:'═'; righta:normal);
  28.   lowerleft : block =(leftc:'╚'; lefta:normal; rightc:'═'; righta:normal);
  29.   upperright : block =(leftc:'╗'; lefta:normal; rightc:' '; righta:normal);
  30.   lowerright : block =(leftc:'╝'; lefta:normal; rightc:' '; righta:normal);
  31.   horizontal : block =(leftc:'═'; lefta:normal; rightc:'═'; righta:normal);
  32.   vertical : block =(leftc:'║'; lefta:normal; rightc:' '; righta:normal);
  33. {  empty = block('∙',normal,' ',normal);
  34.   player = block('O',normal,' ',normal);
  35.   machine = block('X',normal,' ',normal);
  36.   upperleft = block('╔',normal,'═',normal);
  37.   lowerleft = block('╚',normal,'═',normal);
  38.   upperright = block('╗',normal,' ',normal);
  39.   lowerright = block('╝',normal,' ',normal);
  40.   horizontal = block('═',normal,'═',normal);
  41.   vertical = block('║',normal,' ',normal); }
  42.  
  43.   figure :  possibilities = (
  44.            (leftc:'∙'; lefta:normal; rightc:' '; righta:normal) ,
  45.            (leftc:'O'; lefta:normal; rightc:' '; righta:normal) ,
  46.            (leftc:'X'; lefta:normal; rightc:' '; righta:normal)  ) ;
  47.  
  48. {  figure = possibilities(empty,player,machine);}
  49.  
  50.   idir : dtype = ( 1,1,1,0);
  51.   jdir : dtype = (-1,0,1,1);
  52.   ccc : ctype = (36,64,100,81,112,121,169);
  53.   replay = '-'; quit = #27;
  54. var
  55.   screen: array[0..24,0..39] of block absolute $b000:0000;
  56.   ooo,xxx,ppp: array[1..20,1..20] of integer;
  57.   move_count: integer;
  58.   inchar: integer;
  59.   i,j: integer;
  60.   ch: char;
  61.  
  62.   scratch : integer;
  63.  
  64. procedure locate(w :integer);
  65.  
  66. begin
  67.   gotoxy ( lo(w) +1 , hi(w) +1 );
  68.   end;
  69.  
  70.  
  71. function  byword(x,y:byte) : integer;
  72. begin
  73.   byword := (x shl 8) or  y ;
  74.   end;
  75.  
  76. function random1(x:integer):integer;
  77. begin
  78.   random1 := random(x) + 1;
  79.   end;
  80.  
  81.  
  82. function inkey:integer;
  83.  
  84. begin
  85.   begin
  86.     inline
  87.    (  $b8/$00/$00/
  88.       $cd/$16/
  89.       $a3/scratch )
  90.        end;
  91. inkey := scratch;
  92.  
  93. end;
  94.  
  95. function hibyte(x:integer) :integer;
  96. begin
  97.    hibyte := hi (x) ;
  98.    end;
  99.  
  100. function lobyte(x:integer) :integer;
  101. begin
  102.    lobyte := lo (x) ;
  103.    end;
  104.  
  105. function wrd(x:integer) :integer;
  106. begin
  107.    wrd := x;
  108.    end;
  109.  
  110. procedure cursor(w:integer);
  111. begin
  112. end;
  113. procedure scroll(a,b:integer;c:integer);
  114. begin
  115. end;
  116.  
  117. procedure print_help(var ch: integer);
  118.   var i: integer;
  119. begin
  120.   locate(byword( 0,45)); write('The object  of the game of  GOMOKU');
  121.   locate(byword( 1,45)); write('is to place five  of your marks in');
  122.   locate(byword( 2,45)); write('a row (your mark will be "O").  At');
  123.   locate(byword( 3,45)); write('the same time, I will be trying to');
  124.   locate(byword( 4,45)); write('five of my marks in a row (my mark');
  125.   locate(byword( 5,45)); write('will be "X").  You make  your move');
  126.   locate(byword( 6,45)); write('by positioning the cursor with the');
  127.   locate(byword( 7,45)); write('numeric  keypad on the  right, and');
  128.   locate(byword( 8,45)); write('then pressing ENTER.  We will take');
  129.   locate(byword( 9,45)); write('turns making moves until one of us');
  130.   locate(byword(10,45)); write('wins or neither of us can move.');
  131.   locate(byword(12,45)); write('It may seem at  first that I can''t');
  132.   locate(byword(13,45)); write('be beaten, but with  practice, and');
  133.   locate(byword(14,45)); write('if you  are very  careful, you can');
  134.   locate(byword(15,45)); write('win most of the time.');
  135.   locate(byword(17,45)); write('To restart the game, press the DEL');
  136.   locate(byword(18,45)); write('key.  To redraw  the board,  press');
  137.   locate(byword(19,45)); write('the INS key.  And to stop the game');
  138.   locate(byword(20,45)); write('press the ESC key.');
  139.   locate(byword(22,45)); write('Press any key to continue:  ');
  140.   while not keypressed do;
  141. end;
  142.  
  143. procedure board;
  144.   var i,j: integer;
  145. begin
  146.   scroll(byword(0,43),byword(24,79),25); scroll(byword(22,0),byword(24,79),25);
  147.   screen[0,0]:=upperleft;
  148.   for j:=1 to 20 do screen[0,j]:=horizontal;
  149.   screen[0,21]:=upperright;
  150.   for i:=1 to 20 do begin
  151.     screen[i,0]:=vertical;
  152.     for j:=1 to 20 do screen[i,j]:=figure[ppp[i,j]];
  153.     screen[i,21]:=vertical;
  154.   end;
  155.   screen[21,0]:=lowerleft;
  156.   for j:=1 to 20 do screen[21,j]:=horizontal;
  157.   screen[21,21]:=lowerright;
  158. end;
  159.  
  160. procedure moveto(p,i,j: integer);
  161. begin
  162.   move_count:=move_count+1; ppp[i,j]:=p;
  163.   locate(byword(i,2*j)); screen[i,j]:=figure[p];
  164. end;
  165.  
  166. procedure position(var i,j: integer; var c: char);
  167.   var inchar: integer; i_first,j_first: integer; msg: boolean;
  168. begin
  169.   i_first:=i; j_first:=j; c:=chr(0); msg:=false; cursor(byword(1,13));
  170.   while c=chr(0) do begin
  171.     locate(byword(i,2*j)); repeat inchar:=inkey until inchar<>0;
  172.     if msg then begin scroll(byword(0,43),byword(24,79),25); msg:=false; end;
  173.     case hibyte(inchar) of
  174.       01: begin { ESC } c:=quit; end;
  175.       28: begin { RETURN } { move }
  176.         if ppp[i,j]=0 then c:=chr(13) else begin
  177.           locate(byword(10,45)); write('Position occupied.'); msg:=true;
  178.         end;
  179.       end;
  180.       71: begin { Home,  7 } if i>1 then i:=i-1; if j>1 then j:=j-1; end;
  181.       72: begin { Up,    8 } if i>1 then i:=i-1; end;
  182.       73: begin { PgUp,  9 } if i>1 then i:=i-1; if j<20 then j:=j+1; end;
  183.       75: begin { Left,  4 } if j>1 then j:=j-1; end;
  184.       76, 82: begin { Ins, 5 } i:=i_first; j:=j_first; board; end;
  185.       77: begin { Right, 6 } if j<20 then j:=j+1; end;
  186.       79: begin { End,   1 } if i<20 then i:=i+1; if j>1 then j:=j-1; end;
  187.       80: begin { Down,  2 } if i<20 then i:=i+1; end;
  188.       81: begin { PgDn,  3 } if i<20 then i:=i+1; if j<20 then j:=j+1; end;
  189.       83: begin { Del } c:=replay; end;
  190.      { otherwise; }
  191.     end;
  192.   end;
  193.   cursor(byword(15,0));
  194. end;
  195.  
  196. procedure find_winner(i,j: integer);
  197.   var a,b,k,m,n,p: integer;  save: array[1..5] of integer;
  198.   label return;
  199. begin
  200.   p:=ppp[i,j];
  201.   for n:=1 to 4 do begin
  202.     k:=0;
  203.     for m:=-4 to 4 do begin
  204.       a:=i+m*idir[n]; b:=j+m*jdir[n];
  205.       if  ( a>=1 ) and ( a<=20 ) and ( b>=1 ) and ( b<=20 ) then begin
  206.         if ppp[a,b]=p then begin
  207.           k:=k+1; save[k]:=byword(wrd(a),wrd(b));
  208.           if k>=5 then begin
  209.             for k:=1 to 5 do
  210.              screen[ord(hibyte(save[k])),ord(lobyte(save[k]))].lefta:=inverse;
  211.             locate(byword(8,45));
  212.             if p=1 then write('You') else write('I');
  213.             write(' win after ',move_count:0,' moves.');
  214.             goto return;
  215.           end;
  216.         end
  217.         else k:=0;
  218.       end;
  219.     end;
  220.   end;
  221. return:
  222. end;
  223.  
  224. procedure find_moves(var a,b: integer);
  225.   var i,j,k,m,n,o,r,v,x: integer;  accepted: boolean;
  226.       x_best,o_best,save: array[1..20] of integer;
  227. begin
  228.   m:=0; o:=0;
  229.   for i:=1 to 20 do begin
  230.     for j:=1 to 20 do begin
  231.       v:=ooo[i,j];
  232.       if v>=o then begin
  233.         if v>o then m:=1 else if m<20 then m:=m+1;
  234.         o_best[m]:=byword(wrd(i),wrd(j)); o:=v;
  235.       end;
  236.     end;
  237.   end;
  238.   accepted:=false;
  239.   repeat
  240.     n:=0; x:=0;
  241.     for i:=1 to 20 do begin
  242.       for j:=1 to 20 do begin
  243.         v:=xxx[i,j];
  244.         if v>=x then begin
  245.           if v>x then n:=1 else if n<20 then n:=n+1;
  246.           x_best[n]:=byword(wrd(i),wrd(j)); x:=v;
  247.         end;
  248.       end;
  249.     end;
  250.     if  ( x=112 ) and ( random1(2)=1 )
  251.     then xxx[ord(hibyte(x_best[1])),ord(lobyte(x_best[1]))]:=82
  252.     else accepted:=true;
  253.   until accepted;
  254.   r:=0; v:=0;
  255.   if ( x>=o ) or ( o<200 ) and ( x>0 ) and ( random1(2)=1 ) then begin
  256.     if o<=25 then begin
  257.       save:=x_best; r:=n;
  258.     end
  259.     else begin
  260.       for k:=1 to n do begin
  261.         o:=ooo[ord(hibyte(x_best[k])),ord(lobyte(x_best[k]))];
  262.         if o>=v then begin
  263.           if o>v then r:=1 else r:=r+1;
  264.           save[r]:=x_best[k]; v:=o;
  265.         end;
  266.       end;
  267.     end;
  268.   end
  269.   else begin
  270.     for k:=1 to m do begin
  271.       x:=xxx[ord(hibyte(o_best[k])),ord(lobyte(o_best[k]))];
  272.       if x>=v then begin
  273.         if x>v then r:=1 else r:=r+1;
  274.         save[r]:=o_best[k]; v:=x;
  275.       end;
  276.     end;
  277.   end;
  278.   r:=random1(r); a:=ord(hibyte(save[r])); b:=ord(lobyte(save[r]));
  279. end;
  280.  
  281. function scan4(p,i,j: integer): integer;
  282.   var a,b,d,k,m,n,o,r,s,sgn,t,v,x: integer;
  283.       vvv: array[1..4] of integer;
  284.       ttt: array[1..2] of integer;
  285.       label break,return;
  286. begin
  287.   for d:=1 to 4 do begin
  288.     r:=0; s:=0; t:=0; v:=0; sgn:=1;
  289.     for n:=1 to 2 do begin
  290.       sgn:=-sgn; m:=5;
  291.       for k:=1 to 4 do begin
  292.         a:=i+sgn*k*idir[d]; b:=j+sgn*k*jdir[d]; x:=-1;
  293.         if  (a<1) or (a>20) or (b<1) or (b>20) or ( x=(3-p) ) then begin
  294.           if m=5 then t:=2 else if  ( m=3 ) and ( o=p ) then r:=1;
  295.           goto break;
  296.         end
  297.         else
  298.           x:=ppp[a,b];
  299.         if x=p then v:=v+m else m:=(m+1) div 2;
  300.         o:=x; s:=s+1;
  301.       end;
  302.       break:
  303.     end;
  304.     if s<4 then v:=0 else v:=v*v;
  305.     if v<400 then if t=2 then v:=v div 2 else v:=v-r;
  306.     vvv[d]:=v;
  307.   end;
  308.   m:=1;
  309.   for n:=1 to 2 do begin
  310.     for d:=1 to 4 do if vvv[d]>vvv[m] then m:=d;
  311.     v:=vvv[m]; vvv[m]:=0;
  312.     if v>=400 then v:=v+v;
  313.     if v>=255 then v:=(v+v)*p;
  314.     ttt[n]:=v;
  315.   end;
  316.   scan4:=ttt[1]+ttt[2];
  317.   for n:=1 to 7 do begin
  318.     for m:=1 to 7 do begin
  319.       if ( ttt[1]=ccc[n] ) and ( ttt[2]=ccc[m] ) then begin
  320.         if ( m>3 ) or ( n>3 ) then scan4:=400*p else scan4:=200;
  321.         goto return;
  322.       end;
  323.     end;
  324.   end;
  325. return:
  326. end;
  327.  
  328. procedure set_values(i,j: integer);
  329.   var a,b,sgn,v,w,x,y,z: integer;
  330.   label break;
  331. begin
  332.   ooo[i,j]:=0; xxx[i,j]:=0; sgn:=1;
  333.   for w:=1 to 4 do begin
  334.     for x:=1 to 2 do begin
  335.       for y:=1 to 2 do begin
  336.         sgn:=-sgn;
  337.         for z:=1 to 4 do begin
  338.           a:=i+sgn*z*idir[w]; b:=j+sgn*z*jdir[w];
  339.           if  ( a<1 ) or ( a>20 ) or ( b<1 ) or ( b>20 ) then goto break;
  340.           if ppp[a,b]=0 then begin
  341.             if x=1 then ooo[a,b]:=scan4(x,a,b) else xxx[a,b]:=scan4(x,a,b);
  342.           end
  343.           else if x<>ppp[a,b] then goto break;
  344.         end;
  345.         break:
  346.       end;
  347.     end;
  348.   end;
  349. end;
  350.  
  351. begin
  352. {  screen.s:=#b000; screen.r:=0;}
  353.     for i := 1 to 20 do
  354.     for j := 1 to 20 do
  355.     begin
  356.        xxx[i,j] := 0;
  357.        ooo[i,j] := 0;
  358.        ppp[i,j] := 0;
  359.        end;
  360.   cursor(byword(15,0)); board; locate(byword(10,45));
  361.   write('Do you wish to see the rules? '); cursor(byword(12,13));
  362.   repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
  363.   if hibyte(inchar)=21 { Y } then print_help(inchar);
  364.   if hibyte(inchar)<>1 { ESC } then inchar:=byword(21,0);
  365.   while hibyte(inchar)=21 do begin { for each game }
  366. {    fillc(adr xxx,sizeof(xxx),chr(0));
  367.     fillc(adr ooo,sizeof(ooo),chr(0));
  368.     fillc(adr ppp,sizeof(ppp),chr(0));}
  369.     for i := 1 to 20 do
  370.     for j := 1 to 20 do
  371.     begin
  372.        xxx[i,j] := 0;
  373.        ooo[i,j] := 0;
  374.        ppp[i,j] := 0;
  375.        end;
  376.  
  377.     clrscr;
  378.     move_count:=0; board; locate(byword(10,45));
  379.     write('Shall I move first? '); cursor(byword(12,13));
  380.     repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
  381.     scroll(byword(0,43),byword(24,79),25);
  382.     if hibyte(inchar)=1 { ESC } then ch:=quit
  383.     else if hibyte(inchar)=21 { Y } then begin
  384.       i:=random1(10)+5; j:=random1(10)+5;
  385.       moveto(2,i,j);
  386.       set_values(i,j);
  387.     end
  388.     else begin i:=10; j:=10; end;
  389.     while ( ch<>replay ) and ( ch<>quit ) and ( move_count<400 ) do begin
  390.       position(i,j,ch);
  391.       if ch=chr(13) then begin
  392.         moveto(1,i,j);
  393.         if ooo[i,j]>=1600 then begin
  394.           find_winner(i,j); ch:=replay;
  395.         end
  396.         else if move_count<400 then begin
  397.           set_values(i,j);
  398.           find_moves(i,j);
  399.           moveto(2,i,j);
  400.           if xxx[i,j]>=3200 then begin
  401.             find_winner(i,j); ch:=replay;
  402.           end
  403.           else set_values(i,j);
  404.         end;
  405.       end;
  406.     end;
  407.     if ch=replay then begin
  408.       locate(byword(10,45)); write('Again? '); cursor(byword(12,13));
  409.       repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
  410.       ch:=' ';
  411.     end
  412.     else inchar:=0;
  413.   end;
  414.   locate(byword(22,0)); cursor(byword(12,13));
  415. end.
  416.