Web Version of Battleships

Smart Pascal version of Battleships by Lewis Wright: Y12 Age ~16

Introduction

This web version of Battleships is designed as a preview to be run in a browser on a PC. If the program does not work in your current browser, try another such as Chrome. If you see no display at school, the security system might have blocked it. You can try instead this direct link to the program running on its own page. The Smart Pascal code of the main unit follows the program in action. See the web version of MorseCode for the code of the Crt unit. On a Raspberry Pi, install the Lucida Console font.

Program in Action

Battleships.html

You may prefer this direct link rather than viewing the game in an object window.

Code of the Main Unit

unit Unit1;
{
    Copyright (c) 2010 Lewis Wright

    Licensed under the Apache License, Version 2.0 (the "License"); you may not
    use this file except in compliance with the License, as described at
    http://www.apache.org/licenses/ and http://www.pp4s.co.uk/licenses/

    Converted to Smart Pascal for web preview by PPS 2014
}

interface

uses
  System.Types, SmartCL.System, SmartCL.Components, SmartCL.Application,
  SmartCL.Game, SmartCL.GameApp, SmartCL.Graphics, uCrtCanvas;

type
  TInputState = (isMenu, isIntro, isMain);
  TReadState = (rsNotReading, rsReading, rsFinishedReading);

  TCanvasProject = class(TW3CustomGameApplication)
  private
    const DELAY = 20;
    const SCALE_FACTOR = 2;
    const CELL_WIDTH = 5 * SCALE_FACTOR;
    const CELL_HEIGHT = 8 * SCALE_FACTOR;
    const FONT_SIZE = 9 * SCALE_FACTOR;
    const ROWS = 25;
    const COLS = 80;
    const WIDTH = COLS * CELL_WIDTH;
    const HEIGHT = ROWS * CELL_HEIGHT;
    success: array[1..5] of boolean;
    comp_success: array[1..5] of boolean;
    valid, valid2, fired: boolean;
    main_entry : integer;
    input_state: TInputState = isMenu;
    reading_state: TReadState = rsNotReading;
    ViewingTime: integer;
    TempReadString: string = '';
    Grid: TConsoleGrid;
    FirstShowing: Boolean := true;
    FirstShow: Boolean := true;
    attacked, ships, compships, compattacked : array[0..13, 0..13] of string;
    tempy, hitr, invalidcount, hitrx, hitry, longhitrx, dfind, hitcount, done, hitcount2, done2,
      spacepos, longhitry, misscheck, tempx, attx, atty, cattx, catty, sunk, compsunk: integer;
    direction, dirr, firstfound : string;
    hitships, comphitships : array[1..5, 1..6] of integer;
  protected
    procedure ApplicationStarting; override;
    procedure ApplicationClosing; override;
    procedure PaintView(Canvas: TW3Canvas); override;
    procedure KeyDownEvent(mCode: integer);
    procedure GoToXY(X, Y: integer);
    procedure clrscr;
    procedure ClrEOL;
    procedure textColor(colour: TConsoleColour);
    procedure textBackground(colour: TConsoleColour);
    procedure write(txt: string);
    procedure writeln(txt: string); overload;
    procedure writeln; overload;
    procedure readln(var InputString : string); overload;
    procedure readln; overload;
    procedure Sleep(Duration: integer);
    procedure inputships(noofspaces: integer; identifier: string);
    procedure printships;
    procedure printcompships;
    procedure printattacked;
    procedure printcompattacked;
    procedure humanturn;
    procedure compturn;
    procedure cominputships(spaces: integer; id: string);
    procedure Main;
    procedure Intro;
  end;

implementation

var
  choice, tempxyd, intro, dummy, direction2, strXY : string;

procedure TCanvasProject.Sleep(Duration: integer);
begin //http://stackoverflow.com/questions/16873323/javascript-sleep-wait-before-continuing
  asm
    var start = new Date().getTime();
    for (var i = 0; i < 1e7; i++) {
      if ((new Date().getTime() - start) > @Duration){
        break;
      }
    }
  end;
end;

procedure TCanvasProject.inputships(noofspaces: integer; identifier: string);
var
  temps: array of string;
