Author Topic: Battleship with AI by bplus  (Read 721 times)

Offline Qwerkey

  • Moderator
  • Forum Resident
  • Posts: 736
Battleship with AI by bplus
« on: March 08, 2020, 06:32:03 AM »
Battleship with AI

Author:  @bplus with @johnno56 and @Petr
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=218.0, « Reply #14 on: May 28, 2018, 08:14:32 AM »
Version: 5_AI
Tags: [2D], [Graphics]

Description:
Cool QB64 version of the classic game.  Just like human players, my AI tracks whether it has shot at a cell or not.

Source Code:
Code: QB64: [Select]
  1. _TITLE "Battleship 5_AI.bas by bplus"
  2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
  3. 'OK this version with AI works though AI needs a fix
  4. '2018-04-25 fixed the AI! yeah
  5. '2018-04-25 PM Show ONLY ships sunk! Post 2018-04-25PM update
  6. '2018-04-26PM add play again loop  Post v 2018-04-26
  7. '  use Johnno's assets, Thanks Johnno
  8. '  water = _loadimag("filename")
  9. ' _PUTIMAGE (x, y), water
  10. ' Add Petr's idea from today about Player option for automatic setup,
  11. ' Thanks Petr for sharing ideas.
  12. 'add Johnno's sounds
  13. '2018-05-02 AM for me  Johnno adds explode stuff
  14. '2018-05-02 9PM Battleship3 fix surprise screen shake
  15. '2018-05-12&13 Battleship 4
  16. ' added checkClick for improved getClick routine
  17. ' option to turn off effects, center text in text box
  18. ' install new color system, and showShips on Players Board
  19. ' cut 20 lines from autoset, removed fill circle drawing routine
  20. '2018-05-14 post version 05-14
  21. ' testing new shoot systems for getting first hits on ships
  22. '2018-05-18 added new shoot subroutine that mods according to ships sunk
  23. '2018-05-20 the 5_AI 5-20 version is working with new hit directions around first hit
  24. 'I am now going to add hitx(), hity(), ihit, rehit for going back into sunk ship area for more ships if currentHits <> 0
  25. 'it works, keeps hitting an area until currentHits = 0 or all previous hits have been surrounded with misses
  26. 'show boats not sunk!!!!
  27. ' try mod 3 coverage effectsON and AutosetON  to avoid questions when play a ton of games
  28. 'reviewed sound handling and changed to using handles
  29. 'changed grid color to blue
  30. ' cut m = 7 stuff from shoot reduced from 128 lines to nice size now!
  31. ' 5-AI 5-21 backup
  32. ' 2018-05-23 post 5_AI with this date
  33. ' remove playing soundfiles by handle& and go back to _SNDPLAYFILE but use volume!!!
  34. ' add splash screen
  35.  
  36. DIM SHARED main&
  37. CONST xmax = 800
  38. CONST ymax = 600
  39. main& = _NEWIMAGE(xmax, ymax, 32)
  40. SCREEN main&
  41. _SCREENMOVE 360, 60
  42.  
  43. 'setup boards
  44. CONST sq = 32
  45. CONST sqPerSide = 10
  46. CONST n1 = sqPerSide - 1
  47. 'screen offsets for AI board and player board
  48. CONST ax = 50
  49. CONST ay = 232
  50. CONST px = 420
  51. CONST py = 232
  52. 'setup ships
  53. CONST nShips = 10
  54. CONST ns2 = 5 '     number of ships divide by 2
  55. CONST ns2p1 = 6 '   number of ships divide by 2 plus 1
  56. CONST df = 1 '      delay time
  57. 'global arrays and variables
  58. DIM SHARED a(sqPerSide, sqPerSide), p(sqPerSide, sqPerSide), water&, waterHit&, waterMiss&, GameOn, e, pAuto
  59. DIM SHARED shipName$(nShips), shipLen(nShips), shipHits$(nShips), shipHor(nShips), shipX(nShips), shipY(nShips), shipSunk(nShips)
  60. 'hits array will track red and white pegs of hits and misses
  61. REDIM SHARED hits(n1, n1) 'hit = 1 and miss = -1 and no shot taken = 0
  62. DIM SHARED colA, row, col, bump
  63. DIM SHARED ihit, rehit 'more hit tracking, this is for making sure all ships sunk in a hit area
  64. REDIM SHARED hitx(0), hity(0)
  65. DIM SHARED x1, y1, bombx, bomby, dir, currentHits, hit2 'for deciding where to bomb next
  66. DIM SHARED carrier&, battleship&, cruiser&, submarine&, destroyer& 'to use in subs
  67. DIM SHARED explode&(16)
  68.  
  69. 'Johnno's Assets added to game
  70. banner& = _LOADIMAGE("title.bmp")
  71. water& = _LOADIMAGE("water.bmp")
  72. waterHit& = _LOADIMAGE("water-hit.bmp")
  73. waterMiss& = _LOADIMAGE("water-miss.bmp")
  74. metal& = _LOADIMAGE("frame1.bmp")
  75. setupships& = _LOADIMAGE("setupships.bmp")
  76. notpeek& = _LOADIMAGE("notpeek.bmp")
  77. carrier& = _LOADIMAGE("carrier.bmp")
  78. battleship& = _LOADIMAGE("battleship.bmp")
  79. cruiser& = _LOADIMAGE("cruiser.bmp")
  80. submarine& = _LOADIMAGE("submarine.bmp")
  81. destroyer& = _LOADIMAGE("destroyer.bmp")
  82. again& = _LOADIMAGE("again.bmp")
  83. loadExplode
  84.  
  85. shipLen(1) = 5: shipName$(1) = "   Carrier"
  86. shipLen(2) = 4: shipName$(2) = "Battleship"
  87. shipLen(3) = 3: shipName$(3) = "   Cruiser"
  88. shipLen(4) = 3: shipName$(4) = " Submarine"
  89. shipLen(5) = 2: shipName$(5) = " Destroyer"
  90. shipLen(6) = 5: shipName$(6) = "   Carrier"
  91. shipLen(7) = 4: shipName$(7) = "Battleship"
  92. shipLen(8) = 3: shipName$(8) = "   Cruiser"
  93. shipLen(9) = 3: shipName$(9) = " Submarine"
  94. shipLen(10) = 2: shipName$(10) = " Destroyer"
  95.  
  96.  
  97. shipblack& = _LOADIMAGE("ship-black.png")
  98. shipfire& = _LOADIMAGE("ship-wfire.png")
  99. xxmax = 640: yymax = 75 'pixels too slow
  100. xstep = 1: ystep = 1
  101. DIM pal&(300) 'pallette
  102. FOR i = 1 TO 100
  103.     fr = 240 * i / 100 + 15
  104.     pal&(i) = _RGB(fr, 0, 0)
  105.     pal&(i + 100) = _RGB(255, fr, 0)
  106.     pal&(i + 200) = _RGB(255, 255, fr)
  107. DIM f(xxmax, yymax + 2) 'fire array and seed
  108. FOR x = 0 TO xxmax
  109.     f(x, yymax + 1) = INT(RND * 2) * 300
  110.     f(x, yymax + 2) = 300
  111.  
  112. _PUTIMAGE , shipblack&
  113. getClick mx, my, q
  114. IF q = 27 THEN END
  115. ticker = 0
  116. WHILE ticker < 3
  117.     CLS
  118.     IF ticker < 2.95 THEN _PUTIMAGE , shipblack& ELSE _PUTIMAGE , shipfire&
  119.     FOR x = 1 TO xxmax - 1 'shift fire seed a bit
  120.         r = RND
  121.         IF r < .15 THEN
  122.             f(x, yymax + 1) = f(x - 1, yymax + 1)
  123.         ELSEIF r < .3 THEN
  124.             f(x, yymax + 1) = f(x + 1, yymax + 1)
  125.         ELSEIF r < .35 THEN
  126.             f(x, yymax + 1) = INT(RND * 2) * 300
  127.         END IF
  128.     NEXT
  129.     FOR y = 0 TO yymax 'fire based literally on 4 pixels below it like cellular automata
  130.         FOR x = 1 TO xxmax - 1
  131.             f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
  132.             LINE (80 + x * xstep, 230 + y * ystep)-STEP(xstep, ystep), pal&(f(x, y)), BF
  133.         NEXT
  134.     NEXT
  135.     ticker = ticker + .025
  136.     _DISPLAY
  137.     _LIMIT 50
  138. _DELAY 1.5
  139. rgb 0
  140. LINE (0, 0)-(xmax, ymax), , BF
  141.  
  142. '   Display banner   and get the Players setting questions asked once and for all games until restart program
  143. _PUTIMAGE (220, 10), banner&
  144. TxtBx 509, "m", "Special Effects? press [y] yes or [n] no"
  145. IF GetYN$ = "y" THEN e = -1 ELSE e = 0
  146. ClearTextBox
  147. _PUTIMAGE (150, 155), setupships&
  148. IF GetYN$ = "y" THEN pAuto = -1 ELSE pAuto = 0
  149.  
  150.  
  151. restart: '===================================================== restart new game
  152.  
  153. 'reset all critical variables and arrays
  154. ERASE a, p, shipHor, shipX, shipY, shipSunk
  155. REDIM hits(n1, n1)
  156. FOR i = 1 TO nShips
  157.     shipHits$(i) = SPACE$(shipLen(i))
  158. 'AI tracking
  159. pTurn = 0: dir = 0: currentHits = 0: colA = -1
  160. 'start screen drawing
  161.  
  162. '   Display Grid frame
  163. _PUTIMAGE (18, 200), metal&
  164. rgb 9
  165. drawGrid ax, ay, sq, sqPerSide
  166. drawGrid px, py, sq, sqPerSide
  167. FOR bannerx = 220 TO 15 STEP -1
  168.     _PUTIMAGE (bannerx, 10), banner&
  169.     _DELAY 0.01
  170.  
  171. 'setup a board with ships, Computer or AI's setup
  172. autoset 1
  173.  
  174. 'setup player's ships
  175. IF pAuto THEN
  176.     ClearTextBox
  177.     _PUTIMAGE (277, 155), notpeek&
  178.     autoset 0
  179.     FOR s = ns2p1 TO nShips
  180.         showShip s, shipX(s), shipY(s), shipHor(s)
  181.     NEXT
  182.  
  183. ELSE 'player sets up his ships
  184.     FOR s = ns2p1 TO nShips
  185.         OK = 0
  186.         WHILE OK = 0
  187.             ClearTextBox
  188.             ClearUpdateBox
  189.             IF s = 1 OR s = 6 THEN _PUTIMAGE (480, 30), carrier&
  190.             IF s = 2 OR s = 7 THEN _PUTIMAGE (474, 45), battleship&
  191.             IF s = 3 OR s = 8 THEN _PUTIMAGE (496, 50), cruiser&
  192.             IF s = 4 OR s = 9 THEN _PUTIMAGE (496, 45), submarine&
  193.             IF s = 5 OR s = 10 THEN _PUTIMAGE (512, 50), destroyer&
  194.             rgb 990
  195.             '   Position text in UpdateTextBox beneath the ship.
  196.             _PRINTSTRING (430, 100), "Setting up the " + LTRIM$(shipName$(s)) + ":  Length of" + STR$(shipLen(s)) + "."
  197.             TxtBx 85, "t", "Position it Horizontally: Press [ H ]"
  198.             TxtBx 942, "b", "  Position it Vertically: Press [ V ]"
  199.             nogo = 1
  200.             WHILE nogo
  201.                 hor$ = INKEY$
  202.                 IF hor$ = "v" OR hor$ = "h" THEN nogo = 0
  203.                 _LIMIT 200
  204.             WEND
  205.             ClearTextBox
  206.             IF hor$ = "v" THEN
  207.                 TxtBx 942, "t", "Vertial it is."
  208.                 TxtBx 970, "b", "Now click the top most position of the ship."
  209.                 shipHor(s) = 0
  210.             ELSE
  211.                 TxtBx 85, "t", "Horizontal it is:"
  212.                 TxtBx 970, "b", "Now click the left most position of the ship."
  213.                 shipHor(s) = -1
  214.             END IF
  215.  
  216.             checkClick px, py, sq, sqPerSide, sx, sy, escape
  217.             IF escape THEN CLS: END
  218.  
  219.             IF shipHor(s) THEN
  220.                 IF sx <= sqPerSide - shipLen(s) THEN
  221.                     OK = 1
  222.                     FOR xx = 0 TO shipLen(s) - 1
  223.                         IF p(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
  224.                     NEXT
  225.                     IF OK THEN
  226.                         shipX(s) = sx: shipY(s) = sy
  227.                         FOR xx = 0 TO shipLen(s) - 1
  228.                             p(sx + xx, sy) = -1 * s
  229.                         NEXT
  230.                     END IF
  231.                 END IF
  232.             ELSE
  233.                 IF sy <= sqPerSide - shipLen(s) THEN
  234.                     OK = 1
  235.                     FOR yy = 0 TO shipLen(s) - 1
  236.                         IF p(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
  237.                     NEXT
  238.                     IF OK THEN
  239.                         shipX(s) = sx: shipY(s) = sy
  240.                         FOR yy = 0 TO shipLen(s) - 1
  241.                             p(sx, sy + yy) = -1 * s
  242.                         NEXT
  243.                     END IF
  244.                 END IF
  245.             END IF
  246.         WEND
  247.         'update player board
  248.         showShip s, shipX(s), shipY(s), shipHor(s)
  249.         _LIMIT 30
  250.     NEXT
  251.  
  252.  
  253. 'start the shooting match
  254. GameOn = 1
  255. WHILE GameOn
  256.     updateStatus
  257.     pTurn = 1 - pTurn
  258.  
  259.     IF pTurn THEN
  260.         TxtBx 63, "m", "Player. Your turn.  Click on the computer's board."
  261.         checkClick ax, ay, sq, sqPerSide, bx, by, escape
  262.         IF escape THEN CLS: END
  263.         IF e THEN
  264.             _SNDPLAYFILE ("launch-hi.wav"), , 1
  265.             _DELAY 3
  266.         END IF
  267.         IF a(bx, by) < 0 THEN
  268.             IF e THEN
  269.                 playPutExplode ax + bx * sq, ay + by * sq, 0
  270.                 '_DELAY df
  271.             END IF
  272.             _PUTIMAGE (ax + bx * sq, ay + by * sq), waterHit&
  273.             hitEval "a", bx, by 'game could end here
  274.         ELSE
  275.             _PUTIMAGE (ax + bx * sq, ay + by * sq), waterMiss&
  276.             IF e THEN
  277.                 _SNDPLAYFILE ("splash-hi.wav"), , .3
  278.                 _DELAY 1
  279.             END IF
  280.         END IF
  281.     ELSE
  282.         'AI's turn if it gets a hit it will bomb around the ship until it is finished
  283.         'could be trouble if 2 ships are next to each other, damn until just now I hadn't anticipated this
  284.         'hits board tracks red and white pegs like a human player for AI
  285.  
  286.         '   Try to display random computer messages before it fires! - Humour...
  287.         '   Possibly use select.. case.. end select?
  288.         ClearTextBox
  289.         choice = rand(1, 10)
  290.         SELECT CASE choice
  291.             CASE 1: m$ = "Hold onto something! My turn!"
  292.             CASE 2: m$ = "Are you sure you want to do this?"
  293.             CASE 3: m$ = "Close your eyes and start praying!"
  294.             CASE 4: m$ = "Are you ready for what's coming?"
  295.             CASE 5: m$ = "My turn! Buckle up Princess!"
  296.             CASE 6: m$ = "Prepare for a world of hurt!"
  297.             CASE 7: m$ = "Airmail... Special delivery!"
  298.             CASE 8: m$ = "You have nowhere to hide!"
  299.             CASE 9: m$ = "I have a surprise for you!"
  300.             CASE 10: m$ = "Let's play catch! My turn!"
  301.         END SELECT
  302.         TxtBx 970, "m", m$
  303.  
  304.         IF dir THEN 'we have a bomb location all set to test
  305.             IF p(bombx, bomby) < 0 THEN 'hit!
  306.                 IF e THEN
  307.                     _SNDPLAYFILE ("launch-hi.wav"), , .3
  308.                     _DELAY 3
  309.                     playPutExplode px + bombx * sq, py + bomby * sq, 1
  310.  
  311.                     ClearTextBox
  312.                     choice = rand(1, 10)
  313.                     SELECT CASE choice
  314.                         CASE 1: m$ = "No point crying about it!"
  315.                         CASE 2: m$ = "You'll get over it."
  316.                         CASE 3: m$ = "It's either you or me."
  317.                         CASE 4: m$ = "No pain. No gain."
  318.                         CASE 5: m$ = "Now that's gotta hurt!"
  319.                         CASE 6: m$ = "You can always go home!"
  320.                         CASE 7: m$ = "No shame in quitting."
  321.                         CASE 8: m$ = "It'll buff right out."
  322.                         CASE 9: m$ = "Side dish of scrap to go!"
  323.                         CASE 10: m$ = "May you rust in peace."
  324.                     END SELECT
  325.                     TxtBx 930, "m", m$
  326.                 END IF
  327.  
  328.                 hit2 = 1
  329.                 hits(bombx, bomby) = 1
  330.                 currentHits = currentHits + 1
  331.                 ihit = ihit + 1 'take a history  of hits since dir has been activated
  332.                 REDIM _PRESERVE hitx(ihit)
  333.                 REDIM _PRESERVE hity(ihit)
  334.                 hitx(ihit) = bombx
  335.                 hity(ihit) = bomby
  336.  
  337.                 _PUTIMAGE (px + bombx * sq, py + bomby * sq), waterHit&
  338.  
  339.                 'we need to know stuff but can't use this info for AI finding the ship
  340.                 'when hitEval announces a ship sunk we can reduce the currentHits count by that ships amount
  341.                 'if still have more current hits, continue bombing area as another ship is there
  342.                 hitEval "p", bombx, bomby 'this will reduce currentHits by the amount a ship could take when sunk
  343.                 IF currentHits = 0 THEN 'clear our checklist we sank all ships we hit, call off bombing of area
  344.                     x1 = 0: y1 = 0: dir = 0
  345.                 ELSE
  346.                     decideWhereToBombNext
  347.                 END IF
  348.             ELSE 'no hit from checklist scratch off one item
  349.                 IF e THEN
  350.                     _SNDPLAYFILE ("launch-hi.wav"), , .3
  351.                     _DELAY 3
  352.                 END IF
  353.                 hit2 = 0
  354.                 hits(bombx, bomby) = -1
  355.                 _PUTIMAGE (px + bombx * sq, py + bomby * sq), waterMiss&
  356.                 ClearTextBox
  357.                 TxtBx 509, "m", "MISSED!!"
  358.                 IF e THEN
  359.                     _SNDPLAYFILE ("splash-hi.wav"), , 1
  360.                     _DELAY 1
  361.                 END IF
  362.                 decideWhereToBombNext
  363.             END IF ' are we still working on hit
  364.  
  365.         ELSE
  366.             'not working on any hits x1, y1 = 0, dir = 0, currentHits might be = 0
  367.             'random but systematic shooting, bring up next good shooting location
  368.  
  369.             shoot tryx, tryy
  370.  
  371.             'consider that shot just fired was it a hit or miss
  372.             IF p(tryx, tryy) < 0 THEN ' test our shot just fired is hit!
  373.                 IF e THEN
  374.                     _SNDPLAYFILE ("launch-hi.wav"), , .3
  375.                     _DELAY 3
  376.                 END IF
  377.                 ClearTextBox
  378.                 x1 = tryx: y1 = tryy 'save first hit to come back to
  379.                 hits(x1, y1) = 1
  380.                 currentHits = currentHits + 1
  381.                 IF e THEN
  382.                     playPutExplode px + x1 * sq, py + y1 * sq, 1
  383.                 END IF
  384.                 _PUTIMAGE (px + x1 * sq, py + y1 * sq), waterHit&
  385.  
  386.                 'we need to know stuff but can't use this info for AI finding the ship
  387.                 'it's the same as for the player
  388.                 hitEval "p", x1, y1
  389.                 'did we just happen to finish off a ship?  current hits = 0
  390.                 IF currentHits = 0 THEN 'must of finished off an ship
  391.                     x1 = 0: x2 = 0: dir = 0 'we are done
  392.                 ELSE
  393.                     dir = -1
  394.                     decideWhereToBombNext
  395.                 END IF
  396.             ELSE 'no hit
  397.                 IF e THEN
  398.                     _SNDPLAYFILE ("launch-hi.wav"), , .3
  399.                     _DELAY 3
  400.                 END IF
  401.                 _PUTIMAGE (px + tryx * sq, py + tryy * sq), waterMiss&
  402.                 ClearTextBox
  403.                 TxtBx 509, "m", "MISSED!!"
  404.                 IF e THEN
  405.                     _SNDPLAYFILE ("splash-hi.wav"), , 1
  406.                     _DELAY 1
  407.                 END IF
  408.                 hits(tryx, tryy) = -1
  409.             END IF
  410.  
  411.         END IF 'rI (now tryx, tryy) was hit or not
  412.     END IF 'whose turn is it
  413.     _LIMIT 5
  414. _PUTIMAGE (125, 265), again&
  415. IF GetYN$ = "n" THEN CLS: END
  416. GOTO restart
  417.  
  418. SUB updateStatus
  419.     ClearTextBox
  420.     ClearUpdateBox
  421.     rgb 990
  422.     LOCATE 2, 70: PRINT "Computer"
  423.     rgb 63
  424.     LOCATE 2, 83: PRINT "Player"
  425.     FOR i = 1 TO 5
  426.         rgb 85: LOCATE i + 2, 55: PRINT shipName$(i)
  427.         IF shipSunk(i) THEN LOCATE i + 2, 72: rgb 940: PRINT "SUNK": rgb 999
  428.         IF shipSunk(i + ns2) THEN LOCATE i + 2, 84: rgb 940: PRINT "SUNK": rgb 999
  429.     NEXT
  430.  
  431. SUB decideWhereToBombNext
  432.     'find next good location, mark the direction we took
  433.     IF dir = -1 THEN '    we just got a fresh hit the rest of the ship is in 1 of 4 directions
  434.         'fresh slate
  435.         REDIM hitx(0): REDIM hity(0): ihit = 0: rehit = 0
  436.         redirect:
  437.         hit2 = 0 'when direction = 0 reset 2nd hit signal to 0
  438.         IF x1 + 1 <= n1 THEN
  439.             IF hits(x1 + 1, y1) = 0 THEN
  440.                 bombx = x1 + 1: bomby = y1: dir = 1: EXIT SUB 'always the first direction to try
  441.             END IF
  442.         END IF
  443.         'still here?
  444.         IF x1 - 1 >= 0 THEN
  445.             IF hits(x1 - 1, y1) = 0 THEN
  446.                 bombx = x1 - 1: bomby = y1: dir = 3: EXIT SUB
  447.             END IF
  448.         END IF
  449.         'still here?
  450.         IF y1 + 1 <= n1 THEN
  451.             IF hits(x1, y1 + 1) = 0 THEN
  452.                 bombx = x1: bomby = y1 + 1: dir = 2: EXIT SUB
  453.             END IF
  454.         END IF
  455.         'still here OK this has to do it!
  456.         IF y1 - 1 >= 0 THEN
  457.             IF hits(x1, y1 - 1) = 0 THEN
  458.                 bombx = x1: bomby = y1 - 1: dir = 4: EXIT SUB
  459.             END IF
  460.         END IF
  461.         'still here ???? damn! give up and go back to random shots
  462.         rehit = rehit + 1
  463.         IF rehit > ihit THEN
  464.             dir = 0: EXIT SUB 'back to random bombing
  465.         ELSE
  466.             x1 = hitx(rehit): y1 = hity(rehit)
  467.             GOTO redirect
  468.         END IF
  469.  
  470.         dir = 0: EXIT SUB '   <    this signals that
  471.     END IF
  472.  
  473.     'setup next bombx, bomby
  474.     IF hit2 THEN 'whatever direction we are taking, continue if we can
  475.         SELECT CASE dir
  476.             CASE 1
  477.                 IF bombx + 1 <= n1 THEN
  478.                     IF hits(bombx + 1, bomby) = 0 THEN
  479.                         bombx = bombx + 1: EXIT SUB
  480.                     END IF
  481.                 END IF
  482.             CASE 2
  483.                 IF bomby + 1 <= n1 THEN
  484.                     IF hits(bombx, bomby + 1) = 0 THEN
  485.                         bomby = bomby + 1: EXIT SUB
  486.                     END IF
  487.                 END IF
  488.             CASE 3
  489.                 IF bombx - 1 >= 0 THEN
  490.                     IF hits(bombx - 1, bomby) = 0 THEN
  491.                         bombx = bombx - 1: EXIT SUB
  492.                     END IF
  493.                 END IF
  494.             CASE 4
  495.                 IF bomby - 1 >= 0 THEN
  496.                     IF hits(bombx, bomby - 1) = 0 THEN
  497.                         bomby = bomby - 1: dir = 4: EXIT SUB
  498.                     END IF
  499.                 END IF
  500.         END SELECT
  501.     END IF
  502.  
  503.     'still here? then we have to change direction  and go back to x1, y1 the first hit
  504.     hit2 = 0 'reset this for the new direction check
  505.     WHILE dir < 4 AND dir > 0
  506.  
  507.         'dir = dir + 1   want to try 180 direction before changing 90
  508.  
  509.         IF dir = 1 THEN
  510.             dir = 3
  511.         ELSEIF dir = 2 THEN
  512.             dir = 4
  513.         ELSEIF dir = 3 THEN
  514.             dir = 2
  515.         ELSEIF dir = 4 THEN
  516.             rehit = rehit + 1
  517.             IF rehit > ihit THEN
  518.                 dir = 0: EXIT SUB 'back to random bombing
  519.             ELSE
  520.                 x1 = hitx(rehit): y1 = hity(rehit)
  521.                 GOTO redirect
  522.             END IF
  523.         END IF
  524.         SELECT CASE dir
  525.             CASE 2
  526.                 IF y1 + 1 <= n1 THEN
  527.                     IF hits(x1, y1 + 1) = 0 THEN
  528.                         bombx = x1: bomby = y1 + 1: EXIT SUB
  529.                     END IF
  530.                 END IF
  531.             CASE 3
  532.                 IF x1 - 1 >= 0 THEN
  533.                     IF hits(x1 - 1, y1) = 0 THEN
  534.                         bombx = x1 - 1: bomby = y1: EXIT SUB
  535.                     END IF
  536.                 END IF
  537.             CASE 4
  538.                 IF y1 - 1 >= 0 THEN
  539.                     IF hits(x1, y1 - 1) = 0 THEN
  540.                         bombx = x1: bomby = y1 - 1: EXIT SUB
  541.                     END IF
  542.                 END IF
  543.         END SELECT
  544.     WEND
  545.     'still here, well we've run out of directions
  546.     rehit = rehit + 1
  547.     IF rehit > ihit THEN
  548.         dir = 0: EXIT SUB 'back to random bombing
  549.     ELSE
  550.         x1 = hitx(rehit): y1 = hity(rehit)
  551.         GOTO redirect
  552.     END IF
  553.  
  554.     'dir = 0 'back to random bombing
  555.  
  556. SUB hitEval (board$, bbx, bby)
  557.     'this is like a referee / judge for both players  to announce a ship sunk and a game won?
  558.     IF board$ <> "p" THEN
  559.         s = -1 * a(bbx, bby)
  560.         you$ = "Player"
  561.         my$ = "Computer's"
  562.         istart = 1
  563.         istop = ns2
  564.     ELSE
  565.         s = -1 * p(bbx, bby)
  566.         you$ = "Computer"
  567.         my$ = "Player's"
  568.         istart = ns2p1
  569.         istop = nShips
  570.     END IF
  571.     IF shipHor(s) THEN d = bbx - shipX(s) + 1 ELSE d = bby - shipY(s) + 1
  572.     MID$(shipHits$(s), d) = "X"
  573.     IF shipHits$(s) = STRING$(shipLen(s), "X") THEN
  574.         IF board$ = "p" THEN currentHits = currentHits - shipLen(s)
  575.         updateStatus
  576.         TxtBx 995, "m", you$ + " sank the " + my$ + " " + LTRIM$(shipName$(s)) + "!"
  577.         _DELAY 1
  578.         shipSunk(s) = 1
  579.         tot = 0
  580.         FOR i = istart TO istop
  581.             IF shipSunk(i) = 1 THEN tot = tot + 1
  582.         NEXT
  583.         IF tot = ns2 THEN
  584.             updateStatus
  585.             TxtBx 995, "m", "Congratulations " + you$ + "!!  You sank the " + my$ + " fleet!  GameOver..."
  586.             IF you$ = "Computer" THEN
  587.                 FOR y = 0 TO sqPerSide - 1
  588.                     FOR x = 0 TO sqPerSide - 1
  589.                         IF a(x, y) < 0 THEN
  590.                             rgb 900
  591.                             FOR i = 1 TO 5 'show ships locations for Player that lost
  592.                                 IF i MOD 2 THEN rgb 900 ELSE rgb 999
  593.                                 LINE (ax + x * sq + i, ay + y * sq + i)-STEP(sq - 2 * i, sq - 2 * i), , B
  594.                             NEXT
  595.                         END IF
  596.                     NEXT
  597.                 NEXT
  598.                 _DELAY 5
  599.             END IF
  600.             _DELAY 4
  601.             GameOn = 0
  602.         END IF
  603.     END IF
  604.  
  605. SUB autoset (AItf) '  there is surely a shorter way to do this but I am eager to get on with other stuff
  606.     'setup a board with ships, AItf if true setup for Computer else for Player
  607.     FOR i = 1 TO ns2
  608.         IF AItf THEN s = i ELSE s = i + 5
  609.         OK = 0
  610.         WHILE OK = 0
  611.             shipHor(s) = rand(0, 1)
  612.             IF shipHor(s) THEN
  613.                 sy = rand(0, n1)
  614.                 sx = rand(0, sqPerSide - shipLen(s))
  615.                 OK = 1
  616.                 FOR xx = 0 TO shipLen(s) - 1
  617.                     IF AItf THEN
  618.                         IF a(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
  619.                     ELSE
  620.                         IF p(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
  621.                     END IF
  622.                 NEXT
  623.                 IF OK THEN
  624.                     shipX(s) = sx: shipY(s) = sy
  625.                     FOR xx = 0 TO shipLen(s) - 1
  626.                         IF AItf THEN
  627.                             a(sx + xx, sy) = -1 * s
  628.                         ELSE
  629.                             p(sx + xx, sy) = -1 * s
  630.                         END IF
  631.                     NEXT
  632.                 END IF
  633.             ELSE
  634.                 sx = rand(0, n1)
  635.                 sy = rand(0, sqPerSide - shipLen(s))
  636.                 OK = 1
  637.                 FOR yy = 0 TO shipLen(s) - 1
  638.                     IF AItf THEN
  639.                         IF a(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
  640.                     ELSE
  641.                         IF p(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
  642.                     END IF
  643.                 NEXT
  644.                 IF OK THEN
  645.                     shipX(s) = sx: shipY(s) = sy
  646.                     FOR yy = 0 TO shipLen(s) - 1
  647.                         IF AItf THEN
  648.                             a(sx, sy + yy) = -1 * s
  649.                         ELSE
  650.                             p(sx, sy + yy) = -1 * s
  651.                         END IF
  652.                     NEXT
  653.                 END IF
  654.             END IF
  655.         WEND
  656.     NEXT
  657.  
  658. SUB showShip (shipn, bxhead, byhead, hTF)
  659.     'setup to combine use with RotoZoom code Wiki
  660.     SELECT CASE shipn 'player's ships only, get ship len and
  661.         CASE 6: shipLen = 5: sh& = carrier&
  662.         CASE 7: shipLen = 4: sh& = battleship&
  663.         CASE 8: shipLen = 3: sh& = cruiser&
  664.         CASE 9: shipLen = 3: sh& = submarine&
  665.         CASE 10: shipLen = 2: sh& = destroyer&
  666.     END SELECT
  667.     IF hTF THEN 'horizontal True
  668.         dx1 = px + sq * bxhead + 1
  669.         dy1 = py + sq * byhead + 1
  670.         dx2 = px + sq * (bxhead + shipLen) - 1
  671.         dy2 = py + sq * (byhead + 1) - 1
  672.         _PUTIMAGE (dx1, dy1)-(dx2, dy2), sh&, main&
  673.     ELSE
  674.         DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
  675.         W& = _WIDTH(sh&): H& = _HEIGHT(sh&)
  676.         px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
  677.         px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
  678.         sinr! = SIN(-90 / 57.2957795131): cosr! = COS(-90 / 57.2957795131)
  679.  
  680.         xsqlen = 30: ysqlen = 32 * shipLen - 2
  681.         xscale = xsqlen / H&: yscale = ysqlen / W&
  682.         xpivot = px + sq * bxhead + .5 * sq: ypivot = py + sq * byhead + .5 * sq * shipLen
  683.         FOR i& = 0 TO 3
  684.             x2& = (px(i&) * cosr! + sinr! * py(i&)) * xscale + xpivot: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yscale + ypivot
  685.             px(i&) = x2&: py(i&) = y2&
  686.         NEXT
  687.         _MAPTRIANGLE (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), sh& TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
  688.         _MAPTRIANGLE (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), sh& TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
  689.     END IF
  690.  
  691. 'want the board square bx, by from board with grid xoff, yoff, sq pixels, n x n square board
  692. SUB checkClick (xoff, yoff, sq, n, bx, by, escape)
  693.     WHILE 1
  694.         getClick mx, my, q ' get players move
  695.         IF q = 27 OR q = 113 OR q = 81 THEN escape = 1: EXIT SUB
  696.         row = (my - yoff) / sq
  697.         IF row > 0 AND row < n THEN
  698.             by = INT(row)
  699.             col = (mx - xoff) / sq
  700.             IF col > 0 AND col < n THEN
  701.                 bx = INT(col)
  702.                 EXIT WHILE
  703.             ELSE 'this is beeping right after setup (not after a click)
  704.                 IF mx <> -1 AND my <> -1 THEN BEEP
  705.             END IF
  706.         ELSE 'this is beeping right after setup (not after a click)
  707.             IF mx <> -1 AND my <> -1 THEN BEEP
  708.         END IF
  709.         _LIMIT 1000
  710.     WEND
  711.  
  712. SUB getClick (mx, my, q)
  713.     WHILE _MOUSEINPUT: WEND ' clear previous mouse activity
  714.     mx = -1: my = -1: q = 0
  715.     DO WHILE mx = -1 AND my = -1
  716.         q = _KEYHIT
  717.         IF q = 27 OR (q > 31 AND q < 126) THEN EXIT SUB
  718.         i = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
  719.         IF mb THEN
  720.             DO WHILE mb 'wait for release
  721.                 q = _KEYHIT
  722.                 IF q = 27 OR (q > 31 AND q < 126) THEN EXIT SUB
  723.                 i = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
  724.                 _LIMIT 1000
  725.             LOOP
  726.             EXIT SUB
  727.         END IF
  728.         _LIMIT 1000
  729.     LOOP
  730.  
  731. SUB drawGrid (x, y, sq, n)
  732.     d = sq * n
  733.     FOR i = 0 TO n
  734.         LINE (x + sq * i, y)-(x + sq * i, y + d)
  735.         LINE (x, y + sq * i)-(x + d, y + sq * i)
  736.     NEXT
  737.     FOR yy = 0 TO n - 1
  738.         FOR xx = 0 TO n - 1
  739.             _PUTIMAGE (x + sq * xx, y + sq * yy), water&
  740.         NEXT
  741.     NEXT
  742.  
  743. FUNCTION rand% (lo%, hi%)
  744.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
  745.  
  746. SUB TxtBx (n, L$, Message$)
  747.     rgb n
  748.     IF L$ = "t" THEN y = 150
  749.     IF L$ = "m" THEN y = 160
  750.     IF L$ = "b" THEN y = 170
  751.     x = (769 - LEN(Message$) * 8) / 2 + 18
  752.     _PRINTSTRING (x, y), Message$
  753.  
  754. SUB ClearTextBox
  755.     rgb 0
  756.     LINE (18, 141)-(769, 194), , BF
  757.  
  758. SUB ClearUpdateBox
  759.     rgb 0
  760.     LINE (380, 11)-(769, 129), , BF
  761.  
  762. SUB loadExplode ()
  763.     FOR i = 1 TO 16
  764.         x$ = RIGHT$("0" + LTRIM$(STR$(i)), 2)
  765.         f$ = "exp_" + x$ + ".bmp"
  766.         explode&(i) = _LOADIMAGE(f$)
  767.         ' _PUTIMAGE (i * 32, i * 32), explode&(i)   '< test load of file
  768.     NEXT
  769.  
  770. SUB playPutExplode (x, y, shake)
  771.     IF shake THEN _SNDPLAYFILE ("explosion-hi.wav"), , 1 ELSE _SNDPLAYFILE ("explosion-hi.wav"), , .3
  772.     FOR i = 1 TO 16
  773.         _PUTIMAGE (x + 1, y + 1), explode&(i)
  774.         _DELAY .05
  775.         IF shake THEN
  776.             _SCREENMOVE 360 + rand(-10, 10), 60 + rand(-10, 10)
  777.             _SCREENMOVE 360 + rand(-10, 10), 60 + rand(-10, 10)
  778.         END IF
  779.     NEXT
  780.     IF shake THEN _SCREENMOVE 360, 60
  781.     _DELAY .1
  782.  
  783. SUB rgb (n) ' New (even less typing!) New Color System 1000 colors with up to 3 digits
  784.     s3$ = RIGHT$("000" + LTRIM$(STR$(n)), 3)
  785.     r = VAL(MID$(s3$, 1, 1)): IF r THEN r = 28 * r + 3
  786.     g = VAL(MID$(s3$, 2, 1)): IF g THEN g = 28 * g + 3
  787.     b = VAL(MID$(s3$, 3, 1)): IF b THEN b = 28 * b + 3
  788.     COLOR _RGB32(r, g, b)
  789.  
  790. FUNCTION GetYN$ ()
  791.     k$ = "": WHILE k$ <> "n" AND k$ <> "y": k$ = INKEY$: _LIMIT 200: WEND
  792.     GetYN$ = k$
  793.  
  794. SUB shoot (col, row) 'col, row aren't inputs so mush as outputs like a double function return wo input parameters
  795.     i = nShips
  796.     WHILE shipSunk(i) 'find smallest ship not sunk
  797.         i = i - 1
  798.     WEND
  799.     SELECT CASE i 'm for modulus, d for direction to run a check from
  800.         CASE nShips: m = 3 'still have destroyer, for more exciting game testng m = 3
  801.         CASE nShips - 1: m = 3 'still have sub
  802.         CASE nShips - 2: m = 3 'still have cruiser
  803.         CASE nShips - 3: m = 4 'still have battleship
  804.         CASE nShips - 4: m = 5 'still have carrier
  805.     END SELECT
  806.     bc = 0
  807.     IF colA = -1 THEN 'col the Attact starts from notice it is random so player can't anticipate
  808.         colA = rand%(0, n1): col = colA: row = rand(0, n1): bump = rand(0, m - 1)
  809.     END IF
  810.     WHILE bc < m
  811.         cc = 1
  812.         WHILE cc <= sqPerSide
  813.             rc = 0
  814.             WHILE rc <= sqPerSide 'find a space to hit if one left in this column
  815.                 IF cover(m, bump, col, row) THEN 'are we on a place to cover board
  816.                     IF hits(col, row) = 0 THEN EXIT SUB 'good to go!
  817.                 END IF
  818.                 row = (row + 1) MOD sqPerSide
  819.                 rc = rc + 1
  820.             WEND
  821.             row = row - 1
  822.             IF row < 0 THEN row = n1
  823.             'still here means we checked all rows in col so check next col
  824.             col = (col + 1) MOD sqPerSide
  825.             cc = cc + 1
  826.         WEND
  827.         'still here ? then up the bump
  828.         bump = (bump + 1) MOD m
  829.         bc = bc + 1
  830.     WEND
  831.  
  832. 'using a modulus m coverage with a bump so that opponent can't predict where
  833. 'the hardest place to plant the Detroyer
  834. FUNCTION cover (m, bump, c, r)
  835.     bm = bump MOD m 'make sure bump is in modulus
  836.     cm = (c + bm) MOD m
  837.     rm = r MOD m
  838.     IF rm = cm THEN cover = -1 ELSE cover = 0
  839.  
  840. FUNCTION max (a, b)
  841.     IF a > b THEN max = a ELSE max = b
  842.  

 


 


 

Bplus edit fixed download .zip
« Last Edit: March 10, 2020, 11:26:38 AM by bplus »