fpc/install/demo/blackbox.pp

Program blackbox;
{
  (c) 1998 Michael Van Canneyt
  
  The object of the game is simple : You have a box of 9x9x9 cells.
  you can enter a number of atoms that will be put in the box.
  Then you can start shooting in the box with a laser beam.
  You enter the coordinates where the beam enters the box.
  (this must be on the edges, this means that one of the coordinates
  must be 1 or 9...)
  The beam will bounce off the atoms (using normal bouncing), and you 
  will be told where the beam exits. 
  From this you must guess where the atoms are...
}

Const MaxSize = 9;
      MaxAtom = 10;
      
Type TRow   = Array [0..MaxSize+1] of byte;
     TPlane = Array [0..MaxSize+1] of TRow;
     TCube  = Array [0..MaxSize+1] of TPlane;

Var
  Cube                 : TCube;
  Count,Guessed,x,y,z  : Longint;
  ans : string;
  
Procedure FillCube;

var i,x,y,z : longint;

begin
  randomize;
  for x:=0 to maxsize+1 do
    for y:=0 to maxsize+1 do
      for z:=0 to maxsize+1 do
        Cube[x,y,z]:=0;
  repeat
    Write ('Enter number of atoms (1-',maxatom,') : ');
    readln (count);
    if (count<1) or (count>MaxAtom) then 
      writeln ('Invalid value entered. Please try again.');
  until (count>0) and (count<=MaxAtom);
  for I:=1 to count do
     begin
     repeat
       x:=Random(MaxSize)+1;
       y:=Random(MaxSize)+1;
       z:=Random(MaxSize)+1;
     until Cube[x,y,z]=0;
     Cube[x,y,z]:=1;
     end;   
end;

Procedure GetCoords (Var X,y,z : longint);

begin
  Write ('X : ');
  readln (x);
  write ('Y : ');
  readln (y);
  write ('z : ');
  readln (z);
end;

Procedure GetStart (Var x,y,z : longint);

Var OK : boolean;

begin
  Writeln ('Please enter beam start coordinates : '); 
  Repeat
    GetCoords (x,y,z);
    OK:=((X=1) or (X=MaxSize)) or ((y=1) or (Y=MaxSize)) or
        ((Z=1) or (z=maxsize));
    if Not OK then 
      writeln ('The beam should enter at an edge. Please try again');
  until OK;
end;

Function GetGuess : boolean;

Var OK : boolean;
    x,y,z : longint;
    
begin
  Writeln ('Please enter atom coordinates : '); 
  Repeat
    getcoords (x,y,z);
    OK:=((X>=1) or (X<=MaxSize)) or ((y>=1) or (Y<=MaxSize)) or
        ((Z>=1) or (z<=maxsize));
    if Not OK then 
      writeln ('These are not valid coordinates. Please try again');
  until OK;
  GetGuess:=False;
  If Cube[x,y,z]<0 then
    Writeln ('You already had this one ! Trying to be clever, eh ?')
  else if Cube[x,y,z]>0 then
    begin
    Writeln ('Correct guess !');
    Cube[x,y,z]:=-Cube[x,y,z];
    getguess:=true;
    end 
  else
    Writeln ('Wrong guess !');
end;

Procedure CalcExit (X,Y,Z : longint);

var tx,ty,tz,dx,dy,dz : longint;

begin
  dx:=0;dy:=0;dz:=0;
  if x=1 then dx:=1 else if x=MaxSize then dx:=-1;
  if y=1 then dy:=1 else if y=MaxSize then dy:=-1;
  if z=1 then dz:=1 else if z=MaxSize then dz:=-1;
  writeln ('Direction : ',dx,',',dy,',',dz);
  repeat
  for tx:=-1 to 1 do
    for ty:=-1 to 1 do
      for tz:=-1 to 1 do
        if Cube [X+tx,y+ty,z+tz]<>0 then
          begin
          dx:=dx-tx;
          dy:=dy-ty;
          dz:=dz-tz;
          end;
  if dx<>0 then dx:=dx div abs(dx);
  if dz<>0 then dz:=dz div abs(dz);
  if dy<>0 then dy:=dy div abs(dy);
  x:=x+dx;y:=y+dy;z:=z+dz;
  until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or 
        ((z=0) or (z=maxsize+1)); 
  Writeln ('Beam exited at : (',x-dx,',',y-dy,',',z-dz,')');
end;

Procedure DumpCube ;

Var x,y,z : longint;

begin
  for x:=1 to MaxSize do
    for y:=1 to maxsize do
      for z:=1 to maxsize do
        if Cube[x,y,z]<>0 then 
          writeln ('Atom at (',x,',',y,',',z,')');
end;

begin
  FillCube;
  Guessed:=0;
  Repeat
    repeat
      Write ('Shoot, guess or quit (s/g/q) : ');
      readln (ans);
      ans[1]:=Upcase(ans[1]);
      if not (ans[1] in ['S','G','Q']) then 
        writeln ('Invalid entry. Please try again.');
    until ans[1] in ['S','G','Q'];
    Case ans[1] of
     'S' : begin
           getstart (x,y,z);
           calcexit (x,y,z);
           end;
     'G' : If GetGuess then Inc(Guessed);
    end;
  until (ans[1]='Q') or (guessed=count);
  If Guessed=count then
    Writeln ('Congratulations! All ',Count,' correct !')
  else
    Writeln ('Only ',guessed,' out of ',count,' correct...');  
end.