begin
  readln(tempxyd);
  if FirstShow then
    begin
      valid := true;
      direction := ' ';
      FirstShow := False;
    end;

  if not ((reading_state = rsNotReading) and (length(tempxyd) > 4)) then
    exit;
  writeln;
  temps := strSplit(TempReadString, ' ');
  tempx := strToInt(temps[0]);
  tempy := strToInt(temps[1]);
  direction := temps[2];
  case direction of
    'R' : if tempx + noofspaces - 1 > 12 then valid := false;
    'L' : if tempx - noofspaces + 1 < 1 then valid := false;
    'U' : if tempy - noofspaces + 1 < 1 then valid := false;
    'D' : if tempy + noofspaces - 1 > 12 then valid := false;
  end;

  if (direction <> 'R') and (direction <> 'L') and (direction <> 'D') and (direction <> 'U') then
    valid := false;
  try
    for var count := 1 to noofspaces do
      begin
        if direction = 'R' then
          if ships[tempx + count, tempy] <> 'O' then
            valid := false;
        if direction = 'L' then
          if ships[tempx - count, tempy] <> 'O' then
            valid := false;
        if direction = 'U' then
          if ships[tempx, tempy - count] <> 'O' then
            valid := false;
        if direction = 'D' then
          if ships[tempx, tempy + count] <> 'O' then
            valid := false;
       end;

    for var count999 := 0 to noofspaces - 1 do
      begin
        case direction of
          'U': if (ships[tempx,tempy-count999+1] <> 'O') and(ships[tempx,tempy-count999+1] <> identifier)
                   or (ships[tempx,tempy-count999-1] <> 'O') and (ships[tempx,tempy-count999-1] <> identifier)
                   or(ships[tempx-1,tempy-count999] <> 'O') and (ships[tempx-1,tempy-count999] <> identifier)
                   or(ships[tempx+1,tempy-count999] <> 'O') and (ships[tempx+1,tempy-count999] <> identifier)then
                 valid := false;
          'L': if (ships[tempx-count999,tempy+1] <> 'O') and (ships[tempx-count999,tempy+1] <> identifier)
                   or (ships[tempx-count999,tempy-1] <> 'O') and (ships[tempx-count999,tempy-1] <> identifier)
                   or (ships[tempx-1-count999,tempy] <> 'O') and (ships[tempx-1-count999,tempy] <> identifier)
                   or (ships[tempx+1-count999,tempy] <> 'O') and (ships[tempx+1-count999,tempy] <> identifier) then
                  valid := false;
          'R': if (ships[tempx+count999,tempy+1] <> 'O') and (ships[tempx+count999,tempy+1] <> identifier)
                   or (ships[tempx+count999,tempy-1] <> 'O') and (ships[tempx+count999,tempy-1] <> identifier)
                   or (ships[tempx+count999-1,tempy] <> 'O') and (ships[tempx+count999-1,tempy] <> identifier)
                   or (ships[tempx+1+count999,tempy] <> 'O') and (ships[tempx+1+count999,tempy] <> 'O') then
                  valid := false;
          'D': if (ships[tempx,tempy+count999+1] <> 'O') and (ships[tempx,tempy+count999+1] <> identifier)
                   or (ships[tempx,tempy+count999-1] <> 'O') and (ships[tempx,tempy+count999-1] <> identifier)
                   or (ships[tempx-1,tempy+count999] <> 'O') and (ships[tempx-1,tempy+count999] <> identifier)
                   or (ships[tempx+1,tempy+count999] <> 'O') and (ships[tempx+1,tempy+count999] <> identifier) then
                  valid := false;
        end;
      end;
  except
    valid := false;
  end;

  if valid = false then
    begin
      if invalidcount = 3 then
        begin
          ClrScr;
          ViewingTime += 3000;
          writeln('"Know what Captain? I think I will take the lead on this one."');
          writeln;
          //sleep(4000);
          writeln('"Too many lives at stake for messing about"');
          writeln;
          //sleep(4000);
          writeln;
          writeln('"And as Captain I now have power over you - have fun in the brig *COLONEL*"');
          //sleep(3000);
          ShowMessage('Game over');
          ApplicationClosing;
        end;

      if invalidcount = 2 then
        begin
          inc(invalidcount);
          ViewingTime += 1000;
          writeln('"Are you sure you are alright Captain? Maybe you should take a walk..."');
          writeln('*off the side of the boat*');
          tempxyd := '';
          FirstShow := true; // This will make valid true again
          TempReadString := '';
          exit; //to try again
        end;

      if invalidcount = 1 then
        begin
          inc(invalidcount);
          ViewingTime += 1000;
          writeln('"Look Captain, the rules are fairly simple - X Y Dir - not side by side!"');
          writeln('"TRY HARDER!"');
          tempxyd := '';
          TempReadString := '';
          FirstShow := true; // This will make valid true again
          exit; //to try again

        end;

      if invalidcount = 0 then
        begin
          inc(invalidcount);
          ViewingTime += 1000;
          writeln('"Err... maybe you would like another go at that one Captain..." *SIGH*');
          tempxyd := '';
          TempReadString := '';
          FirstShow := true; // This will make valid true again
          exit; //to try again
        end;
    end;
  for var count := 1 to noofspaces do
    begin
      ships[tempx,tempy] := identifier;
      case direction of
        'R' : inc(tempx);
        'L' : dec(tempx);
        'U' : dec(tempy);
        'D' : inc(tempy);
      end;
    end;
   success[noofspaces] := true;
end;

procedure TCanvasProject.printships;
var
  count2: integer;
