home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 120.lha / BattleShip / Battle.4th < prev    next >
Encoding:
Text File  |  1986-11-20  |  44.1 KB  |  1,298 lines
  1. \ This program is the boardgame BATTLESHIP!.
  2. \ Use the mouse to point to an area of the sea to fire your missles.
  3. \
  4. \ Version 1.0 - is a one player game
  5. \
  6. \ Version 1.4 - is a two player ( one humanoid, one Amiga ) game.
  7. \
  8. \ Version 1.5 - Adds digitized Sound and gives a little intelligence to the
  9. \               computer routine.
  10. \
  11. \ Version 1.6 - More smarter Computer moves! (Although it can't be too
  12. \               smart considering the author) Also a few bug fixes and I
  13. \               prettied up the display some.
  14. \
  15. \ It is also public domain ( I Hope! ) in as far as I request no fee
  16. \ for the sweat of my brow ( or the executable ). I would like it if
  17. \ you do use the game and/or code, if you tell your friends what a Genius
  18. \ the author is, and to send me mail telling me so.
  19. \
  20. \ I, Stephen Berry, can be reached at
  21. \     Compuserve [71561,276] ... occasionally.
  22. \
  23. \ ( Mainly because my wallet is not bottomless )
  24. \ If you have any problems ( doubtful ) contact me there.
  25. \
  26. \ Oh Yeah, CSI wants me to plug their language.
  27. \ And I would like to thank ASDG for VD0: & FaccII,
  28. \ The Brilliant Canuck who wrote GOMF1.0, and the fellows
  29. \ who did CONMAN & POPCLI.
  30. \
  31. \ By the way guy's ... the checks are in the mail. (Really!)
  32.  
  33. Anew Battleship
  34.  
  35. decimal
  36.  
  37. Include IFF-sound.f     \ Load in the sound words
  38.  
  39. 200 Tokens
  40. 50000 minimum.object
  41.  
  42. Global dest.hand in.heap
  43. Global s.hand in.heap
  44. Global battle.hand in.heap
  45. Global air.hand in.heap
  46. Global air.ball.hand in.heap
  47.  
  48.                                 \ define a custom screen with 3 bit planes
  49. struct NewScreen  Bscreen       \ Tell Intuition what the screen looks like
  50.     Bscreen InitScreen          \ copy default values to new screen
  51.     645 Bscreen +nsWidth w!
  52.     205 Bscreen +nsHeight w!
  53.     3 Bscreen +nsDepth w!       \ # bit planes
  54.     2 Bscreen +nsDetailpen c!
  55.     3 Bscreen +nsBlockpen c!
  56.     CUSTOMSCREEN Bscreen +nsType w!
  57. structend
  58.  
  59. struct NewWindow  Cwin          \ This is the Computers window.
  60.      Cwin Initwindow            \ also where the user fires his bombs.
  61.      0  Cwin +nwLeftEdge w!
  62.      0  Cwin +nwTopEdge w!
  63.      645 Cwin +nwWidth w!
  64.      205 Cwin +nwHeight w!
  65.      5 Cwin +nwdetailpen c!
  66.      3 Cwin +nwblockpen c!
  67.      Smart_Refresh WINDOWDEPTH |
  68.      ACTIVATE | REPORTMOUSE | NOCAREREFRESH | WINDOWCLOSE |
  69.      GIMMEZEROZERO | WINDOWDRAG | Cwin +nwFlags !
  70.      fCLOSEWINDOW MOUSEBUTTONS | MENUPICK |
  71.      Cwin +nwIDCMPFlags  !
  72.      CUSTOMSCREEN Cwin +nwType w!       \ open a custom screen
  73. structend
  74.  
  75. struct NewWindow  Uwin          \ Users window ...this is where his ships are
  76.      Uwin Initwindow
  77.      0  Uwin +nwLeftEdge w!
  78.      0  Uwin +nwTopEdge w!
  79.      645 Uwin +nwWidth w!
  80.      205 Uwin +nwHeight w!
  81.      5 Uwin +nwdetailpen c!
  82.      2 Uwin +nwblockpen c!
  83.      Smart_Refresh WINDOWDEPTH |
  84.      ACTIVATE | REPORTMOUSE | NOCAREREFRESH | WINDOWCLOSE |
  85.      GIMMEZEROZERO | WINDOWDRAG | Uwin +nwFlags !
  86.      fCLOSEWINDOW MOUSEBUTTONS | MENUPICK |
  87.      Uwin +nwIDCMPFlags  !
  88.      CUSTOMSCREEN Uwin +nwType w!
  89. structend
  90.  
  91. struct NewWindow  Awin            \ open a window for the about menu
  92.      Awin Initwindow              \ and for Help. Put defaults into structure
  93.      100  Awin +nwLeftEdge w!
  94.      50  Awin +nwTopEdge w!
  95.      460 Awin +nwWidth w!
  96.      120 Awin +nwHeight w!
  97.      7 Awin +nwdetailpen c!
  98.      4 Awin +nwblockpen c!
  99.      ACTIVATE REPORTMOUSE | SIMPLE_REFRESH | GIMMEZEROZERO |
  100.      WINDOWCLOSE | Awin +nwFlags !
  101.      fCLOSEWINDOW MOUSEBUTTONS | Awin +nwIDCMPFlags  !
  102.      CUSTOMSCREEN Awin +nwType w!
  103. structend
  104.  
  105. cstruct MenuItem SubMenu   \ define structure for submenu's
  106.    0 ,                     \ +miNextItem
  107.    0 w,  0 w,              \ +mileftedge +mitopedge
  108.    130 w,  10 w,           \ +miwidth +miheight
  109.    ITEMENABLED COMMSEQ |   \ +miFlags
  110.    ITEMTEXT | HIGHCOMP | w,
  111.    0 ,                     \ +miMutualExclude
  112.    0 ,   0 ,               \ +miItemFill +miSelectFill
  113.    ascii a  c,  0 c,       \ +miCommand - kludge byte
  114.    0 ,                     \ +miSubItem
  115.    0 w,                    \ +miNextSelect
  116. structend
  117.  
  118. struct Intuitext Text.defaults     Text.defaults Intuitext erase
  119.    5  Text.defaults  +itfrontpen c!
  120.    2  Text.defaults  +itbackpen  c!
  121.    jam1  Text.defaults  +itdrawmode c!
  122.    8  Text.defaults  +itleftedge w!
  123.    1  Text.defaults  +ittopedge  w!
  124. structend
  125.  
  126. : inittext ( intuitext structure )
  127.    Text.defaults   swap  Intuitext   cmove ;
  128.  
  129. struct   intuitext   Sounzetext   Sounzetext inittext
  130. struct   intuitext   Onntext      Onntext inittext
  131. struct   intuitext   Offftext     Offftext inittext
  132. struct   intuitext   Aboutext     Aboutext inittext
  133. struct   intuitext   Quitext      Quitext inittext
  134. struct   intuitext   Newtext      Newtext inittext
  135. struct   intuitext   Byetext      Byetext inittext
  136. struct   intuitext   Help?text    Help?text inittext
  137. struct   intuitext   Yestext      Yestext inittext
  138. struct   intuitext   Notext       Notext inittext
  139. struct   intuitext   Helptext     Helptext inittext
  140. struct   intuitext   Infotext     Infotext inittext
  141. struct   intuitext   Tom?text     Tom?text inittext
  142. struct   intuitext   Badtext      Badtext inittext
  143. struct   intuitext   Stoptext     Stoptext inittext
  144. struct   intuitext   Starttext    Starttext inittext
  145.  
  146. create Options$ 0," Options"
  147. create About$ 0,"  About"
  148. create Quit$ 0,"  Quit"
  149. create Project$ 0," Project"
  150. create Onn$ 0," On"
  151. create Offf$ 0," Off"
  152. create Sounze$ 0," Sounds"
  153. create New$ 0," New Game"
  154. create Help$ 0," Help"
  155. create Byebye$ 0," Are You SURE you want to Quit ?"
  156. create Help?$ 0," Would you like some HELP, Tom?"
  157. create Info$ 0," Information"
  158. create Tom?$ 0," Who is Tom?"
  159. create Yes$ 0," Yeah"
  160. create No$ 0," No way!"
  161. create Bad$ 0," Error in Program Execution - Continue?"
  162. create Stop$ 0," Stop Game"
  163. create Start$ 0," Start Over"
  164.  
  165. : initmenu  ( Ptr --- )
  166.       Submenu swap MenuItem cmove ;
  167.  
  168. ( ======================================================================== )
  169. ( =                 This section sets up the structures for              = )
  170. ( =                   the on-screen menus                                = )
  171. ( ======================================================================== )
  172.  
  173. struct MenuItem Onn       Onn initmenu
  174.    60 Onn +miLeftedge w!               \ Sub-Item position
  175.    0 Onn +miTopedge  w!
  176.    ascii o Onn +micommand c!
  177. structend
  178.  
  179. struct MenuItem Offf        Offf initmenu
  180.    60 Offf +miLeftedge w!               \ Same level as previous
  181.    10 Offf +mitopedge  w!
  182.    ascii f Offf +micommand c!
  183. structend
  184.  
  185. struct MenuItem New New initmenu
  186.    0 New +mileftedge w!                 \ Item of Options
  187.    10 New +mitopedge w!
  188.    ascii n New +micommand c!
  189. structend
  190.  
  191. struct MenuItem Help Help initmenu
  192.    0 Help +mileftedge w!                \ Item of Options
  193.    20 Help +mitopedge w!
  194.    ascii h Help +micommand c!
  195. structend
  196.  
  197. struct MenuItem Sounze Sounze initmenu
  198.    0 Sounze +mileftedge w!              \ Item of Options
  199.    0 Sounze +mitopedge w!
  200.    ascii w Sounze +micommand c!
  201. structend
  202.  
  203. struct MenuItem jQuit    jQuit initmenu
  204.    0 jquit +mileftedge w!               \ Item of Project
  205.    10 jquit +mitopedge w!
  206.    ascii q jQuit +micommand c!          \ Aq (Amiga - q) shortcut for quit
  207. structend
  208.  
  209. struct MenuItem jAbout  jAbout initmenu
  210.    0 jAbout +mileftedge w!              \ Item of Project
  211.    0 jAbout +mitopedge w!
  212. structend
  213.  
  214. struct MenuItem Tom?  Tom? initmenu
  215.    0 Tom? +mileftedge w!              \ Item of Project
  216.    0 Tom? +mitopedge w!
  217.    ascii t Tom? +micommand c!          \ Aq (Amiga - t) shortcut for tom?
  218. structend
  219.  
  220. struct Menu Info         Info Menu erase
  221.    100 Info +muWidth w!               \ Top border Item
  222.    10 Info +muHeight w!
  223.    130 Info +muLeftedge w!
  224.    0 Info +muTopedge w!
  225.    MENUENABLED Info +muFlags w!
  226. structend
  227.  
  228. struct Menu Options      Options Menu erase
  229.    65 Options +muWidth w!               \ Top border Item
  230.    10 Options +muHeight w!
  231.    65 Options +muLeftedge w!
  232.    0 Options +muTopedge w!
  233.    MENUENABLED Options +muFlags w!
  234. structend
  235.  
  236. struct Menu Project       Project Menu erase
  237.    60 Project +muWidth w!               \ First Menu
  238.    10 Project +muHeight w!
  239.    MENUENABLED Project +muFlags w!
  240. structend
  241.  
  242. ( ======================================================================== )
  243. ( =             Graphics for the ships,subs & etc.                       = )
  244. ( ======================================================================== )
  245.  
  246. cstruct Image Idef           \ default image structure
  247.  idef image erase            \ clear out structure ( why? )
  248.  0 w, 0 w,                   \ left & top edge
  249.  64 w, 18 w,                 \ wide & high
  250.  3 w, 0 ,                    \ depth & Igpointer
  251.  7 c, 0 c,                   \ planepick & plane on-off
  252.  0 ,                         \ next image ptr
  253. structend
  254.  
  255. : initimage ( ptr -- )       \ copy image defauts to new image definition
  256.  idef swap Image cmove ;
  257.  
  258. struct image Dest.image dest.image initimage
  259. struct image s.image s.image initimage
  260. struct image battle.image battle.image initimage
  261. struct image air.image air.image initimage
  262. struct image water.image water.image initimage
  263.  
  264. \ Put the graphics bit map here - so I can forget the images created
  265. \ after I move them into chip memory. This saves me some valuable ram.
  266.  
  267.      Variable size.pic
  268. hex
  269.      create d.stryer
  270. here
  271. \ * Plane 0
  272.  0000 w, 0000 w, 0000 w, 0000 w,
  273.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
  274.  0000 w, 0000 w, 07fc w, 0000 w, 0000 w, 0000 w, fffe w, 0000 w,
  275.  01ff w, 8001 w, ffff w, 0000 w, 0003 w, ff03 w, ffff w, 8000 w,
  276.  0003 w, ff07 w, ffff w, e000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  277.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  278.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  279.  0000 w, 0000 w, 0000 w, 0000 w,
  280.  0000 w, 6000 w, 0006 w, 0407 w, 0101 w, f807 w, e10f w, ffff w,
  281.  0fe7 w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
  282. \ * Plane 1
  283.  0000 w, 0000 w, 0000 w, 0000 w,
  284.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
  285.  0000 w, 0000 w, 07fc w, 0000 w, 0000 w, 0000 w, fffe w, 0000 w,
  286.  01ff w, 8001 w, ffff w, 0000 w, 0003 w, ff03 w, ffff w, 8000 w,
  287.  0003 w, ff07 w, ffff w, e000 w, 0000 w, 0000 w, 000f w, 3c00 w,
  288.  000f w, 7cf9 w, e000 w, 0000 w, 0009 w, 1018 w, 2000 w, 0000 w,
  289.  000f w, 1310 w, c000 w, 0000 w, 0008 w, 1020 w, 2000 w, 0000 w,
  290.  0008 w, 1041 w, e000 w, 0000 w,
  291.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  292.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  293. \ * Plane 2
  294.  0000 w, 0000 w, 0000 w, 0000 w,
  295.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  296.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  297.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  298.  0000 w, 0000 w, 0000 w, 0000 w, ffff w, ffff w, fff0 w, c3fe w,
  299.  7ff0 w, 8306 w, 1fff w, fffe w, 1ff6 w, efe7 w, dfff w, fffe w,
  300.  07f0 w, ecef w, 3fff w, fffe w, 01f7 w, efdf w, dfff w, fffe w,
  301.  0077 w, efbe w, 1fff w, fffe w,
  302.  0007 w, 9fff w, fff9 w, fbf8 w, 0000 w, 07f8 w, 1ef0 w, 0000 w,
  303.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  304.  
  305.  here
  306.  swap - size.pic !
  307.  size.pic @ chip get.memory to dest.hand
  308.  d.stryer dest.hand @ size.pic @ cmove
  309.  
  310.         create s.marine
  311.  here
  312. \ * Plane 0
  313.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  314.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  315.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  316.  0000 w, 0000 w, 0fc0 w, 0000 w, 0000 w, 0000 w, 7fc0 w, 0000 w,
  317.  0000 w, 0001 w, ffe0 w, 0000 w, 0000 w, 0007 w, fff8 w, 0000 w,
  318.  0000 w, 0000 w, fffe w, 0000 w, 007f w, ffff w, 0000 w, ff80 w,
  319.  01ff w, ffff w, ffff w, ffe0 w, 0700 w, ffff w, ffff w, fff8 w,
  320.  1fff w, ffff w, ffff w, ffff w, 2fff w, ffff w, ffff w, ffff w,
  321.  ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
  322. \ * Plane 1
  323.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0c00 w, 0000 w,
  324.  03c4 w, 9e00 w, 0400 w, 0000 w, 0204 w, 9200 w, 0400 w, 0000 w,
  325.  03e4 w, 9e00 w, 0400 w, 0000 w, 0024 w, 9300 w, 0400 w, 0000 w,
  326.  03e7 w, 9f00 w, 0fc0 w, 0000 w, 0000 w, 0000 w, 7fc0 w, 0000 w,
  327.  0000 w, 0001 w, ffe0 w, 0000 w, 0000 w, 0007 w, fff8 w, 0000 w,
  328.  0000 w, 000f w, fffe w, 0000 w, 007f w, ffff w, ffff w, ff80 w,
  329.  01ff w, ffff w, ffff w, ffe0 w, 07ff w, ffff w, ffff w, fff8 w,
  330.  1eef w, ffbf w, ffff w, fffc w, 2843 w, cc1e w, 1ff9 w, fcc0 w,
  331.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  332. \ * Plane 2
  333.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  334.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  335.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  336.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  337.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  338.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  339.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  340.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  341.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  342.  
  343.  here
  344.  swap - size.pic !
  345.  size.pic @ chip get.memory to s.hand
  346.  s.marine s.hand @ size.pic @ cmove
  347.  
  348.          create battle.ship
  349.  here
  350. \ * Plane 0
  351.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
  352.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 00c0 w, 0000 w,
  353.  0000 w, 0000 w, 00e0 w, 0000 w, 0000 w, 0000 w, 00e0 w, 0000 w,
  354.  0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 0000 w, 0fff w, c000 w,
  355.  0000 w, 0001 w, 3b78 w, 0000 w, 0000 w, 3e3e w, 7cf8 w, 0000 w,
  356.  0000 w, 03e0 w, fffc w, 00fc w, fc3f w, 0771 w, 07fe w, 3fc0 w,
  357.  0ff0 w, 0ffc w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  358.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  359.  0000 w, 0000 w, 0000 w, 0000 w, ffff w, ffff w, ffff w, ffff w,
  360. \ * Plane 1
  361.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
  362.  0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 00c0 w, 0000 w,
  363.  0000 w, 0000 w, 00e0 w, 0000 w, 0000 w, 0000 w, 00e0 w, 0000 w,
  364.  0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 0000 w, 0fff w, c000 w,
  365.  0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 3e3f w, 7ff8 w, 0000 w,
  366.  0000 w, 03e0 w, fffc w, 00fc w, fc3f w, 07f1 w, fffe w, 3fc0 w,
  367.  0ff0 w, 0ffc w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  368.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  369.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  370. \ * Plane 2
  371.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  372.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  373.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  374.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  375.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  376.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  377.  0000 w, 0003 w, ffff w, fffe w, 7fff w, ffff w, ffff w, ffe0 w,
  378.  1fff w, ffff w, ffff w, ff80 w, 07ff w, ffff w, ffff w, f800 w,
  379.  01ff w, ffff w, ffff w, e000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  380.  
  381.  here
  382.  swap - size.pic !
  383.  size.pic @ chip get.memory to battle.hand
  384.  battle.ship battle.hand @ size.pic @ cmove
  385.  
  386.           create air.ship
  387.  here
  388. \ * Plane 0
  389.  0000 w, 0000 w, 0003 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  390.  0000 w, 0000 w, 02ff w, c000 w, 0000 w, 0000 w, 03fd w, c000 w,
  391.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 3fff w, fc00 w,
  392.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 3fff w, fc00 w,
  393.  0000 w, 0000 w, 00ff w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  394.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  395.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  396.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0020 w, 0400 w, 0000 w,
  397.  0000 w, 0078 w, 9e00 w, 0000 w, ffff w, ffff w, ffff w, ffff w,
  398. \ * Plane 1
  399.  0000 w, 0000 w, 0003 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  400.  0000 w, 0000 w, 03ff w, c000 w, 0000 w, 0000 w, 03ff w, c000 w,
  401.  0000 w, 1000 w, 0000 w, 0000 w, 0000 w, fc00 w, 3fff w, fc00 w,
  402.  0000 w, 4800 w, 0080 w, c000 w, 0000 w, 0000 w, 3fff w, fc00 w,
  403.  0000 w, 0000 w, 00ff w, 0000 w, 00ff w, ffc0 w, 0000 w, 0000 w,
  404.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0800 w, 0000 w,
  405.  0000 w, 0000 w, 1400 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  406.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  407.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  408. \ * Plane 2
  409.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 000f w, 0000 w,
  410.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  411.  0000 w, 0000 w, 00ff w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  412.  0000 w, 0000 w, 0f7f w, 3000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  413.  0000 w, 0000 w, 0000 w, 0000 w, 0f00 w, 003f w, ffff w, fff0 w,
  414.  001f w, ffff w, ffff w, f800 w, 0001 w, ffff w, ffff w, 8000 w,
  415.  0000 w, 1fff w, fff8 w, 0000 w, 0000 w, 03ff w, ffc0 w, 0000 w,
  416.  0000 w, 007f w, fe00 w, 0000 w, 0000 w, 001f w, f800 w, 0000 w,
  417.  0000 w, 0007 w, 6000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  418.  
  419.  here
  420.  swap - size.pic !
  421.  size.pic @ chip get.memory to air.hand
  422.  air.ship air.hand @ size.pic @ cmove
  423.  
  424.             create air.ball  \ Image if user misses everthing
  425.  here
  426. \ * Plane 0
  427.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  428.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  429.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  430.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  431.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  432.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  433.  0000 w, 0000 w, 0000 w, 8000 w, 0100 w, 0000 w, 0003 w, c000 w,
  434.  0785 w, 8000 w, 600f w, e000 w, 1fff w, e3c1 w, f9ff w, ffc4 w,
  435.  7fff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
  436. \ * Plane 1
  437.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  438.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  439.  0306 w, 3f87 w, 8780 w, 0000 w, 028a w, 040c w, 0c00 w, 0000 w,
  440.  0252 w, 0402 w, 0200 w, 0000 w, 0222 w, 0401 w, 0100 w, 0000 w,
  441.  0202 w, 0400 w, c0c0 w, 0000 w, 0202 w, 3f8f w, 8f80 w, 0000 w,
  442.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  443.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  444.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  445.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  446. \ * Plane 2
  447.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  448.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  449.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  450.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  451.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  452.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  453.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  454.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  455.  0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
  456.  
  457.  here
  458.  swap - size.pic !
  459.  size.pic @ chip get.memory to air.ball.hand
  460.   air.ball air.ball.hand @ size.pic @ cmove
  461.  
  462.  Forget d.stryer        \ reclaim object space
  463.  
  464. ( ======================================================================== )
  465. ( =             Subwords - to get the job done !                         = )
  466. ( ======================================================================== )
  467.  
  468. : initext$ ( -- )       \ initialize the Intuitext strings for run time
  469.  Project$ Project +muMenuName !
  470.  About$ Aboutext +itItext ! Aboutext jAbout +miItemFill !
  471.  Quit$ Quitext +ititext ! Quitext jQuit +miItemfill !
  472.  Options$ Options +muMenuName !
  473.  Sounze$ Sounzetext +ititext ! Sounzetext Sounze +miItemfill !
  474.  New$ Newtext +ititext ! Newtext New +miItemfill !
  475.  Onn$ Onntext +ititext ! Onntext Onn +miItemfill !
  476.  Offf$ Offftext +ititext ! Offftext Offf +miItemfill !
  477.  Info$ Info +muMenuName !
  478.  Tom?$ Tom?text +ititext ! Tom?text Tom? +miitemfill !
  479.  Byebye$ Byetext +ititext !
  480.  Help?$ Help?text +ititext !
  481.  Bad$ Badtext +ititext !
  482.  Start$ Starttext +ititext !
  483.  Stop$ Stoptext +ititext !
  484.  Yes$ Yestext +ititext !
  485.  No$ Notext +ititext !
  486.  Help$ Helptext +itItext ! Helptext Help +miItemfill !
  487.  dest.hand @ dest.image +igimagedata !
  488.  s.hand @ s.image +igimagedata !
  489.  battle.hand @ battle.image +igimagedata !
  490.  air.hand @ air.image +igimagedata !
  491.  air.ball.hand @ water.image +igimagedata ! ;
  492.  
  493. : Initpntrs ( -- )           \ Give all the pointers valid values
  494.  jAbout Project +muFirstItem !
  495.  Options Project +muNextMenu !
  496.  Info Options +muNextMenu !
  497.  Tom? Info +muFirstItem !
  498.  Sounze Options +muFirstItem !
  499.  New Sounze +miNextItem !
  500.  jQuit jAbout +miNextItem !
  501.  Offf Sounze +miSubItem !
  502.  Onn Offf +miNextItem !
  503.  Help New +miNextitem !
  504.  10 Byetext +itTopedge w!    \ have to make some adjustments to
  505.  3 Yestext +itTopedge w!     \ the standard intuitext defaults.
  506.  3 Notext +itTopedge w!      \ I can either make my own numbers
  507.  20 Help?text +itTopedge w!  \ or let Intuition do it for me.
  508.  10 Help?text +itleftedge w! \ I chose to do it My Way (sorry Frank)
  509.  20 Badtext +itTopedge w!
  510.  10 Badtext +itleftedge w!
  511.  3 Starttext +itTopedge w!
  512.  3 Stoptext +itTopedge w! ;
  513.  
  514. Variable Uwindow_pntr
  515. Variable Cwindow_pntr
  516.  
  517. : Uwin_active ( -- )         \ make the Users window active
  518. Uwindow_pntr @ Windowtofront
  519. Uwindow_pntr @ !window
  520. Uwindow_pntr @ activatewindow ;
  521.  
  522. : Cwin_active ( -- )         \ make Computers window the active one
  523. Cwindow_pntr @ Windowtofront
  524. Cwindow_pntr @ !window
  525. Cwindow_pntr @ activatewindow ;
  526.  
  527. : Cleanup ( -- )             \ do when fCLOSEWINDOW detected
  528.     Cwindow_pntr @ Clearmenustrip
  529.     Cwindow_pntr @ CloseWindow
  530.     Uwindow_pntr @ ClearMenuStrip
  531.     Uwindow_pntr @ CloseWindow
  532.     CurrentScreen @ CloseScreen ginit ;
  533.  
  534. : goodbye ( -- )             \ bye if executing turnkey, abort if not
  535.        ?turnkey  if bye else abort then ;
  536. hex
  537.  
  538. : ITEMNUM ( n --  n )        \ convert menu selection to number
  539.  -5 scale 03f and ;
  540.  
  541. : SUBNUM ( n -- n )          \ convert for submenu #
  542.     -0b scale 01f and ;
  543.  
  544. : MENUNUM ( n -- n )         \ which menu ?
  545.  01f and ;
  546.  
  547. : menu# thisevent +eCode w@ ;
  548.  
  549. : whichmenu menu# MENUNUM ;
  550.  
  551. : whichitem menu# ITEMNUM ;
  552.  
  553. : whichsubmenu menu# SUBNUM ;
  554.  
  555. : Mstate ( --  Mstate )      \ get the state of the left mouse button
  556.  Thisevent +ecode w@ ;
  557.  
  558. decimal
  559.  
  560. : Print.text ( x y addr count  -- )     \ output text directly to window
  561.  2swap xform.array
  562.  xlate moveto rport !a1 !d0 !a0 graphics 10 ;     \ 10 is text
  563.  
  564. ( ====================================================================== )
  565. ( =                    Menu respones                                   = )
  566. ( ====================================================================== )
  567.  
  568. Variable Soundon 1 Soundon !
  569.  
  570. : Turn_on_Sound ( -- )       \ Make some noise
  571.  1 Soundon ! ;
  572.  
  573. : Turn_Sound_off ( -- )      \ Be Quiet ! Shhhh.
  574.  0 Soundon ! ;
  575.  
  576. : get_mouse_click ( -- )     \ wait for a mouse button event
  577. Begin
  578.  getevent dup
  579.  MOUSEBUTTONS = Mstate SELECTUP = and swap fCLOSEWINDOW = |
  580.  pause
  581. until ;
  582.  
  583. Variable Savewn
  584.  
  585. : About.prog ( -- )    \ User wants to know more about the author. Flatterer!
  586.  
  587. Currentwindow @ Savewn !     \ save pointer to old window
  588. 0" About Battleship! " Awin +nwTitle !
  589. Currentscreen @ Awin +nwscreen !      \ connect window to current screen
  590. Awin Openwindow
  591. 20 10 " Program written by Steve Berry." count Print.text
  592. 20 20 " This was written as an exercize in Intuition." count Print.text
  593. 20 30 " Also as a get-re-aqquainted-with Forth session." count
  594.  Print.text
  595. 20 40 " Date 2/28/88   V1.6   ---------   CSI Multi-Forth"
  596.  count Print.text
  597. 20 50 " Address any complaints or bugs/enhanchments to: " count print.text
  598. 40 65 " Stephen Berry " count print.text
  599. 40 75 " CIS [71561,276] or GEinie XTH62381 under RAZ " count print.text
  600. 40 85 " ( unless your name is Tom - then don't bother ) " count print.text
  601. 20 100 " To exit back to Game - Press left button in window " count print.text
  602. get_mouse_click
  603. Currentwindow @ closewindow
  604. Savewn @ !window ;
  605.  
  606. : Help.prog ( -- )            \ User needs some help.
  607.  
  608. Currentwindow @ Savewn !      \ save pointer to old window
  609. 0" Help for Battleship! " Awin +nwTitle !
  610. Currentscreen @ Awin +nwscreen !      \ connect window to current screen
  611. Awin Openwindow               \ open it up
  612. 30 50 " I KNEW You needed Help Tom ! " count print.text
  613. 50 delay
  614. clr.window
  615. 5 10 " The object of the game is to sink :" count Print.text
  616. 20 20 " 1 - AircraftCarrier    2 - Battleships " count Print.text
  617. 20 30 " 3 - Submarines         4 - Destroyers" count Print.text
  618. 5 40 " Each of the ships has AT LEAST 2 pieces to it." count Print.text
  619. 5 50 " The actual number of pieces for each ship is:" count print.text
  620. 20 60 " AircraftCarrier - 5   Battleships - 4" count print.text
  621. 20 70 " Submarines - 3         Destroyers - 2" count print.text
  622. 5 80 " Each SHIP can be oriented horizontally or vertically" count print.text
  623. 5 90 " The next few screens contain some examples." count print.text
  624. 5 100 " Press left mouse button in window or gadget." count print.text
  625. get_mouse_click
  626. clr.window
  627. 5 10 " To sink a Battleship you must hit ALL FOUR of it's" count print.text
  628. 5 20 " pieces!" count print.text
  629. 92 20 do rport battle.image 200 I Drawimage 18 +loop
  630. 5 100 " Press left mouse button in window or gadget." count print.text
  631. get_mouse_click
  632. clr.window
  633. 5 10 " Or the Battleship could look like this:" count print.text
  634. 266 10 do rport battle.image I 50 Drawimage 64 +loop
  635. 5 100 " Press left mouse button in window or gadget." count print.text
  636. get_mouse_click
  637. clr.window
  638. 5 10 " The pieces look like this: " count print.text
  639. 5 30 " Aircraft-Carrier : " count print.text
  640. rport air.image 200 20 Drawimage
  641. 5 50 " Battleship : " count print.text
  642. rport battle.image 200 40 Drawimage
  643. 5 70 " Submarine : " count print.text
  644. rport s.image 200 60 Drawimage
  645. 5 90 " Destroyer : " count print.text
  646. rport dest.image 200 80 Drawimage
  647. 5 105 " Press left mouse button in window or gadget." count print.text
  648. get_mouse_click
  649. clr.window
  650. 5 10 " When starting the game you must enter in the positions" count
  651. print.text
  652. 5 20 " of YOUR ships. You do this by simply pressing the mouse" count
  653. print.text
  654. 5 30 " button to where you want the piece to go. The computer" count
  655. print.text
  656. 5 40 " starts by placing the Aircraft-carrier first, then the" count
  657. print.text
  658. 5 50 " Battleships (remember there are two Battleships!) and" count
  659. print.text
  660. 10 60 " so on. If you make a mistake, finish entering the" count
  661. print.text
  662. 5 70 " ships first, and then select New Game from the menu." count
  663. print.text
  664. 5 80 " First person (or Amiga) to sink all the ships - WINS!" count
  665. print.text
  666. 30 90 "  GOOD LUCK !!!!!!" count print.text
  667. 5 100 " Press left mouse button in window or gadget." count print.text
  668. get_mouse_click
  669. clr.window
  670. 30 50 " Was that too COM-PLI-CA-TED for you Tom?" count print.text
  671. 50 delay
  672. Currentwindow @ closewindow
  673. Savewn @ !window ;
  674.  
  675. : Who_is_Tom? ( -- )    \ So you wanna know about Tom eh?
  676.  
  677. Currentwindow @ Savewn !     \ save pointer to old window
  678. 0" About Tom! " Awin +nwTitle !
  679. Currentscreen @ Awin +nwscreen !      \ connect window to current screen
  680. Awin Openwindow
  681. 20 20 " So  you think  you want to know  who Tom is?" count print.text
  682. 20 30 " If you  knew him,  you'ud  run  and  hide at" count Print.text
  683. 20 40 " the  sound  of  his  name.  Little  children" count Print.text
  684. 20 50 " SCREAM and CRY for their mother  when  he is" count Print.text
  685. 20 60 " around. He is the epitome of evil incarnated." count print.text
  686. 40 80 " So who is Tom?" count print.text
  687. 20 100 " To find out click the left mouse button." count print.text
  688. get_mouse_click
  689. clr.window
  690. 20 55 " Tom is my Beta tester." count print.text
  691. get_mouse_click
  692. Currentwindow @ closewindow
  693. Savewn @ !window ;
  694.  
  695. : change-colors ( -- )        \ change color palette for the game
  696.  Viewaddress +vViewport @ dup
  697.  0 0 0 15 setrgb4 dup         \ color reg 0 - lt blue
  698.  1 2 2 8 setrgb4 dup          \ color reg 1 - dk blue
  699.  2 0 0 0 setrgb4 dup          \ color 2 - black
  700.  3 10 10 10 setrgb4 dup       \ color 3 - lt grey
  701.  4 6 6 6 setrgb4 dup          \ color 4 - dk grey
  702.  5 15 0 0 setrgb4 dup         \ color 5 - red
  703.  6 15 13 0 setrgb4            \ color 6 - yellow
  704.  7 15 15 15 setrgb4           \ color 7 - White
  705.  ;
  706.  
  707. Variable seed
  708. VBeamPos seed !
  709. Variable rnd-1
  710. hex 7fffffff rnd-1 !          \ largest pos num
  711. ffffffff Constant big         \ basicly -1
  712. decimal
  713. Variable Start
  714. Variable End
  715. 10 10 4 2array grid           \ array for Computers ships
  716. 10 10 4 2array gridU          \ Users array ( the computer fires into here )
  717.  
  718. : rnd ( -- rnd# )      \ generates a random number from the seed given by
  719.                        \ the current system time ( kinda).
  720.  rnd-1 @ 0= if seed @ rnd-1 ! then
  721.  rnd-1 @ 16807 big */mod drop dup rnd-1 ! ;
  722.  
  723. : rand ( -- )                 \ generate a random number from 0 to 9
  724.  rnd big 11 */mod drop abs ;
  725.  
  726. : randnum ( -- )              \ get a random, but filter out num's > 9
  727. 0
  728. Begin
  729.  drop
  730.  rand dup 10 <
  731. until ;
  732.  
  733. : ?empty grid @ 0= ; ( x y -- f )  \ is x y empty ?
  734.  
  735. : ?emptyU gridU @ ( x y -- f )     \ is x y empty for gridU ?
  736. 1 = not ;
  737.  
  738. : ?check ( -- x y )           \ get an x and y of matrice  that is not used
  739. 0 0
  740. Begin
  741.  2drop
  742.  randnum randnum 2dup
  743.  ?empty
  744. until ;
  745.  
  746. Variable x Variable y
  747. Variable gStart Variable gEnd
  748.  
  749. : ?Getrange ( h/v size -- f ) \ look for free space in matrice of size
  750. 1-                            \ in horiz or vert orientation.
  751. Locals| size h/v |
  752. h/v if                        \ find start & end points on a line
  753.  x @ size - 0< if
  754.   0 gstart ! size gend !
  755.  else
  756.  x @ size - dup gstart !
  757.  size + gend !
  758.  then
  759. else
  760.  y @ size - 0< if
  761.   0 gstart ! size gend !
  762.  else
  763.  y @ size - dup gstart !
  764.  size + gend !
  765.  then
  766. then
  767.                              \ now check gstart thru end to be empty
  768. 0                            \ in matrice. return a flag reflecting result.
  769. gend @ 1+ gstart @ do
  770.  h/v if I y @
  771.  else x @ I then
  772.  grid @ |
  773. loop
  774. not ;
  775.  
  776. : put-ship ( size num -- )   \ place ship of given size in array - randomly
  777.  Locals| num size |
  778.  rand 5 > if                 \ pick horizontal orientation
  779.  Begin
  780.   ?check y ! x !
  781.   1 size ?getrange
  782.  until
  783.  gend @ 1+ gstart @ do
  784.   num I y @ grid !
  785.  loop
  786.  else
  787.  Begin
  788.   ?check y ! x !
  789.   0 size ?getrange
  790.  until
  791.  gend @ 1+ gstart @ do
  792.   num x @ I grid !
  793.  loop
  794. then ;
  795.  
  796.  
  797. : print-screen ( -- )         \ using matrice print graphics to screen
  798.  10 0 do
  799.   10 0 do
  800.   j i grid @ case
  801.   2 5 range.of rport dest.image i 64 * j 18 * drawimage
  802.     endof
  803.   6 8 range.of rport s.image i 64 * j 18 * drawimage
  804.     endof
  805.   9 10 range.of rport battle.image i 64 * j 18 * drawimage
  806.     endof
  807.   11 of rport air.image i 64 * j 18 * drawimage
  808.     endof
  809.     endcase
  810.   loop
  811.  loop ;
  812.  
  813. ( ===================================================================== )
  814. ( =                     Mouse coordinates & stuff                     = )
  815. ( ===================================================================== )
  816.  
  817.  
  818. : getxy ( -- rport x y )      \ find mouse position in matrice
  819.  
  820. rport Thisevent +eMousey w@ 9 - 18 /
  821. 0 9 range not if 9 > if 9 else 0 then then
  822. Thisevent +eMousex w@ 1+ 64 /
  823. 0 9 range not if 9 > if 9 else 0 then then ;
  824.  
  825. : bombsound ( -- )            \ give me a whistle!
  826.  
  827. 2 play 2 kill-sound ;
  828.  
  829. : hitsound ( -- )             \ sound when you get hit
  830.  
  831. soundon @ if
  832. 3 play 3 kill-sound
  833. then ;
  834.  
  835. : ?oor ( x y -- f )           \ is x y out of range?
  836.  
  837.  locals| y x |
  838.  x 0 < x 9 > | y 0 < | y 9 > | ;
  839.  
  840. : Draw_grid ( -- )
  841.  
  842. 181 0 do
  843.   0 I Moveto                  \ draw horizontal grid lines
  844.   640 I Drawto
  845.   18 +loop
  846. 641 0 do
  847.   I 0 Moveto                  \ same as above but with vertical.
  848.   I 180 Drawto
  849.   64 +loop ;
  850.  
  851. : sinksound ( -- )            \ sinking ship sounds go here
  852.  
  853. soundon @ if
  854. 1 play 1 kill-sound
  855. then ;
  856.  
  857. : ?Sink ( x y -- )            \ Check if the ship has sunk.
  858.  
  859. 2dup grid @
  860. Locals| snum y x |
  861. 1 x y grid !                  \ sink the piece ...
  862. 0
  863. 10 0 do
  864.  10 0 do
  865.   j i grid @ snum = if 1+ then
  866.  loop
  867. loop
  868. 0= if
  869.  snum case
  870.  2 5 range.of 40 188 " You sunk MY Destroyer ! " count print.text
  871.   sinksound endof
  872.  6 8 range.of 40 188 " You sunk MY Submarine ! " count print.text
  873.   sinksound endof
  874.  9 10 range.of 40 188 " You sunk MY Battleship! " count print.text
  875.   sinksound endof
  876.  11 of 40 188 " You sunk MY Carrier !!!   " count print.text
  877.   sinksound endof
  878.  endcase
  879. then ;
  880.  
  881. Variable Lastx Variable Newx 0 Newx ! 0 Lastx !
  882. Variable Lasty Variable Newy 0 Newy ! 0 Lasty !
  883. 4 4 1Array Past         \ This array is for remembering past moves
  884. Variable Orientation -1 Orientation !
  885. 0 Constant Horizon
  886. 1 Constant Vertical
  887.  
  888. : ?SinkU ( x y -- )           \ Check if the Users ship has sunk.
  889.  
  890. 2dup gridU @
  891. Locals| snum y x |
  892. 1 x y gridU !                 \ sink the piece ...
  893. x Lastx ! y Lasty !
  894. 0
  895. 10 0 do
  896.  10 0 do
  897.   j i gridU @ snum = if 1+ then
  898.  loop
  899. loop
  900. 0= if
  901.  -1 lastx ! -1 lasty ! false 0 past !
  902.  snum case
  903.  2 5 range.of 40 188 " I sunk YOUR Destroyer ! " count print.text
  904.   sinksound endof
  905.  6 8 range.of 40 188 " I sunk YOUR Submarine ! " count print.text
  906.   sinksound endof
  907.  9 10 range.of 40 188 " I sunk YOUR Battleship! " count print.text
  908.   sinksound endof
  909.  11 of 40 188 " I sunk YOUR Carrier !!!   " count print.text
  910.   sinksound endof
  911.  endcase
  912. else                \ Didn't sink it ... so remember it!
  913.     0 past @ true = snum 3 past @ = and if     \ is there a past hit?
  914.         x 1 past @ = if Horizon Orientation ! then
  915.         y 2 past @ = if Vertical Orientation ! then
  916.     else
  917.         true 0 past ! x 1 past ! y 2 past ! snum 3 past !
  918.     then
  919. then ;
  920.  
  921. \ ========================================================================
  922. \ ==        This is the Computer's "Intelligence" section               ==
  923. \ ========================================================================
  924.  
  925. Variable HitsU
  926. Variable Hits
  927. Variable Temp-count 0 Temp-count !
  928. Variable Temp-index 0 Temp-index !
  929. Variable Temp-x -1 Temp-x !
  930. Variable Temp-y -1 Temp-y !
  931. Variable Toggl 0 toggl !
  932. Variable Stopit 0 stopit !
  933. Variable BeforeX 0 BeforeX !
  934. Variable BeforeY 1 BeforeY !
  935. Variable Stack_depth 0 Stack_depth !
  936. Variable Pass2 false Pass2 !
  937.  
  938. : (randnum) ( -- x y )        \ get a not so random number.
  939. depth Stack_depth !           \ in fact this is a stratagy for increased
  940. false stopit !                \ efficiency in covering the board
  941. 10 BeforeX @ do
  942.     10 BeforeY @ do
  943.         I 7 > If toggl @
  944.             case
  945.                 0 of -1 BeforeY ! 1 toggl ! leave endof
  946.                 1 of -2 BeforeY ! 0 toggl ! leave endof
  947.             endcase
  948.             BeforeX @ 1+ dup 9 > if drop 0 then BeforeX !
  949.         else
  950.             BeforeX @ BeforeY @ 2+ 2dup
  951.             ?emptyU If true stopit ! 2dup leave then
  952.             BeforeY ! BeforeX !
  953.         then
  954.     2 +loop
  955.     stopit @ If leave then
  956. loop
  957. depth Stack_depth @ = if    \ are we at the end of the array?
  958.     1 toggl !
  959.     -1 BeforeY !
  960.     -1 Orientation !        \ If so, reset to scan not played squares.
  961.     false 0 past !          \ This fixes a bug in the routine (the computer
  962.     0 BeforeX !             \ gets confused when a different ship -
  963.     true Pass2 !
  964.     Myself                  \ other than the current one - is hit)
  965. then ;          \ never thought i'd use a recursive call!
  966.  
  967. : no_bad_move ( x y -- )      \ make sure the computer doesn't waste a
  968. locals| y x |                 \ shot in a dead end (lonely piece).
  969.   0 temp-count !
  970.   2 -1 do
  971.    2 -1 do
  972.     j -1 = i 0 = and j 0 = i -1 = and |
  973.     j 0 = i 1 = and j 1 = i 0 = and | |
  974.     if x j + y i+ ?oor not if x j + y i+ gridU @ 1 = not if 1 temp-count !
  975.      x j + temp-x ! y i+ temp-y ! then then then
  976.    loop
  977.   loop ;
  978.  
  979. : randcomp ( -- x y )         \ get a random empty x y for gridU
  980.                               \ First check if there is only one piece
  981.                               \ of a ship left, and it's not a destroyer.
  982.                               \ if there is ... sink the sucker.
  983. 12 6 do
  984.  0 temp-count !
  985.  i temp-index !
  986.  10 0 do                        \ here we look through the array for a ship
  987.   10 0 do                       \ with just 1 piece left
  988.    j i gridU @
  989.    temp-index @ = if temp-count @ 1+ temp-count !
  990.    j Temp-x ! i Temp-y ! then
  991.   loop
  992.  loop
  993.  temp-count @ 1 = if leave then
  994. loop
  995.  
  996. temp-count @ 1 = if temp-x @ temp-y @
  997. else
  998.  0 0                            \ now we are looking to get a randum #
  999.  Begin                          \ because the search failed
  1000.     2drop
  1001.     (randnum)
  1002.     2dup ?emptyU if
  1003.         Pass2 @ not if 2dup no_bad_move     \ don't do anything dumb!
  1004.         temp-count @ if true else false then
  1005.         else true then                      \ exit with co-ordinates
  1006.     else false then
  1007.  until
  1008. then ;
  1009.  
  1010. : Save_next ( x y -- )        \ save the position to fire next missle
  1011. locals| ly lx |
  1012. lx ly ?oor if exit then
  1013. lx ly ?emptyU
  1014. if lx newx ! ly newy ! then ;
  1015.  
  1016. : Kill_ship ( -- )            \ shoot the next piece of the ship
  1017.                               \ or get the next random place
  1018. lastx @ 0 < not if
  1019. lastx @ newx ! lasty @ newy !
  1020.  2 -1 do
  1021.   2 -1 do
  1022.    Orientation @                \ look around for a not played square
  1023.    case
  1024.      -1 of
  1025.        j -1 = i 0 = and j 0 = i -1 = and |
  1026.        j 0 = i 1 = and j 1 = i 0 = and | | endof
  1027.      HORIZON of j 0 = endof
  1028.      VERTICAL of i 0 = endof
  1029.    endcase
  1030.    if lastx @ j + lasty @ i+ Save_next then
  1031.   loop
  1032.  loop
  1033.  
  1034.  lastx @ newx @ =
  1035.  lasty @ newy @ = and
  1036.  if randcomp -1 -1 lastx ! lasty ! -1 Orientation ! false 0 past !
  1037.  else newx @ newy @ then
  1038. else randcomp -1 -1 lastx ! lasty ! -1 Orientation ! false 0 past ! then ;
  1039.  
  1040. ( =================================================================== )
  1041. ( ==            Miscellaneous startup and menu stuff                = )
  1042. ( =================================================================== )
  1043.  
  1044. : Placeum ( Ship_image numbr -- )  \ here we set up the Uwin with the user
  1045.                                    \ ships
  1046. getxy
  1047. Locals| y x rprt numbr Ship_image |
  1048. soundon @ if 2 play 2 kill-sound then
  1049. rprt Ship_image y 64 * x 18 * Drawimage
  1050. numbr x y gridU ! ;
  1051.  
  1052. hex 68 Constant MDOWN
  1053.     e8 Constant MUP decimal        \ mouse up & down IDCMPF
  1054.  
  1055. : setup-array ( -- )               \ zeros out current arrays
  1056. VBeamPos seed !                    \ also reset random # seed
  1057. 10 0
  1058.  do 10 0
  1059.   do
  1060.    0 j i grid !
  1061.    0 j i gridU !
  1062.   loop
  1063.  loop ;
  1064.  
  1065. : Startup-sequence ( -- )          \ Init pointers for run time
  1066.  0 play 0 kill-sound
  1067.  initext$ initpntrs ginit setup-array
  1068.  0 BeforeX ! -2 BeforeY !
  1069.  0 toggl !
  1070.  -1 Orientation ! false 0 past !
  1071.  false Pass2 !
  1072.  -1 -1 Lastx ! Lasty !
  1073.  0 hitsU !
  1074.  0 hits !
  1075.  5 11 put-ship
  1076.  2 0 do 4 9 I+ put-ship loop
  1077.  3 0 do 3 6 I+ put-ship loop
  1078.  4 0 do 2 2 I+ put-ship loop ;
  1079.  
  1080. : Get_mouse_click_empty ( -- )      \ get the `Click the mouse button-
  1081. Begin                               \ to continue' event.
  1082.  Get_mouse_click
  1083.  getxy
  1084.  gridU @ swap drop 0= not if
  1085.   soundon @ if
  1086.    30 5 beep then
  1087.   0 else
  1088.  1 then
  1089. until ;
  1090.  
  1091. : User_setup ( -- )           \ set up the Users ships in the array
  1092.  
  1093. Currentwindow @ Help?text Yestext Notext 0 0 400 100 AutoRequest
  1094.                               \ requestor for the help menus.
  1095. if
  1096.  Help.prog
  1097. then
  1098.  
  1099. 5 0 do                        \ now put the ships in the
  1100.     20 188 " Please place the Aircraft-Carrier piece #   on the board"
  1101.     count print.text
  1102.     350 188 1 I+ <# # #> print.text
  1103.     Get_mouse_click_empty     \ array
  1104.     air.image 11 Placeum
  1105. loop
  1106.  
  1107. 2 0 do
  1108.     4 0 do                    \ Battleships here
  1109.       20 188 " Please place Battleship( ) piece #   on the board       "
  1110.       count print.text
  1111.       300 188 1 I+ <# # #> print.text
  1112.       212 188 1 j + <# # #> print.text
  1113.       Get_mouse_click_empty
  1114.       Battle.image 9 j + Placeum
  1115.     loop
  1116. loop
  1117.  
  1118. 3 0 do
  1119.     3 0 do                    \ Submarines
  1120.       20 188 " Please place Submarine( ) piece #   on the board        "
  1121.       count print.text
  1122.       290 188 1 I+ <# # #> print.text
  1123.       204 188 1 j + <# # #> print.text
  1124.       Get_mouse_click_empty
  1125.       s.image 6 j + Placeum
  1126.     loop
  1127. loop
  1128.  
  1129. 4 0 do
  1130.     2 0 do                    \ Destroyers
  1131.       20 188 " Please place Destroyer( ) piece #   on the board        "
  1132.       count print.text
  1133.       290 188 1 I+ <# # #> print.text
  1134.       204 188 1 j + <# # #> print.text
  1135.       Get_mouse_click_empty
  1136.       dest.image 2 j + Placeum
  1137.     loop
  1138. loop
  1139. 20 188 "                                                        "
  1140. count print.text
  1141. clr.window Cwin_active ;
  1142.  
  1143. : restart ( -- )        \ start the game over -- but first show the user the
  1144.                         \ old screen and clean things up some.
  1145. Cwin_active
  1146. print-screen
  1147. 20 188 "    This is where everything was !                   " count print.text
  1148. 200 delay
  1149. 20 188 " *** Press the left mouse button to continue ****    " count print.text
  1150. get_mouse_click
  1151. clr.window startup-sequence draw_grid
  1152. Uwin_active clr.window draw_grid User_setup ;
  1153.  
  1154. : Saiyonara ( -- )      \ say goodbye but give the user one last chance.
  1155.  
  1156. Currentwindow @ Byetext Yestext Notext 0 0 300 65 AutoRequest
  1157.                         \ a simple requestor to quit.
  1158. if                      \ the asshole says he wants to leave.
  1159.  Cleanup goodbye
  1160. then ;
  1161.  
  1162. : do.menu ( -- )        \ Find out what the User has asked us to do.
  1163. whichmenu case
  1164.  0 of whichitem
  1165.   case
  1166.    0 of About.prog endof      \ About program menu
  1167.    1 of Saiyonara endof       \ Quit menu
  1168.   endcase
  1169.  endof
  1170.  1 of whichitem
  1171.   case
  1172.    0 of whichsubmenu case
  1173.     0 of Turn_Sound_off endof     \ Sound off
  1174.     1 of Turn_on_Sound endof      \ Sound on
  1175.    endcase endof
  1176.    1 of restart endof         \ New game
  1177.    2 of Help.prog endof       \ Help
  1178.   endcase
  1179.  endof
  1180.  2 of Who_is_Tom? endof       \ So Who is Tom anyway?
  1181. endcase ;
  1182.  
  1183. : sEvents   ( -- )            \ process IDCMP events
  1184.    GetEvent
  1185.    case
  1186.       fCLOSEWINDOW of  CleanUp goodbye endof
  1187.       MENUPICK  of  do.menu endof
  1188.    endcase ;
  1189.  
  1190.  
  1191. : Comp_fire ( -- )            \ Ok - the computer gets a turn
  1192. Uwin_active
  1193. 20 188 "                                    " count print.text
  1194. hits @ 30 = not if
  1195.  soundon @ if bombsound then
  1196.  Kill_ship
  1197.  Locals| y x |
  1198.  x y gridU @ case
  1199.   0 of rport water.image y 64 * x 18 * Drawimage
  1200.   40 188 "                           " count print.text
  1201.   1 x y gridU ! false endof
  1202.   2 5 range.of rport dest.image y 64 * x 18 * Drawimage
  1203.    hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  1204.   6 8 range.of rport s.image y 64 * x 18 * Drawimage
  1205.    hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  1206.   9 10 range.of rport battle.image y 64 * x 18 * Drawimage
  1207.    hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  1208.   11 of rport air.image y 64 * x 18 * Drawimage
  1209.    hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  1210.   endcase
  1211.  hitsU @ 30 = if
  1212.   20 188 " Sorry I WIN !!!! Better luck next time !!!! " count print.text
  1213.   soundon @ if 5 play 5 kill-sound then
  1214.   3 0 do
  1215.    15 0 do Viewaddress +vViewport @ 0 0 0 I setrgb4 10 delay loop
  1216.   loop
  1217.   then
  1218. then
  1219. 150 0 do sEvents 1 delay loop
  1220. Cwin_active ;
  1221.  
  1222. : Fire ( -- )     \ Ok. player has fired a missle ... do sounds and images
  1223. getxy
  1224. locals| y x rprt |
  1225. x y grid @ 1 = not
  1226. x y ?oor not and if
  1227.  soundon @ if bombsound then
  1228.  x y grid @ case
  1229.  0 of rprt water.image y 64 * x 18 * Drawimage
  1230.  40 188 "                           " count print.text
  1231.  1 x y grid ! endof
  1232.  2 5 range.of rprt dest.image y 64 * x 18 * Drawimage
  1233.   hitsound x y ?sink hits @ 1+ hits ! endof
  1234.  6 8 range.of rprt s.image y 64 * x 18 * Drawimage
  1235.   hitsound x y ?sink hits @ 1+ hits ! endof
  1236.  9 10 range.of rprt battle.image y 64 * x 18 * Drawimage
  1237.   hitsound x y ?sink hits @ 1+ hits ! endof
  1238.  11 of rprt air.image y 64 * x 18 * Drawimage
  1239.   hitsound x y ?sink hits @ 1+ hits ! endof
  1240.  endcase
  1241. hits @ 30 = if
  1242.  20 188 " CONGRADULATIONS !!!! YOU WIN !!!!     " count print.text
  1243.  soundon @ if 4 play 4 kill-sound then
  1244.  3 0 do
  1245.   15 0 do Viewaddress +vViewport @ 0 0 0 I setrgb4 10 delay loop
  1246.  loop
  1247.  then
  1248.  Comp_fire                    \ It's the computers turn
  1249. else soundon @ if 50 5 beep then
  1250. then ;
  1251.  
  1252. : screenEvents   ( -- )       \  process IDCMP events
  1253.    GetEvent
  1254.    case
  1255.       fCLOSEWINDOW of  CleanUp goodbye endof
  1256.       MENUPICK  of  do.menu endof
  1257.       MOUSEBUTTONS of Mstate SELECTUP =
  1258.            Hits @ 30 < HitsU @ 30 < AND AND if fire then endof
  1259. endcase  ;
  1260.  
  1261. : Error!         \ Somthing bad happened ... put up an auto-requester
  1262.  
  1263. Currentwindow @ Badtext Stoptext Starttext 0 0 400 100 AutoRequest
  1264. if cleanup goodbye then
  1265. cleanup ;
  1266.  
  1267. : doit   ( -- )               \ this becomes the turnkey token
  1268.  
  1269. On.error Error! resume        \ Forth found an error!
  1270.                               \ let the user decide the next action
  1271. Startup-sequence
  1272. 0" BattleShip! " Bscreen +nsDefaultTitle !
  1273. 0" Battleship! " Cwin +nwTitle !
  1274. Bscreen OpenScreen  verifyscreen        \ open the screen
  1275. CurrentScreen @ Cwin +nwScreen !        \ store screen ptr in window
  1276. Cwin OpenWindow verifywindow            \ open the window
  1277. currentwindow @ dup Project SetMenuStrip       \ Attach menu to screen
  1278. Cwindow_pntr !                                 \ save the windows pointer
  1279.  
  1280. ginit                                   \ must initialize csigraphics
  1281. change-colors                           \ set up the screen colors
  1282. clr.window
  1283. Draw_grid
  1284.  
  1285. 0" Battleship!  Your ships go here ! " Uwin +nwTitle !
  1286.                                         \ open window for Users ships
  1287. CurrentScreen @ Uwin +nwScreen !        \ store screen ptr in window
  1288. Uwin OpenWindow verifywindow            \ open the window
  1289. Currentwindow @ dup Project SetMenuStrip       \ Attach menu to screen
  1290. Uwindow_pntr !                          \ save the windows pointer
  1291. Draw_grid
  1292.  
  1293. User_setup
  1294.  
  1295. Begin pause                            \ Main polling loop
  1296.      Screenevents
  1297. again  ;                               \ do it "forever"
  1298.