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
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.