begin
  writeln('  123456789...');
  for count2 := 1 to 12 do
    begin
      if count2 < 10 then
        begin
          writeln(inttostr(count2)+' '+ships[1,count2]+ships[2,count2]+ships[3,count2]+ships[4,count2]+ships[5,count2]+
          ships[6,count2]+ships[7,count2]+ships[8,count2]+ships[9,count2]+ships[10,count2]+ships[11,count2]+ships[12,count2]);
        end
      else
        begin
          writeln('. '+ships[1,count2]+ships[2,count2]+ships[3,count2]+ships[4,count2]+ships[5,count2]+ships[6,count2]+
          ships[7,count2]+ships[8,count2]+ships[9,count2]+ships[10,count2]+ships[11,count2]+ships[12,count2]);
        end;
    end;
end;

procedure TCanvasProject.printcompships;
begin
  writeln('  123456789...');
  for var count3 := 1 to 12 do
    begin
      if count3 < 10 then
        begin
          writeln(inttostr(count3)+' '+compships[1,count3]+compships[2,count3]+compships[3,count3]+compships[4,count3]+
          compships[5,count3]+compships[6,count3]+compships[7,count3]+compships[8,count3]+compships[9,count3]+
          compships[10,count3]+compships[11,count3]+compships[12,count3])
        end
      else
        begin
          writeln('. '+compships[1,count3]+compships[2,count3]+compships[3,count3]+compships[4,count3]+
          compships[5,count3]+compships[6,count3]+compships[7,count3]+compships[8,count3]+compships[9,count3]+
          compships[10,count3]+compships[11,count3]+compships[12,count3])
        end;
    end;
end;

procedure TCanvasProject.printattacked;
begin
  //Needs sleep to allow reading of comp's attacks
  ClrScr;
  writeln('Here are the places you have attacked thus far');
  writeln('  123456789...');
  for var count3 := 1 to 12 do
    begin
      if count3 < 10 then
        begin
          writeln(intToStr(count3)+' '+attacked[1,count3]+attacked[2,count3]+attacked[3,count3]+attacked[4,count3]+
          attacked[5,count3]+attacked[6,count3]+attacked[7,count3]+attacked[8,count3]+attacked[9,count3]+
          attacked[10,count3]+attacked[11,count3]+attacked[12,count3])
        end
      else
        begin
          writeln('. '+attacked[1,count3]+attacked[2,count3]+attacked[3,count3]+attacked[4,count3]+
          attacked[5,count3]+attacked[6,count3]+attacked[7,count3]+attacked[8,count3]+attacked[9,count3]+
          attacked[10,count3]+attacked[11,count3]+attacked[12,count3])
        end;
    end;
end;

procedure TCanvasProject.printcompattacked;
begin
  writeln('  123456789...');
  for var count3 := 1 to 12 do
    begin
      if count3 < 10 then
        begin
          writeln(inttostr(count3)+' '+compattacked[1,count3]+compattacked[2,count3]+compattacked[3,count3]+
          compattacked[4,count3]+compattacked[5,count3]+compattacked[6,count3]+compattacked[7,count3]+
          compattacked[8,count3]+compattacked[9,count3]+compattacked[10,count3]+compattacked[11,count3]+
          compattacked[12,count3])
        end
      else
        begin
          writeln('. '+compattacked[1,count3]+compattacked[2,count3]+compattacked[3,count3]+
          compattacked[4,count3]+compattacked[5,count3]+compattacked[6,count3]+compattacked[7,count3]+
          compattacked[8,count3]+compattacked[9,count3]+compattacked[10,count3]+compattacked[11,count3]+
          compattacked[12,count3])
        end;
    end;
end;

