home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / source / demo / text / blackbox.pp next >
Encoding:
Text File  |  2000-01-01  |  4.9 KB  |  202 lines

  1. {
  2.     $Id: blackbox.pp,v 1.1 2000/03/09 02:49:09 alex Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1993-98 by Michael Van Canneyt
  5.  
  6.     Blackbox Game Example
  7.  
  8.     See the file COPYING.FPC, included in this distribution,
  9.     for details about the copyright.
  10.  
  11.     This program is distributed in the hope that it will be useful,
  12.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14.  
  15.  **********************************************************************}
  16. Program blackbox;
  17.  
  18. {
  19.   The object of the game is simple : You have a box of 9x9x9 cells.
  20.   you can enter a number of atoms that will be put in the box.
  21.   Then you can start shooting in the box with a laser beam.
  22.   You enter the coordinates where the beam enters the box.
  23.   (this must be on the edges, this means that one of the coordinates
  24.   must be 1 or 9...)
  25.   The beam will bounce off the atoms (using normal bouncing), and you
  26.   will be told where the beam exits.
  27.   From this you must guess where the atoms are...
  28. }
  29.  
  30. Const MaxSize = 9;
  31.       MaxAtom = 10;
  32.  
  33. Type TRow   = Array [0..MaxSize+1] of byte;
  34.      TPlane = Array [0..MaxSize+1] of TRow;
  35.      TCube  = Array [0..MaxSize+1] of TPlane;
  36.  
  37. Var
  38.   Cube                 : TCube;
  39.   Count,Guessed,x,y,z  : Longint;
  40.   ans : string;
  41.  
  42. Procedure FillCube;
  43.  
  44. var i,x,y,z : longint;
  45.  
  46. begin
  47.   randomize;
  48.   for x:=0 to maxsize+1 do
  49.     for y:=0 to maxsize+1 do
  50.       for z:=0 to maxsize+1 do
  51.         Cube[x,y,z]:=0;
  52.   repeat
  53.     Write ('Enter number of atoms (1-',maxatom,') : ');
  54.     readln (count);
  55.     if (count<1) or (count>MaxAtom) then
  56.       writeln ('Invalid value entered. Please try again.');
  57.   until (count>0) and (count<=MaxAtom);
  58.   for I:=1 to count do
  59.      begin
  60.      repeat
  61.        x:=Random(MaxSize)+1;
  62.        y:=Random(MaxSize)+1;
  63.        z:=Random(MaxSize)+1;
  64.      until Cube[x,y,z]=0;
  65.      Cube[x,y,z]:=1;
  66.      end;
  67. end;
  68.  
  69. Procedure GetCoords (Var X,y,z : longint);
  70.  
  71. begin
  72.   Write ('X : ');
  73.   readln (x);
  74.   write ('Y : ');
  75.   readln (y);
  76.   write ('z : ');
  77.   readln (z);
  78. end;
  79.  
  80. Procedure GetStart (Var x,y,z : longint);
  81.  
  82. Var OK : boolean;
  83.  
  84. begin
  85.   Writeln ('Please enter beam start coordinates : ');
  86.   Repeat
  87.     GetCoords (x,y,z);
  88.     OK:=((X=1) or (X=MaxSize)) or ((y=1) or (Y=MaxSize)) or
  89.         ((Z=1) or (z=maxsize));
  90.     if Not OK then
  91.       writeln ('The beam should enter at an edge. Please try again');
  92.   until OK;
  93. end;
  94.  
  95. Function GetGuess : boolean;
  96.  
  97. Var OK : boolean;
  98.     x,y,z : longint;
  99.  
  100. begin
  101.   Writeln ('Please enter atom coordinates : ');
  102.   Repeat
  103.     getcoords (x,y,z);
  104.     OK:=((X>=1) or (X<=MaxSize)) or ((y>=1) or (Y<=MaxSize)) or
  105.         ((Z>=1) or (z<=maxsize));
  106.     if Not OK then
  107.       writeln ('These are not valid coordinates. Please try again');
  108.   until OK;
  109.   GetGuess:=False;
  110.   If Cube[x,y,z]<0 then
  111.     Writeln ('You already had this one ! Trying to be clever, eh ?')
  112.   else if Cube[x,y,z]>0 then
  113.     begin
  114.     Writeln ('Correct guess !');
  115.     Cube[x,y,z]:=-Cube[x,y,z];
  116.     getguess:=true;
  117.     end
  118.   else
  119.     Writeln ('Wrong guess !');
  120. end;
  121.  
  122. Procedure CalcExit (X,Y,Z : longint);
  123.  
  124. var tx,ty,tz,dx,dy,dz : longint;
  125.  
  126. begin
  127.   dx:=0;dy:=0;dz:=0;
  128.   if x=1 then dx:=1 else if x=MaxSize then dx:=-1;
  129.   if y=1 then dy:=1 else if y=MaxSize then dy:=-1;
  130.   if z=1 then dz:=1 else if z=MaxSize then dz:=-1;
  131.   writeln ('Direction : ',dx,',',dy,',',dz);
  132.   repeat
  133.   for tx:=-1 to 1 do
  134.     for ty:=-1 to 1 do
  135.       for tz:=-1 to 1 do
  136.         if Cube [X+tx,y+ty,z+tz]<>0 then
  137.           begin
  138.           dx:=dx-tx;
  139.           dy:=dy-ty;
  140.           dz:=dz-tz;
  141.           end;
  142.   if dx<>0 then dx:=dx div abs(dx);
  143.   if dz<>0 then dz:=dz div abs(dz);
  144.   if dy<>0 then dy:=dy div abs(dy);
  145.   x:=x+dx;y:=y+dy;z:=z+dz;
  146.   until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or
  147.         ((z=0) or (z=maxsize+1));
  148.   Writeln ('Beam exited at : (',x-dx,',',y-dy,',',z-dz,')');
  149. end;
  150.  
  151. {
  152. Procedure DumpCube ;
  153.  
  154. Var x,y,z : longint;
  155.  
  156. begin
  157.   for x:=1 to MaxSize do
  158.     for y:=1 to maxsize do
  159.       for z:=1 to maxsize do
  160.         if Cube[x,y,z]<>0 then
  161.           writeln ('Atom at (',x,',',y,',',z,')');
  162. end;
  163. }
  164.  
  165. begin
  166.   FillCube;
  167.   Guessed:=0;
  168.   Repeat
  169.     repeat
  170.       Write ('Shoot, guess or quit (s/g/q) : ');
  171.       readln (ans);
  172.       ans[1]:=Upcase(ans[1]);
  173.       if not (ans[1] in ['S','G','Q']) then
  174.         writeln ('Invalid entry. Please try again.');
  175.     until ans[1] in ['S','G','Q'];
  176.     Case ans[1] of
  177.      'S' : begin
  178.            getstart (x,y,z);
  179.            calcexit (x,y,z);
  180.            end;
  181.      'G' : If GetGuess then Inc(Guessed);
  182.     end;
  183.   until (ans[1]='Q') or (guessed=count);
  184.   If Guessed=count then
  185.     Writeln ('Congratulations! All ',Count,' correct !')
  186.   else
  187.     Writeln ('Only ',guessed,' out of ',count,' correct...');
  188. end.
  189.  
  190. {
  191.   $Log: blackbox.pp,v $
  192.   Revision 1.1  2000/03/09 02:49:09  alex
  193.   moved files
  194.  
  195.   Revision 1.3  2000/02/22 03:14:17  alex
  196.   fixed the warning
  197.  
  198.   Revision 1.2  1998/09/11 10:55:20  peter
  199.     + header+log
  200.  
  201. }
  202.