ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/MBUG/MBUG017.ARC/STARSHOT.PAS

Pascal/Delphi Source File | 1979-12-31 | 6KB | 260 lines

Program StarShot(Input,Output);
{Writen by Peter Billing   14 - 6 - 1985}

Const
  on   = '*';
  off  = 'o';

Var
  board    : array[1..3,1..5] of char;
  i,j      : integer;
  quit     : boolean;
  move     : integer;

  Procedure Initialize;
  begin
    move :=0;
    for i := 1 to 3 do
    for j := 1 to 5 do
    board[i,j] := off;
    board[2,3] := on;
    for i := 1 to 3 do
    begin
      board[i,2] := ' ';
      board[i,4] := ' ';
    end;
    gotoxy(20,16); writeln('1 2 3');
    gotoxy(20,17); writeln('4 5 6');
    gotoxy(20,18); writeln('7 8 9');
    gotoxy(34,14);
    writeln('               ');
    gotoxy(25,23);
    writeln('                              ');
  end;

  Procedure Instruction;
  begin
    gotoxy(1,1);
    writeln('S T A R    S H O O T':48);
    writeln;
    writeln('You may only shoot at stars that are turned on. eg "on" The star will turn off');
    writeln('eg "o", and depending on its position will turn on stars adjacent to itself.');
    writeln('The object of the game is to reverse the initial pattern.');
    writeln;
    writeln('             INITIAL                              FINAL');
    writeln('              o o o                               * * *');
    writeln('              o * o                               * o *');
    writeln('              o o o                               * * *');
    writeln;
    writeln(' Best possible score is 11 moves.  Enter 0 to start again, Q to Quit.');
    writeln(' Press D for a DEMONSTRATION in 11 moves.');
  end;

  Procedure Display;
  var
    y,i,j : integer;
  begin
    gotoxy(30,15); write('Move >',move:2);
    y := 15;
    for i := 1 to 3 do
    begin
      writeln;
      gotoxy(38,y+i);
      for j := 1 to 5 do
      write(board[i,j]);
    end;
  end;

  Procedure Horizontal(x : integer);
  var
    y : integer;
  begin
    y := 1;
    repeat
      if board[x,y] =on
        then board[x,y] := off
        else board[x,y] := on;
      y := y + 2;
    until y = 7;
    move := move +1;
  end;

  Procedure Vertical(y : integer);
  var
    x : integer;
  begin
    for x := 1 to 3 do
    if board[x,y] =on
      then board[x,y] := off
      else board[x,y] := on;
    move := move +1;
  end;

Procedure Center;
begin
  horizontal(2);
  if board[1,3] =on
     then board[1,3] := off
     else board[1,3] := on;
  if board[3,3] =on
     then board[3,3] := off
     else board[3,3] := on;
end;

  Procedure Corner(x,y : integer);
  var
    temp : integer;
  begin
    temp := y;
    for i := x to x+1 do
    begin
      y := temp;
      repeat
        if board[i,y] =on
          then board[i,y] := off
          else board[i,y] := on;
        y := y+2;
      until temp+4 = y;
    end;
    move := move +1;
  end;

  Function Check(x,y :integer) :boolean;
  begin
    if board[x,y] = on
      then check := true
      else check := false;
  end;

  Function Win :boolean;
  var
    z,x,y :integer;
  begin
    z := 0;
    x := 1;
    repeat
      y := 1;
      repeat
        if board[x,y] = off
          then z := 1;
        y := y+2;
      until y=7;
      x := x+2
    until x = 5;
    if board[2,1] = off
      then z := 1;
    if board[2,5] = off
      then z := 1;
    if board[2,3] = on
      then z := 1;
    if z=1
      then win := false
      else win := true;
  end;

Procedure p;
begin
  delay (1000)
end;

Procedure Demo;
begin
  center;       display;p;
  horizontal(3);display;p;
  corner(2,1);  display;p;
  corner(2,3);  display;p;
  horizontal(1);display;p;
  corner(1,1);  display;p;
  center;       display;p;
  corner(1,3);  display;p;
  horizontal(1);display;p;
  horizontal(3);display;p;
  center;       display;p;
end;


  Procedure Command;
  var
    x,y,k : integer;
    ch : char;
  begin
    gotoxy(25,22);
    write('Command > ');
    read(kbd,ch);
    write(ch);
    case ch of
      '5'  :
            if check(2,3)
              then center;
      '4'  :
            if check(2,1)
              then vertical(1);
      '6'  :
            if check(2,5)
              then vertical(5);
      '2'  :
            if check(1,3)
              then horizontal(1);
      '8'  :
            if check(3,3)
              then horizontal(3);
      '1'  :
            if check(1,1)
              then corner(1,1);
      '3'  :
            if check(1,5)
              then corner(1,3);
      '7'  :
            if check(3,1)
              then corner(2,1);
      '9'  :
            if check(3,5)
              then corner(2,3);
      '0'  :
             Initialize;
      'd','D' :
               if move < 1
                then demo;
      'q','Q' :
             quit := true;
      else command
    end;
    display;
    if win
      then
        begin
          gotoxy(34,14);
          writeln('You have won!!!');
          gotoxy(25,23);
          writeln('Do you wish to try again? Y/N ');
          gotoxy(25,22);write('Command > ');
          repeat
            read(kbd,ch);
          until upcase(ch) in ['Y','N'];
          if upcase(ch) = 'Y'
            then
              begin
                quit := false;
                initialize;
                display
              end
            else
              begin
                quit := true;
                clrscr
              end
            end;
       if (ch ='D') or (ch ='d') then quit := false;
  end;

begin
  ClrScr;
  Initialize;
  Instruction;
  Display;
  Quit := false;
  Repeat
    Command;
  Until quit;
end.