procedure TCanvasProject.humanturn;
begin
  fired := false;
  printattacked;
  writeln('Input attack longitude (X) and latitude (Y) captain!');
  readln(strXY);
  if not ((reading_state = rsNotReading) and (length(strXY) > 2)) then
    exit;
  spacepos := pos(' ', strXY);
  attX := strToInt(LeftStr(strXY, spacepos - 1));
  attY := strToInt(RightStr(strXY, length(strXY) - spacepos));

  if compships[attX,attY] <> 'O' then
    begin
      writeln('Great Aiming Captain - We HIT them!');
      ViewingTime += 1000;
      attacked[attX, attY] := 'H';
      case compships[attX, attY] of
        'A':
          begin
            hitcount := 0;
            done := 0;
            repeat
              inc(hitcount);
              if hitships[1, hitcount] = 0 then
                begin
                  hitships[1, hitcount] := 1;
                  done := 1;
                end;
              if hitships[1, hitcount + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('We SUNK Their Aircraft Carrier! Good work men!');
                  inc(sunk);
                  done := 1;
                end;
            until done = 1;
          end;
        'B':
          begin
            hitcount := 0;
            done := 0;
            repeat
              inc(hitcount);
              if hitships[2, hitcount] = 0 then
                begin
                  hitships[2, hitcount] := 1;
                  done := 1;
                end;
              if hitships[2, hitcount + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('We SUNK Their Battleship! Good work men!');
                  inc(sunk);
                  done := 1;
                end;
            until done = 1;
          end;
        'C':
          begin
            hitcount := 0;
            done := 0;
            repeat
              inc(hitcount);
              if hitships[3,hitcount] = 0 then
                begin
                  hitships[3,hitcount] := 1;
                  done := 1;
                end;
              if hitships[3,hitcount+1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('We SUNK Their Cruiser! Good work men!');
                  inc(sunk);
                  done := 1;
                end;
            until done = 1;
          end;
        'S':
          begin
            hitcount := 0;
            done := 0;
            repeat
              inc(hitcount);
              if hitships[4, hitcount] = 0 then
                begin
                  hitships[4, hitcount] := 1;
                  done := 1;
                end;
              if hitships[4, hitcount + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('We SUNK Their Submarine! Good work men!');
                  inc(sunk);
                  done := 1;
                end;
            until done = 1;
          end;
        'D':
          begin
            hitcount := 0;
            done := 0;
            repeat
              inc(hitcount);
              if hitships[5, hitcount] = 0 then
                begin
                  hitships[5, hitcount] := 1;
                  done := 1;
                end;
              if hitships[5, hitcount + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('We SUNK Their Destroyer! Good work men!');
                  inc(sunk);
                  done := 1;
                end;
            until done = 1;
          end;
      end;
    end
  else
    begin
      writeln('MISSED');
      sleep(1000);
      attacked[attX, attY] := 'M';
    end;
  Fired := true;
  if sunk = 5 then
    main_entry := 20;
end;

procedure TCanvasProject.compturn;
begin
  if hitr = 0 then
    begin
      repeat
        cattX := RandomInt(12) + 1;
        cattY := RandomInt(12) + 1;
      until (compattacked[cattX,cattY] = 'O') and (compattacked[cattX-1,cattY] <> 'H') and
        (compattacked[cattX,cattY-1] <> 'H') and (compattacked[cattX+1,cattY] <> 'H') and
        (compattacked[cattX,cattY+1] <> 'H');
    end
  else
    begin
      if hitr = 1 then
        begin
          longhitrx := hitrx;
          longhitry := hitry;
          if (compattacked[hitrx + 1, hitry] = 'O') and (hitrx + 1 < 13) then
            begin
              cattX := hitrx+1;
              cattY := hitry;
              firstfound := 'R';
            end
          else
            if (compattacked[hitrx - 1, hitry] = 'O') and (hitrx - 1 > 0) then
              begin
                cattX := hitrx - 1;
                cattY := hitry;
                firstfound := 'L';
              end
            else
              if (compattacked[hitrx, hitry + 1] = 'O') and (hitry + 1 < 13) then
                begin
                  cattX := hitrx;
                  cattY := hitry+1;
                  firstfound := 'D';
                end
              else
                if (compattacked[hitrx, hitry - 1] = 'O') and (hitry - 1 > 0) then
                  begin
                    cattX := hitrx;
                    cattY := hitry - 1;
                    firstfound := 'U';
                  end;
        end
      else
        begin
          if dirr = 'R' then
            begin
              if (misscheck = 1) or ((Firstfound = 'R') and (cattX + 1 > 12)) or
                 ((Firstfound = 'L') and (cattX -1 < 0))  then
                begin
                  if firstfound = 'R' then
                    begin
                      cattY := longhitrY;
                      cattX := longhitrX - 1;
                      firstfound := 'L';
                    end
                  else
                    begin
                      cattY := longhitrY;
                      cattX := longhitrX + 1;
                      firstfound := 'R';
                    end;
                end
              else
                begin
                  if firstfound = 'R' then
                    begin
                      cattY := longhitrY;
                      cattX := hitrX + 1;
                    end
                  else
                    begin
                      cattY := longhitrY;
                      cattX := hitrX - 1;
                    end;
                end;
            end
          else
            begin
              if (misscheck = 1) or ( (Firstfound = 'U') and (cattY - 1 < 1) ) or ((Firstfound = 'D') and (cattY +1 > 12))  then
                begin
                  if firstfound = 'D' then
                    begin
                      cattX := longhitrX;
                      cattY := longhitrY - 1;
                      firstfound := 'U';
                    end
                  else
                    begin
                      cattX := longhitrX;
                      cattY := longhitrY + 1;
                      firstfound := 'D';
                    end;
                 end
              else
                begin
                  if firstfound = 'D' then
                    begin
                      cattX := longhitrX;
                      cattY := hitrY + 1;
                    end
                  else
                    begin
                      cattX := longhitrX;
                      cattY := hitrY - 1;
                    end;
                end;
            end;
          end;
    end;
  ViewingTime += 1000;
  writeln('The Computer is firing sir! They have pulverised position '+ inttostr(cattX)+' '+inttostr(cattY));
  if ships[cattX,cattY] <> 'O' then
    begin
      writeln('They have HIT us captain! We are already hearing reports of virtual casualties.');
      ViewingTime += 1000;
      misscheck := 0;
      compattacked[cattX, cattY] := 'H';
      if hitry = cattY then
        dirr := 'R';
      if hitrx = cattX then
        dirr := 'D';
      case ships[cattX, cattY] of
        'A':
          begin
            hitcount2 := 0;
            done2 := 0;
            repeat
              inc(hitcount2);
              if comphitships[1, hitcount2]= 0 then
                begin
                  comphitships[1, hitcount2]:= 1;
                  done2:= 1;
                  hitrx := cattX;
                  hitry := cattY;
                  inc(hitr);
               end;
             if comphitships[1, hitcount2 + 1]= -1 then
               begin
                 ViewingTime += 1000;
                 writeln('They SUNK our aircraft carrier!');
                 inc(compsunk);
                 done2:= 1;
                 hitrx := 0;
                 hitry := 0;
                 hitr := 0;
               end;
            until done2 = 1;
          end;
        'B':
          begin
            hitcount2 := 0;
            done2 := 0;
            repeat
              inc(hitcount2);
              if comphitships[2, hitcount2] = 0 then
                begin
                  comphitships[2, hitcount2] := 1;
                  done2 := 1;
                  hitrx := cattX;
                  hitry := cattY;
                  inc(hitr);
                end;
              if comphitships[2, hitcount2 + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('They SUNK Our Battleship!');
                  inc(compsunk);
                  done2 := 1;
                  hitrx := 0;
                  hitry := 0;
                  hitr := 0;
                end;
            until done2 = 1;
          end;
        'C':
          begin
            hitcount2 := 0;
            done2 := 0;
            repeat
              inc(hitcount2);
              if comphitships[3, hitcount2] = 0 then
                begin
                  comphitships[3, hitcount2] := 1;
                  done2 := 1;
                  hitrx := cattX;
                  hitry := cattY;
                  inc(hitr);
                end;
             if comphitships[3, hitcount2 + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('They SUNK Our Cruiser!');
                  inc(compsunk);
                  done2 := 1;
                  hitrx := 0;
                  hitry := 0;
                  hitr := 0;
                end;
            until done2 = 1;
          end;
        'S':
          begin
            hitcount2 := 0;
            done2 := 0;
            repeat
              inc(hitcount2);
              if comphitships[4, hitcount2] = 0 then
                begin
                  comphitships[4, hitcount2] := 1;
                  done2 := 1;
                  hitrx := cattX;
                  hitry := cattY;
                  inc(hitr);
               end;
              if comphitships[4, hitcount2 + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('They SUNK Our Submarine!');
                  inc(compsunk);
                  done2 := 1;
                  hitrx := 0;
                  hitry := 0;
                  hitr := 0;
                end;
            until done2 = 1;
          end;
        'D':
          begin
            hitcount2 := 0;
            done2 := 0;
            repeat
              inc(hitcount2);
              if comphitships[5, hitcount2] = 0 then
                begin
                  comphitships[5, hitcount2] := 1;
                  done2 := 1;
                  hitrx := cattX;
                  hitry := cattY;
                  inc(hitr);
                end;
              if comphitships[5, hitcount2 + 1] = -1 then
                begin
                  ViewingTime += 1000;
                  writeln('They SUNK Our Destroyer!');
                  inc(compsunk);
                  done2 := 1;
                  hitrx := 0;
                  hitry := 0;
                  hitr := 0;
                end;
            until done2 = 1;
          end;
      end;
   end
  else
    begin
      writeln('MISSED');
      ViewingTime += 1000;
      compattacked[cattX, cattY] := 'M';
      misscheck := 1;
    end;
  fired := true;
  if compsunk = 5 then
    main_entry := 20;
end;

procedure TCanvasProject.cominputships(spaces: integer; id: string);
begin
  valid2 := true;
  tempx := randomInt(12) + 1;
  tempy := randomInt(12) + 1;
  dfind := randomInt(4) + 1;
  case dfind of
    1 : direction2 := 'R';
    2 : direction2 := 'U';
    3 : direction2 := 'L';
    4 : direction2 := 'D';
  end;

  case direction2 of
    'R': if tempx + spaces - 1 > 12 then valid2 := false;
    'L': if tempx - spaces + 1 < 1 then valid2 := false;
    'U': if tempy - spaces + 1 < 1 then valid2 := false;
    'D': if tempy + spaces - 1 > 12 then valid2 := false;
  end;
  try
    for var Count64 := 1 to spaces do
      begin
       if direction2 = 'R' then
         if compships[tempx + count64, tempy] <> 'O' then
           valid2 := false;
       if direction2 = 'L' then
         if compships[tempx - count64, tempy] <> 'O' then
           valid2 := false;
       if direction2 = 'U' then
         if compships[tempx, tempy - count64] <> 'O' then
           valid2 := false;
       if direction2 = 'D' then
         if compships[tempx, tempy + count64] <> 'O' then
           valid2 := false;
      end;

    for var count88 := 0 to spaces - 1  do
      begin
        case direction2 of
          'U': if ((compships[tempx,(tempy-count88)+1] <> 'O') and(compships[tempx,(tempy-count88)+1] <> id))
                   or ((compships[tempx,(tempy-count88)-1] <> 'O') and (compships[tempx,(tempy-count88)-1] <> id))
                   or((compships[tempx-1,tempy-count88] <> 'O') and (compships[tempx-1,tempy-count88] <> id)) or
                   ((compships[tempx+1,tempy-count88] <> 'O') and (compships[tempx+1,tempy-count88] <> id))then
                 valid2 := false;

          'L': if ((compships[tempx-count88,tempy+1] <> 'O') and (compships[tempx-count88,tempy+1] <> id))
                   or ((compships[tempx-count88,tempy-1] <> 'O') and (compships[tempx-count88,tempy-1] <> id))
                   or ((compships[(tempx-1)-count88,tempy] <> 'O') and (compships[(tempx-1)-count88,tempy] <> id))
                   or ((compships[(tempx+1)-count88,tempy] <> 'O') and (compships[(tempx+1)-count88,tempy] <> id))then
                 valid2 := false;
          'R': if ((compships[tempx+count88,tempy+1] <> 'O') and (compships[tempx+count88,tempy+1] <> id))
                   or ((compships[tempx+count88,tempy-1] <> 'O')and(compships[tempx+count88,tempy-1] <> id))
                   or ((compships[(tempx+count88)-1,tempy] <> 'O') and (compships[(tempx+count88)-1,tempy] <> id))
                   or ((compships[(tempx+1)+count88,tempy] <> 'O') and (compships[(tempx+1)+count88,tempy] <> 'O')) then
                 valid2 := false;
          'D': if ((compships[tempx,(tempy+count88)+1] <> 'O') and (compships[tempx,(tempy+count88)+1] <> id))
                   or ((compships[tempx,(tempy+count88)-1] <> 'O') and (compships[tempx,(tempy+count88)-1] <> id))
                   or ((compships[tempx-1,tempy+count88] <> 'O') and (compships[tempx-1,tempy+count88] <> id))
                   or ((compships[tempx+1,tempy+count88] <> 'O') and (compships[tempx+1,tempy+count88] <> id)) then
                  valid2 := false;
        end;
      end;
  except
    valid2 := false;
  end;
  if valid2 then
    begin
      for var count64 := 1 to spaces do
        begin
          compships[tempx,tempy] := id;
          case direction2 of
           'R': inc(tempx);
           'L': dec(tempx);
           'U': dec(tempy);
           'D': inc(tempy);
          end;
        end;
      comp_success[spaces] := true;
    end;
end;

procedure TCanvasProject.Intro; //Sleeping removed
begin
  if FirstShowing then
    begin
      writeln('The computer - the immortal foe');
      writeln;
      writeln('Year after year you moaned, cried and fumed as your computer crashed.');
      writeln;
      writeln('Then one day, you said "NO MORE" and lead your virtual fleet into an epic');
      writeln('battle!');
      writeln;
      writeln('You will be assisted by your old friend Colonel Peter Umbridge.');
      writeln;
      writeln('"Good Afternoon Captain!"');
      writeln;
      writeln('"The grid err... I mean sea is 12 by 12."');
      writeln;
      writeln('"We can bomb any metre block with our surprisingly accurate V Bomb -');
      writeln('that''s V for Virtual"');
      writeln('"You will now position our glorious navy."');
      writeln;
      writeln('"Actually only 5 ships - lots of the men are *sick*"');
      writeln;
      writeln;
      writeln('Press Esc for menu');
    end;
  FirstShowing := False;
end;

procedure TCanvasProject.Main;
begin
  case main_entry of
    1: begin  //Sleep removed
         writeln('"Please submit coordinates in the following way..."');
         writeln;
         writeln('"HorizontalStartPoint VerticalSP ShipDirection - for example 4 7 R/L/D/U"');
         writeln;
         writeln('"Remember not to put ships side by side captain - they can only touch corner to corner"');
         writeln;
         printships;
         writeln('"Please input aircraft carrier captain, 5 spaces are needed"');
         inc(main_entry);
         TempReadString := '';
         reading_state := rsNotReading;
       end;
    2: if not success[5] then
         inputships(5, 'A')
       else
         inc(main_entry);
    3: begin
         invalidcount := 0;
         ClrScr;
         printships;
         writeln('"Please input battleship captain, 4 spaces needed"');
         inc(main_entry);
         reading_state := rsNotReading;
         FirstShow := true;
       end;
    4: if not success[4] then
         inputships(4, 'B')
       else
         inc(main_entry);
    5: begin
         invalidcount := 0;
         hitships[2, 5] := -1;
         comphitships[3, 6] := -1;
         comphitships[4, 6] := -1;
         comphitships[5, 6] := -1;
         comphitships[1, 6] := -1;
         comphitships[2, 6] := -1;
         comphitships[2, 5] := -1;
         comphitships[3, 5] := -1;
         comphitships[3, 4] := -1;
         comphitships[4, 4] := -1;
         comphitships[4, 5] := -1;
         comphitships[5, 5] := -1;
         comphitships[5, 4] := -1;
         comphitships[5, 3] := -1;
         ClrScr;
         printships;
         writeln('Please input cruiser captain, 3 spaces needed');
         inc(main_entry);
         reading_state := rsNotReading;
         FirstShow := true;
       end;
    6: if not success[3] then
         inputships(3, 'C')
       else
         inc(main_entry);
    7: begin
         invalidcount := 0;
         hitships[3, 4] := -1;
         hitships[3, 5] := -1;
         ClrScr;
         printships;
         writeln('Please input submarine captain, 3 spaces needed');
         inc(main_entry);
         reading_state := rsNotReading;
         FirstShow := true;
         success[3] := false;
       end;
    8: if not success[3] then
         inputships(3, 'S')
       else
         inc(main_entry);
    9: begin
         invalidcount := 0;
         hitships[4, 4] := -1;
         hitships[4, 5] := -1;
         ClrScr;
         printships;
         writeln('Please input destroyer captain, 2 spaces needed');
         inc(main_entry);
         reading_state := rsNotReading;
         FirstShow := true;
       end;
    10: if not success[2] then
          inputships(2, 'D')
        else
          inc(main_entry);
    11: begin
          invalidcount := 0;
          hitships[5, 3] := -1;
          hitships[5, 4] := -1;
          hitships[5, 5] := -1;
          hitships[1, 6] := -1;
          hitships[2, 6] := -1;
          hitships[3, 6] := -1;
          hitships[4, 6] := -1;
          hitships[5, 6] := -1;
          ClrScr;
          printships;
          inc(main_entry);
        end;
    12: if not comp_success[5] then
          cominputships(5, 'A')
        else
          inc(main_entry);
    13: if not comp_success[4] then
          cominputships(4, 'B')
        else
          inc(main_entry);
    14: if not comp_success[3] then
          cominputships(3, 'C')
        else
          begin
            inc(main_entry);
            comp_success[3]:= false;
          end;
    15: if not comp_success[3] then
          cominputships(3, 'S')
        else
          inc(main_entry);
    16: if not comp_success[2] then
          cominputships(2, 'D')
        else
          inc(main_entry);
    17: begin
          ClrScr;
          //printcompships;  // for testing
          printships;
          inc(main_entry);
          TempReadString := '';
          reading_state := rsNotReading;
          fired := false;
        end;
    18: if fired = false then
          humanturn
          else
             begin
               inc(main_entry);
               fired := false;
             end;
    19: if fired = false then
           compturn
          else
             begin
               dec(main_entry);
               ClrScr;
               fired := false;
               ViewingTime += 2500;
               {writeln('Here are the places where the computer has attacked');
               FirstShowing := true;
               printcompattacked;
               ShowMessage('Enter then click in display to continue');  }
             end;
    20: begin
          if sunk = 5 then
            begin
             ClrScr;
             writeln;
             ViewingTime += 4000;
             writeln('Your men fought the good fight');
             //sleep(1000);
             writeln;
             writeln('In the end you come out victorious');
             //sleep(1000);
             writeln;
             writeln('But with '+ inttoStr(compsunk)+' ships lost and countless wives widowed...');
             //sleep(1000);
             writeln;
             writeln('Who really won?');
             //sleep(3000);
             writeln;
             writeln('You did...');
           end;
          if compsunk = 5 then
            begin
              writeln('YOU LOSE - PREPARE FOR SEVERAL EONS CAPTIVITY IN THE MEMORY UNIT!');
              inc(main_entry); //21 does not exist so we stop here
            end;
        end;
  end;
  if ViewingTime > 0 then
    Sleep(ViewingTime);
  ViewingTime := 0;
end;

procedure TCanvasProject.ApplicationStarting;
begin
  inherited;
  Randomize;
  hitr := 0;
  misscheck := 0;
  for var count3 := 0 to 13 do
    begin
      for var count4 := 0 to 13 do
        begin
          ships[count3,count4] := 'O';
          compships[count3,count4] := 'O';
          attacked[count3,count4] := 'O';
          compattacked[count3,count4] := 'O';
        end;
    end;
  Grid := new TConsoleGrid;
  Grid.Rows := ROWS;
  Grid.Cols := COLS;
  GameView.Width:= WIDTH;
  GameView.Height := HEIGHT;
  asm
    window.onkeydown = function(e)
    {
    TCanvasProject.KeyDownEvent(Self, e.keyCode);
    }
  end;
  KeyDownEvent(0);
  GameView.Delay := DELAY;
  GameView.StartSession(False);
end;

procedure TCanvasProject.KeyDownEvent(mCode: integer);
begin
  if mCode = 27 then
    begin
      case input_state of
        isIntro: begin
                   choice := '';
                   reading_state := rsNotReading;
                   input_state := isMenu;
                   clrscr;
                   exit;
                 end;
        isMenu: ApplicationClosing;
      end;
    end;

  if reading_state = rsReading then
    if mCode = 13 then
      reading_state := rsFinishedReading
    else
      case mCode of
        39:                     TempReadString += ' ';
        32, 48 .. 57, 65 .. 90: TempReadString += chr(mCode);
        189, 109:               TempReadString += '-';
        190, 110:               TempReadString += '.';
        191, 111:               TempReadString += '/';
        187:                    TempReadString += '=';
        188:                    TempReadString += ',';
        37:                     TempReadString := LeftStr(TempReadString,
                                                          (length(TempReadString) - 1));
      end;
end;

procedure TCanvasProject.GoToXY(X, Y: integer);
begin
  Grid.CursorX := X;
  Grid.CursorY := Y;
end;

procedure TCanvasProject.ClrScr;
begin
  Grid.ClearGrid;
  GoToXY(1, 1);
end;

procedure TCanvasProject.ClrEOL;
begin
  grid.ClearEol(Grid.CursorX, Grid.CursorY);
end;

procedure TCanvasProject.textColor(colour: TConsoleColour);
begin
  Grid.TextColour := colour;
end;

procedure TCanvasProject.textBackground(colour: TConsoleColour);
begin
  Grid.BackgroundColour := colour;
end;

procedure TCanvasProject.write(txt: string);
begin
  Grid.write(txt);
end;

procedure TCanvasProject.writeln(txt : string);
begin
  Grid.write(txt);
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TCanvasProject.writeln;
begin
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TCanvasProject.readln(var InputString : string);
begin
  case reading_state of
    rsReading: begin
                 write(TempReadString + ' '); //Space in order to delete
                 Grid.CursorX := Grid.CursorX - length(TempReadString) - 1;
               end;
    rsNotReading: begin
                    reading_state := rsReading;
                    TempReadString := '';
                  end;
    rsFinishedReading: begin
                         InputString := TempReadString;
                         reading_state := rsNotReading;
                         writeln(TempReadString);
                       end;
  end;
end;

procedure TCanvasProject.readln;
begin
  case reading_state of
    rsNotReading: begin
                    reading_state := rsReading;
                    TempReadString := '';
                  end;
    rsFinishedReading: begin
                         reading_state := rsNotReading;
                       end;
  end;
end;
procedure TCanvasProject.ApplicationClosing;
begin
  GameView.EndSession;
  Grid.Destroy;
  inherited;
end;

procedure TCanvasProject.PaintView(Canvas: TW3Canvas);

  procedure PaintGrid;
  begin
    Canvas.Font :=  IntToStr(FONT_SIZE) +'px Lucida Console';
    var currentChar: TCharacter;
    for var x := 1 to COLS do
      for var y := 1 to ROWS do
        begin
          currentChar := Grid.getCharacters[x, y];
          SetTextColor(currentChar.TextBackGroundColour, Canvas);
          Canvas.FillRect((x - 1) * CELL_WIDTH, ((y - 1) * CELL_HEIGHT) + 2, CELL_WIDTH, CELL_HEIGHT);
          SetTextColor(currentChar.TextColour, Canvas);
          Canvas.FillText(currentChar.Letter, (x - 1) * CELL_WIDTH, y * CELL_HEIGHT);
        end;
  end;

begin
  case input_state of
    isMenu: begin
              writeln('Battleships by Lewis Wright');
              writeln;
              writeln('1 - Instructions');
              writeln('2 - Play');
              writeln('3 - Quit');
              writeln;
              writeln;
              writeln('You may use the right arrow to type a space in this web preview.');
              writeln;
              writeln('Use the left arrow to delete.');

              readln(choice);
              case TempReadString of
                '': begin
                      PaintGrid;
                      ClrScr;
                      exit;
                    end;
                '1': begin
                       input_state := isIntro;
                       FirstShowing := true;
                     end;
                '2': begin
                       input_state := isMain;
                       main_entry := 1;
                     end;
                '3': ApplicationClosing;
              end; //Case
              PaintGrid;
              clrscr;
       end; //isMenu
    isIntro: begin
               Intro;
               PaintGrid;
               if FirstShowing then
                 ClrScr;
             end;
    isMain: begin
              Main;
              PaintGrid;
            end;
  end;
end;

end.
UpGreen03.png
Programming - a skill for life!

by Lewis Wright: L6 Age ~16

dita powered logo dita powered™. Copyright © 2010-17 Pascal Programming for Schools. All rights reserved.