\ This program is the boardgame BATTLESHIP!.
\ Use the mouse to point to an area of the sea to fire your missles.
\ 
\ Version 1.0 - is a one player game
\
\ Version 1.4 - is a two player ( one humanoid, one Amiga ) game.
\
\ Version 1.5 - Adds digitized Sound and gives a little intelligence to the
\               computer routine.
\
\ It is also public domain ( I Hope! ) in as far as I request no fee
\ for the sweat of my brow ( or the executable ). I would like it if
\ you do use the game and/or code, if you tell your friends what a Genius
\ the author is, and to send me mail telling me so. 
\
\ I, Stephen Berry, can be reached at 
\     Compuserve [71561,276] ... occasionally.
\     
\ ( Mainly because my wallet is not bottomless )
\ If you have any problems ( doubtful ) contact me there.
\
\ Oh Yeah, CSI wants me to plug their language.
\ And I would like to thank ASDG for VD0: & FaccII, 
\ The Brilliant Canuck who wrote GOMF1.0, and the fellows
\ who did CONMAN & POPCLI. 
\
\ By the way guy's ... the checks are in the mail.
 
Anew Battleship

decimal

Include IFF-sound.f     \ Load in the sound words

151 Tokens
50000 minimum.object

Global dest.hand in.heap
Global s.hand in.heap
Global battle.hand in.heap
Global air.hand in.heap
Global air.ball.hand in.heap

                                \ define a custom screen with 4 bit planes
struct NewScreen  Bscreen       \ Tell Intuition what the screen looks like 
    Bscreen InitScreen          \ copy default values to new screen
    3 Bscreen +nsDepth w!       \ # bit planes
    2 Bscreen +nsDetailpen c!
    3 Bscreen +nsBlockpen c!
    CUSTOMSCREEN Bscreen +nsType w!
structend

struct NewWindow  Cwin          \ This is the Computers window.
     Cwin Initwindow            \ also where the user fires his bombs.
     0  Cwin +nwLeftEdge w!
     0  Cwin +nwTopEdge w!
     640 Cwin +nwWidth w!
     200 Cwin +nwHeight w!
     5 Cwin +nwdetailpen c!
     3 Cwin +nwblockpen c!
     Smart_Refresh WINDOWDEPTH |
     ACTIVATE | REPORTMOUSE | NOCAREREFRESH | WINDOWCLOSE |
     GIMMEZEROZERO | WINDOWDRAG | Cwin +nwFlags !
     fCLOSEWINDOW MOUSEBUTTONS | MENUPICK |
     Cwin +nwIDCMPFlags  !
     CUSTOMSCREEN Cwin +nwType w!       \ open a custom screen
structend

struct NewWindow  Uwin          \ Users window ...this is where his ships are
     Uwin Initwindow
     0  Uwin +nwLeftEdge w!
     0  Uwin +nwTopEdge w!
     640 Uwin +nwWidth w!
     200 Uwin +nwHeight w!
     5 Uwin +nwdetailpen c!
     2 Uwin +nwblockpen c!
     Smart_Refresh WINDOWDEPTH |
     ACTIVATE | REPORTMOUSE | NOCAREREFRESH | WINDOWCLOSE |
     GIMMEZEROZERO | WINDOWDRAG | Uwin +nwFlags !
     fCLOSEWINDOW MOUSEBUTTONS | MENUPICK |
     Uwin +nwIDCMPFlags  !
     CUSTOMSCREEN Uwin +nwType w!
structend

struct NewWindow  Awin            \ open a window for the about menu
     Awin Initwindow              \ and for Help. Put defaults into structure 
     100  Awin +nwLeftEdge w!
     50  Awin +nwTopEdge w!
     460 Awin +nwWidth w!
     120 Awin +nwHeight w!
     7 Awin +nwdetailpen c!
     4 Awin +nwblockpen c!
     ACTIVATE REPORTMOUSE | SIMPLE_REFRESH | GIMMEZEROZERO | 
     WINDOWCLOSE | Awin +nwFlags !
     fCLOSEWINDOW MOUSEBUTTONS | Awin +nwIDCMPFlags  !
     CUSTOMSCREEN Awin +nwType w!
structend

cstruct MenuItem SubMenu   \ define structure for submenu's
   0 ,                     \ +miNextItem
   0 w,  0 w,              \ +mileftedge +mitopedge
   130 w,  10 w,           \ +miwidth +miheight
   ITEMENABLED COMMSEQ |   \ +miFlags
   ITEMTEXT | HIGHCOMP | w,
   0 ,                     \ +miMutualExclude
   0 ,   0 ,               \ +miItemFill +miSelectFill
   ascii a  c,  0 c,       \ +miCommand - kludge byte
   0 ,                     \ +miSubItem
   0 w,                    \ +miNextSelect
structend

struct Intuitext Text.defaults     Text.defaults Intuitext erase
   5  Text.defaults  +itfrontpen c!
   2  Text.defaults  +itbackpen  c!
   jam1  Text.defaults  +itdrawmode c!
   8  Text.defaults  +itleftedge w!
   1  Text.defaults  +ittopedge  w!
structend

: inittext ( intuitext structure )
   Text.defaults   swap  Intuitext   cmove ;

struct   intuitext   Sounzetext   Sounzetext inittext
struct   intuitext   Onntext      Onntext inittext
struct   intuitext   Offftext     Offftext inittext
struct   intuitext   Aboutext     Aboutext inittext
struct   intuitext   Quitext      Quitext inittext
struct   intuitext   Newtext      Newtext inittext
struct   intuitext   Byetext      Byetext inittext
struct   intuitext   Help?text    Help?text inittext
struct   intuitext   Yestext      Yestext inittext
struct   intuitext   Notext       Notext inittext
struct   intuitext   Helptext     Helptext inittext
struct   intuitext   Infotext     Infotext inittext
struct   intuitext   Tom?text     Tom?text inittext
struct   intuitext   Badtext      Badtext inittext
struct   intuitext   Stoptext     Stoptext inittext
struct   intuitext   Starttext    Starttext inittext

create Options$ 0," Options"
create About$ 0,"  About"
create Quit$ 0,"  Quit"
create Project$ 0," Project"
create Onn$ 0," On"
create Offf$ 0," Off"
create Sounze$ 0," Sounds"
create New$ 0," New Game"
create Help$ 0," Help"
create Byebye$ 0," Are You SURE you want to Quit ?"
create Help?$ 0," Would you like some HELP, Tom?"
create Info$ 0," Information"
create Tom?$ 0," Who is Tom?"
create Yes$ 0," Yeah"
create No$ 0," No way!"
create Bad$ 0," Error in Program Execution - Continue?"
create Stop$ 0," Stop Game"
create Start$ 0," Start Over"

: initmenu  ( Ptr --- )
      Submenu swap MenuItem cmove ;

( ======================================================================== )
( =                 This section sets up the structures for              = )
( =                   the on-screen menus                                = )
( ======================================================================== )

struct MenuItem Onn       Onn initmenu
   60 Onn +miLeftedge w!               \ Sub-Item position
   0 Onn +miTopedge  w!
   ascii o Onn +micommand c!
structend

struct MenuItem Offf        Offf initmenu
   60 Offf +miLeftedge w!               \ Same level as previous
   10 Offf +mitopedge  w!
   ascii f Offf +micommand c!
structend

struct MenuItem New New initmenu
   0 New +mileftedge w!                 \ Item of Options
   10 New +mitopedge w!
   ascii n New +micommand c!
structend

struct MenuItem Help Help initmenu
   0 Help +mileftedge w!                \ Item of Options
   20 Help +mitopedge w!
   ascii h Help +micommand c!
structend

struct MenuItem Sounze Sounze initmenu
   0 Sounze +mileftedge w!              \ Item of Options
   0 Sounze +mitopedge w!
   ascii w Sounze +micommand c!
structend

struct MenuItem jQuit    jQuit initmenu
   0 jquit +mileftedge w!               \ Item of Project
   10 jquit +mitopedge w!
   ascii q jQuit +micommand c!          \ Aq (Amiga - q) shortcut for quit
structend

struct MenuItem jAbout  jAbout initmenu
   0 jAbout +mileftedge w!              \ Item of Project
   0 jAbout +mitopedge w!
structend

struct MenuItem Tom?  Tom? initmenu
   0 Tom? +mileftedge w!              \ Item of Project
   0 Tom? +mitopedge w!
   ascii t Tom? +micommand c!          \ Aq (Amiga - t) shortcut for tom?
structend

struct Menu Info         Info Menu erase
   100 Info +muWidth w!               \ Top border Item
   10 Info +muHeight w!
   130 Info +muLeftedge w!
   0 Info +muTopedge w!
   MENUENABLED Info +muFlags w!
structend

struct Menu Options      Options Menu erase
   65 Options +muWidth w!               \ Top border Item
   10 Options +muHeight w!
   65 Options +muLeftedge w!
   0 Options +muTopedge w!
   MENUENABLED Options +muFlags w!
structend

struct Menu Project       Project Menu erase
   60 Project +muWidth w!               \ First Menu
   10 Project +muHeight w!
   MENUENABLED Project +muFlags w!
structend

( ======================================================================== )
( =             Graphics for the ships,subs & etc.                       = )
( ======================================================================== )

cstruct Image Idef           \ default image structure
 idef image erase            \ clear out structure ( why? )
 0 w, 0 w,                   \ left & top edge
 64 w, 18 w,                 \ wide & high
 3 w, 0 ,                    \ depth & Igpointer
 7 c, 0 c,                   \ planepick & plane on-off
 0 ,                         \ next image ptr
structend

: initimage ( ptr -- )       \ copy image defauts to new image definition
 idef swap Image cmove ;

struct image Dest.image dest.image initimage
struct image s.image s.image initimage
struct image battle.image battle.image initimage
struct image air.image air.image initimage
struct image water.image water.image initimage

\ Put the graphics bit map here - so I can forget the images created
\ after I move them into chip memory. This saves me some valuable ram.

     Variable size.pic
hex
     create d.stryer
here
\ * Plane 0
 0000 w, 0000 w, 0000 w, 0000 w, 
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
 0000 w, 0000 w, 07fc w, 0000 w, 0000 w, 0000 w, fffe w, 0000 w,
 01ff w, 8001 w, ffff w, 0000 w, 0003 w, ff03 w, ffff w, 8000 w,
 0003 w, ff07 w, ffff w, e000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 
 0000 w, 6000 w, 0006 w, 0407 w, 0101 w, f807 w, e10f w, ffff w,
 0fe7 w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
\ * Plane 1
 0000 w, 0000 w, 0000 w, 0000 w, 
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
 0000 w, 0000 w, 07fc w, 0000 w, 0000 w, 0000 w, fffe w, 0000 w,
 01ff w, 8001 w, ffff w, 0000 w, 0003 w, ff03 w, ffff w, 8000 w,
 0003 w, ff07 w, ffff w, e000 w, 0000 w, 0000 w, 000f w, 3c00 w,
 000f w, 7cf9 w, e000 w, 0000 w, 0009 w, 1018 w, 2000 w, 0000 w,
 000f w, 1310 w, c000 w, 0000 w, 0008 w, 1020 w, 2000 w, 0000 w,
 0008 w, 1041 w, e000 w, 0000 w, 
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
\ * Plane 2
 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, ffff w, ffff w, fff0 w, c3fe w,
 7ff0 w, 8306 w, 1fff w, fffe w, 1ff6 w, efe7 w, dfff w, fffe w,
 07f0 w, ecef w, 3fff w, fffe w, 01f7 w, efdf w, dfff w, fffe w,
 0077 w, efbe w, 1fff w, fffe w, 
 0007 w, 9fff w, fff9 w, fbf8 w, 0000 w, 07f8 w, 1ef0 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,

 here 
 swap - size.pic !
 size.pic @ chip get.memory to dest.hand
 d.stryer dest.hand @ size.pic @ cmove 

        create s.marine
 here
\ * Plane 0
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0fc0 w, 0000 w, 0000 w, 0000 w, 7fc0 w, 0000 w,
 0000 w, 0001 w, ffe0 w, 0000 w, 0000 w, 0007 w, fff8 w, 0000 w,
 0000 w, 0000 w, fffe w, 0000 w, 007f w, ffff w, 0000 w, ff80 w,
 01ff w, ffff w, ffff w, ffe0 w, 0700 w, ffff w, ffff w, fff8 w,
 1fff w, ffff w, ffff w, ffff w, 2fff w, ffff w, ffff w, ffff w,
 ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
\ * Plane 1
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0c00 w, 0000 w,
 03c4 w, 9e00 w, 0400 w, 0000 w, 0204 w, 9200 w, 0400 w, 0000 w,
 03e4 w, 9e00 w, 0400 w, 0000 w, 0024 w, 9300 w, 0400 w, 0000 w,
 03e7 w, 9f00 w, 0fc0 w, 0000 w, 0000 w, 0000 w, 7fc0 w, 0000 w,
 0000 w, 0001 w, ffe0 w, 0000 w, 0000 w, 0007 w, fff8 w, 0000 w,
 0000 w, 000f w, fffe w, 0000 w, 007f w, ffff w, ffff w, ff80 w,
 01ff w, ffff w, ffff w, ffe0 w, 07ff w, ffff w, ffff w, fff8 w,
 1eef w, ffbf w, ffff w, fffc w, 2843 w, cc1e w, 1ff9 w, fcc0 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
\ * Plane 2
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,

 here
 swap - size.pic !
 size.pic @ chip get.memory to s.hand
 s.marine s.hand @ size.pic @ cmove 

         create battle.ship
 here
\ * Plane 0
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 00c0 w, 0000 w,
 0000 w, 0000 w, 00e0 w, 0000 w, 0000 w, 0000 w, 00e0 w, 0000 w,
 0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 0000 w, 0fff w, c000 w,
 0000 w, 0001 w, 3b78 w, 0000 w, 0000 w, 3e3e w, 7cf8 w, 0000 w,
 0000 w, 03e0 w, fffc w, 00fc w, fc3f w, 0771 w, 07fe w, 3fc0 w,
 0ff0 w, 0ffc w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, ffff w, ffff w, ffff w, ffff w,
\ * Plane 1
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 0040 w, 0000 w,
 0000 w, 0000 w, 0040 w, 0000 w, 0000 w, 0000 w, 00c0 w, 0000 w,
 0000 w, 0000 w, 00e0 w, 0000 w, 0000 w, 0000 w, 00e0 w, 0000 w,
 0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 0000 w, 0fff w, c000 w,
 0000 w, 0000 w, 0ff0 w, 0000 w, 0000 w, 3e3f w, 7ff8 w, 0000 w,
 0000 w, 03e0 w, fffc w, 00fc w, fc3f w, 07f1 w, fffe w, 3fc0 w,
 0ff0 w, 0ffc w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
\ * Plane 2
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0003 w, ffff w, fffe w, 7fff w, ffff w, ffff w, ffe0 w,
 1fff w, ffff w, ffff w, ff80 w, 07ff w, ffff w, ffff w, f800 w,
 01ff w, ffff w, ffff w, e000 w, 0000 w, 0000 w, 0000 w, 0000 w,

 here
 swap - size.pic !
 size.pic @ chip get.memory to battle.hand
 battle.ship battle.hand @ size.pic @ cmove 

          create air.ship
 here
\ * Plane 0
 0000 w, 0000 w, 0003 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 02ff w, c000 w, 0000 w, 0000 w, 03fd w, c000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 3fff w, fc00 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 3fff w, fc00 w,
 0000 w, 0000 w, 00ff w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0020 w, 0400 w, 0000 w,
 0000 w, 0078 w, 9e00 w, 0000 w, ffff w, ffff w, ffff w, ffff w,
\ * Plane 1
 0000 w, 0000 w, 0003 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 03ff w, c000 w, 0000 w, 0000 w, 03ff w, c000 w,
 0000 w, 1000 w, 0000 w, 0000 w, 0000 w, fc00 w, 3fff w, fc00 w,
 0000 w, 4800 w, 0080 w, c000 w, 0000 w, 0000 w, 3fff w, fc00 w,
 0000 w, 0000 w, 00ff w, 0000 w, 00ff w, ffc0 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0800 w, 0000 w,
 0000 w, 0000 w, 1400 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
\ * Plane 2
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 000f w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 00ff w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0f7f w, 3000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0f00 w, 003f w, ffff w, fff0 w,
 001f w, ffff w, ffff w, f800 w, 0001 w, ffff w, ffff w, 8000 w,
 0000 w, 1fff w, fff8 w, 0000 w, 0000 w, 03ff w, ffc0 w, 0000 w,
 0000 w, 007f w, fe00 w, 0000 w, 0000 w, 001f w, f800 w, 0000 w,
 0000 w, 0007 w, 6000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,

 here
 swap - size.pic !
 size.pic @ chip get.memory to air.hand
 air.ship air.hand @ size.pic @ cmove 

            create air.ball  \ Image if user misses everthing
 here
\ * Plane 0
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 8000 w, 0100 w, 0000 w, 0003 w, c000 w,
 0785 w, 8000 w, 600f w, e000 w, 1fff w, e3c1 w, f9ff w, ffc4 w,
 7fff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w, ffff w,
\ * Plane 1
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0306 w, 3f87 w, 8780 w, 0000 w, 028a w, 040c w, 0c00 w, 0000 w,
 0252 w, 0402 w, 0200 w, 0000 w, 0222 w, 0401 w, 0100 w, 0000 w,
 0202 w, 0400 w, c0c0 w, 0000 w, 0202 w, 3f8f w, 8f80 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
\ * Plane 2
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,
 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w, 0000 w,

 here
 swap - size.pic !
 size.pic @ chip get.memory to air.ball.hand
  air.ball air.ball.hand @ size.pic @ cmove 

 Forget d.stryer        \ reclaim object space

( ======================================================================== )
( =             Subwords - to get the job done !                         = )
( ======================================================================== )

: initext$ ( -- )       \ initialize the Intuitext strings for run time
 Project$ Project +muMenuName !
 About$ Aboutext +itItext ! Aboutext jAbout +miItemFill ! 
 Quit$ Quitext +ititext ! Quitext jQuit +miItemfill !
 Options$ Options +muMenuName !
 Sounze$ Sounzetext +ititext ! Sounzetext Sounze +miItemfill !
 New$ Newtext +ititext ! Newtext New +miItemfill !
 Onn$ Onntext +ititext ! Onntext Onn +miItemfill !
 Offf$ Offftext +ititext ! Offftext Offf +miItemfill ! 
 Info$ Info +muMenuName ! 
 Tom?$ Tom?text +ititext ! Tom?text Tom? +miitemfill !
 Byebye$ Byetext +ititext !
 Help?$ Help?text +ititext !
 Bad$ Badtext +ititext !
 Start$ Starttext +ititext !
 Stop$ Stoptext +ititext !
 Yes$ Yestext +ititext !
 No$ Notext +ititext !
 Help$ Helptext +itItext ! Helptext Help +miItemfill !
 dest.hand @ dest.image +igimagedata ! 
 s.hand @ s.image +igimagedata !
 battle.hand @ battle.image +igimagedata ! 
 air.hand @ air.image +igimagedata !
 air.ball.hand @ water.image +igimagedata ! ;

: Initpntrs ( -- )           \ Give all the pointers valid values
 jAbout Project +muFirstItem ! 
 Options Project +muNextMenu !
 Info Options +muNextMenu !
 Tom? Info +muFirstItem !
 Sounze Options +muFirstItem !
 New Sounze +miNextItem !
 jQuit jAbout +miNextItem !
 Offf Sounze +miSubItem !
 Onn Offf +miNextItem !
 Help New +miNextitem !
 10 Byetext +itTopedge w!    \ have to make some adjustments to
 3 Yestext +itTopedge w!     \ the standard intuitext defaults.
 3 Notext +itTopedge w!      \ I can either make my own numbers
 20 Help?text +itTopedge w!  \ or let Intuition do it for me.
 10 Help?text +itleftedge w! \ I chose to do it My Way (sorry Frank)
 20 Badtext +itTopedge w!
 10 Badtext +itleftedge w! 
 3 Starttext +itTopedge w!
 3 Stoptext +itTopedge w! ;

Variable Uwindow_pntr
Variable Cwindow_pntr

: Uwin_active ( -- )         \ make the Users window active
Uwindow_pntr @ Windowtofront
Uwindow_pntr @ !window
Uwindow_pntr @ activatewindow ;

: Cwin_active ( -- )         \ make Computers window the active one
Cwindow_pntr @ Windowtofront
Cwindow_pntr @ !window
Cwindow_pntr @ activatewindow ;

: Cleanup ( -- )             \ do when fCLOSEWINDOW detected
    Cwindow_pntr @ Clearmenustrip
    Cwindow_pntr @ CloseWindow
    Uwindow_pntr @ ClearMenuStrip
    Uwindow_pntr @ CloseWindow
    CurrentScreen @ CloseScreen ginit ;

: goodbye ( -- )             \ bye if executing turnkey, abort if not
       ?turnkey  if bye else abort then ;
hex

: ITEMNUM ( n --  n )        \ convert menu selection to number
 -5 scale 03f and ;

: SUBNUM ( n -- n )          \ convert for submenu #
    -0b scale 01f and ;

: MENUNUM ( n -- n )         \ which menu ?
 01f and ;

: menu# thisevent +eCode w@ ;

: whichmenu menu# MENUNUM ;

: whichitem menu# ITEMNUM ;

: whichsubmenu menu# SUBNUM ;

: Mstate ( --  Mstate )      \ get the state of the left mouse button
 Thisevent +ecode w@ ;

decimal
  
: Print.text ( x y addr count  -- )     \ output text directly to window
 2swap xform.array
 xlate moveto rport !a1 !d0 !a0 graphics 10 ;     \ 10 is text

( ====================================================================== )
( =                    Menu respones                                   = )
( ====================================================================== )

Variable Soundon 1 Soundon !

: Turn_on_Sound ( -- )       \ Make some noise
 1 Soundon ! ;

: Turn_Sound_off ( -- )      \ Be Quiet ! Shhhh.
 0 Soundon ! ;

: get_mouse_click ( -- )     \ wait for a mouse button event
Begin
 getevent dup
 MOUSEBUTTONS = Mstate SELECTUP = and swap fCLOSEWINDOW = |
 pause
until ;

Variable Savewn

: About.prog ( -- )    \ User wants to know more about the author. Flatterer!

Currentwindow @ Savewn !     \ save pointer to old window
0" About Battleship! " Awin +nwTitle !
Currentscreen @ Awin +nwscreen !      \ connect window to current screen
Awin Openwindow
20 10 " Program written by Steve Berry." count Print.text
20 20 " This was written as an exercize in Intuition." count Print.text
20 30 " Also as a get-re-aqquainted-with Forth session." count
 Print.text
20 40 " Date 2/28/88   V1.5   ---------   CSI Multi-Forth"
 count Print.text 
20 50 " Address any complaints or bugs/enhanchments to: " count print.text
40 65 " Stephen Berry " count print.text
40 75 " CIS [71561,276] " count print.text
40 85 " ( unless your name is Tom - then don't bother ) " count print.text 
20 100 " To exit back to Game - Press left button in window " count print.text 
get_mouse_click
Currentwindow @ closewindow
Savewn @ !window ;

: Help.prog ( -- )            \ User needs some help.

Currentwindow @ Savewn !      \ save pointer to old window
0" Help for Battleship! " Awin +nwTitle !
Currentscreen @ Awin +nwscreen !      \ connect window to current screen
Awin Openwindow               \ open it up
30 50 " I KNEW You needed Help Tom ! " count print.text
50 delay
clr.window
5 10 " The object of the game is to sink :" count Print.text
20 20 " 1 - AircraftCarrier    2 - Battleships " count Print.text
20 30 " 3 - Submarines         4 - Destroyers" count Print.text
5 40 " Each of the ships has AT LEAST 2 pieces to it." count Print.text 
5 50 " The actual number of pieces for each ship is:" count print.text
20 60 " AircraftCarrier - 5   Battleships - 4" count print.text
20 70 " Submarines - 3         Destroyers - 2" count print.text
5 80 " Each SHIP can be oriented horizontally or vertically" count print.text 
5 90 " The next few screens contain some examples." count print.text 
5 100 " Press left mouse button in window or gadget." count print.text 
get_mouse_click
clr.window
5 10 " To sink a Battleship you must hit ALL FOUR of it's" count print.text
5 20 " pieces!" count print.text
92 20 do rport battle.image 200 I Drawimage 18 +loop
5 100 " Press left mouse button in window or gadget." count print.text 
get_mouse_click
clr.window
5 10 " Or the Battleship could look like this:" count print.text
266 10 do rport battle.image I 50 Drawimage 64 +loop
5 100 " Press left mouse button in window or gadget." count print.text 
get_mouse_click
clr.window
5 10 " The pieces look like this: " count print.text
5 30 " Aircraft-Carrier : " count print.text
rport air.image 200 20 Drawimage 
5 50 " Battleship : " count print.text
rport battle.image 200 40 Drawimage 
5 70 " Submarine : " count print.text
rport s.image 200 60 Drawimage 
5 90 " Destroyer : " count print.text
rport dest.image 200 80 Drawimage 
5 105 " Press left mouse button in window or gadget." count print.text 
get_mouse_click
clr.window
5 10 " When starting the game you must enter in the positions" count
print.text
5 20 " of YOUR ships. You do this by simply pressing the mouse" count
print.text
5 30 " button to where you want the piece to go. The computer" count
print.text
5 40 " starts by placing the Aircraft-carrier first, then the" count
print.text
5 50 " Battleships (remember there are two Battleships!) and" count
print.text
10 60 " so on. If you make a mistake, finish entering the" count
print.text
5 70 " ships first, and then select New Game from the menu." count
print.text
5 80 " First person (or Amiga) to sink all the ships - WINS!" count
print.text
30 90 "  GOOD LUCK !!!!!!" count print.text
5 100 " Press left mouse button in window or gadget." count print.text 
get_mouse_click
clr.window
30 50 " Was that too COM-PLI-CA-TED for you Tom?" count print.text
50 delay
Currentwindow @ closewindow 
Savewn @ !window ;

: Who_is_Tom? ( -- )    \ So you wanna know about Tom eh?

Currentwindow @ Savewn !     \ save pointer to old window
0" About Tom! " Awin +nwTitle !
Currentscreen @ Awin +nwscreen !      \ connect window to current screen
Awin Openwindow
20 20 " So  you think  you want to know  who Tom is?" count print.text
20 30 " If you  knew him,  you'ud  run  and  hide at" count Print.text
20 40 " the  sound  of  his  name.  Little  children" count Print.text
20 50 " SCREAM and CRY for their mother  when  he is" count Print.text 
20 60 " around. He is the epitome of evil incarnated." count print.text
40 80 " So who is Tom?" count print.text
20 100 " To find out click the left mouse button." count print.text 
get_mouse_click
clr.window
20 55 " Tom is my Beta tester." count print.text
get_mouse_click
Currentwindow @ closewindow
Savewn @ !window ;

: change-colors ( -- )        \ change color palette for the game
 Viewaddress +vViewport @ dup
 0 0 0 15 setrgb4 dup         \ color reg 0 - lt blue
 1 2 2 8 setrgb4 dup          \ color reg 1 - dk blue
 2 0 0 0 setrgb4 dup          \ color 2 - black
 3 10 10 10 setrgb4 dup       \ color 3 - lt grey
 4 6 6 6 setrgb4 dup          \ color 4 - dk grey
 5 15 0 0 setrgb4 dup         \ color 5 - red
 6 15 13 0 setrgb4            \ color 6 - yellow
 7 15 15 15 setrgb4           \ color 7 - White
 ;

Variable seed 
@clock xor xor seed !
Variable rnd-1 
hex 7fffffff rnd-1 !          \ largest pos num
ffffffff Constant big         \ basicly -1
decimal
Variable Start
Variable End
10 10 4 2array grid           \ array for Computers ships 
10 10 4 2array gridU          \ Users array ( the computer fires into here )

: rnd ( -- rnd# )      \ generates a random number from the seed given by
                       \ the current system time ( kinda).
 rnd-1 @ 0= if seed @ rnd-1 ! then
 rnd-1 @ 16807 big */mod drop dup rnd-1 ! ;

: rand ( -- )                 \ generate a random number from 0 to 9
 rnd big 11 */mod drop abs ;

: randnum ( -- )              \ get a random, but filter out num's > 9
0
Begin
 drop
 rand dup 10 <
until ;
 
: ?empty grid @ 0= ; ( x y -- f )  \ is x y empty ?

: ?emptyU gridU @ ( x y -- f )     \ is x y empty for gridU ? 
1 = not ; 

: ?check ( -- x y )           \ get an x and y of matrice  that is not used
0 0
Begin
 2drop
 randnum randnum 2dup
 ?empty
until ;

Variable x Variable y
Variable gStart Variable gEnd

: ?Getrange ( h/v size -- f ) \ look for free space in matrice of size
1-                            \ in horiz or vert orientation.
Locals| size h/v | 
h/v if                        \ find start & end points on a line
 x @ size - 0< if
  0 gstart ! size gend ! 
 else
 x @ size - dup gstart !
 size + gend !
 then
else
 y @ size - 0< if
  0 gstart ! size gend !
 else
 y @ size - dup gstart !
 size + gend !
 then
then
                             \ now check gstart thru end to be empty
0                            \ in matrice. return a flag reflecting result.
gend @ 1+ gstart @ do
 h/v if I y @
 else x @ I then
 grid @ |
loop
not ;

: put-ship ( size num -- )   \ place ship of given size in array - randomly
 Locals| num size |
 rand 5 > if                 \ pick horizontal orientation
 Begin
  ?check y ! x !   
  1 size ?getrange
 until
 gend @ 1+ gstart @ do
  num I y @ grid ! 
 loop
 else
 Begin
  ?check y ! x !
  0 size ?getrange
 until
 gend @ 1+ gstart @ do
  num x @ I grid ! 
 loop
then ;


: print-screen ( -- )         \ using matrice print graphics to screen
 10 0 do
  10 0 do
  j i grid @ case
  2 5 range.of rport dest.image i 64 * j 18 * drawimage
    endof
  6 8 range.of rport s.image i 64 * j 18 * drawimage
    endof   
  9 10 range.of rport battle.image i 64 * j 18 * drawimage
    endof
  11 of rport air.image i 64 * j 18 * drawimage
    endof
    endcase
  loop
 loop ;
 
( ===================================================================== )
( =                     Mouse coordinates & stuff                     = )
( ===================================================================== )


: getxy ( -- rport x y )      \ find mouse position in matrice
rport Thisevent +eMousey w@ 9 - 18 /  \ don't allow divide by zero
 Thisevent +eMousex w@ 1+ 64 / ;

: bombsound ( -- )            \ give me a whistle!
2 play 2 kill-sound ;

: hitsound ( -- )             \ sound when you get hit
soundon @ if
3 play 3 kill-sound
then ;

: ?oor ( x y -- f )           \ is x y out of range?
 locals| y x |
 x 0 < x 9 > | y 0 < | y 9 > | ;

: Draw_grid ( -- )
179 0 do 
 0 I Moveto                   \ draw horizontal grid lines
 639 I Drawto
 18 +loop
639 0 do
 I 0 Moveto                   \ same as above but with vertical.
 I 179 Drawto
 64 +loop ;

: sinksound ( -- )            \ sinking ship sounds go here
soundon @ if
1 play 1 kill-sound
then ;

: ?Sink ( x y -- )            \ Check if the ship has sunk.
2dup grid @ 
Locals| snum y x |
1 x y grid !                  \ sink the piece ...
0
10 0 do 
 10 0 do
  j i grid @ snum = if 1+ then
 loop
loop
0= if 
 snum case
 2 5 range.of 40 186 " You sunk a Destroyer ! " count print.text
  sinksound endof
 6 8 range.of 40 186 " You sunk a Submarine ! " count print.text
  sinksound endof
 9 10 range.of 40 186 " You sunk a Battleship! " count print.text
  sinksound endof
 11 of 40 186 " You sunk a Carrier !!!   " count print.text
  sinksound endof
 endcase
then ;

Variable Lastx Variable Newx 0 Newx ! 0 Lastx !
Variable Lasty Variable Newy 0 Newy ! 0 Lasty !

: ?SinkU ( x y -- )           \ Check if the Users ship has sunk.
2dup gridU @ 
Locals| snum y x |
1 x y gridU !                 \ sink the piece ...
x Lastx ! y Lasty !
0
10 0 do 
 10 0 do
  j i gridU @ snum = if 1+ then
 loop
loop
0= if 
 -1 lastx ! -1 lasty !
 snum case
 2 5 range.of 40 186 " I sunk YOUR Destroyer ! " count print.text
  sinksound endof
 6 8 range.of 40 186 " I sunk YOUR Submarine ! " count print.text
  sinksound endof
 9 10 range.of 40 186 " I sunk YOUR Battleship! " count print.text
  sinksound endof
 11 of 40 186 " I sunk YOUR Carrier !!!   " count print.text
  sinksound endof
 endcase
then ;

Variable HitsU
Variable Hits
Variable Temp-count 0 Temp-count !
Variable Temp-index 0 Temp-index !
Variable Temp-x -1 Temp-x !
Variable Temp-y -1 Temp-y !

: no_bad_move ( x y -- )      \ make sure the computer doesn't waste a 
locals| y x |                 \ shot in a dead end (lonely piece).
  0 temp-count !
  2 -1 do
   2 -1 do
    j -1 = i 0 = and j 0 = i -1 = and |
    j 0 = i 1 = and j 1 = i 0 = and | |
    if x j + y i+ ?oor not if x j + y i+ gridU @ 1 = not if 1 temp-count ! 
     x j + temp-x ! y i+ temp-y ! then then then
   loop
  loop ;

: randcomp ( -- x y )         \ get a random empty x y for gridU
                              \ First check if there is only one piece
                              \ of a ship left, and it's not a destroyer.
                              \ if there is ... sink the sucker.
12 6 do
 0 temp-count !
 i temp-index !
 10 0 do
  10 0 do
   j i gridU @
   temp-index @ = if temp-count @ 1+ temp-count !
   j Temp-x ! i Temp-y ! then
  loop
 loop
 temp-count @ 1 = if leave then
loop

temp-count @ 1 = if temp-x @ temp-y @ 
else
 0 0 
 Begin
  2drop
  randnum randnum
  2dup ?emptyU if
  2dup  no_bad_move
  temp-count @ if 2drop temp-x @ temp-y @ true else false then
  else false then
 until
then ;

: Placeum ( Ship_image numbr -- )  \ here we set up the Uwin with the user
                                   \ ships
getxy
Locals| y x rprt numbr Ship_image |
soundon @ if 2 play 2 kill-sound then 
rprt Ship_image y 64 * x 18 * Drawimage
numbr x y gridU ! ;

hex 68 Constant MDOWN 
    e8 Constant MUP decimal        \ mouse up & down IDCMPF

: setup-array ( -- )               \ zeros out current arrays
@clock xor xor seed !              \ also reset random # seed
10 0
 do 10 0
  do
   0 j i grid !
   0 j i gridU !
  loop
 loop ;

: Startup-sequence ( -- )          \ Init pointers for run time 
 0 play 0 kill-sound
 initext$ initpntrs ginit setup-array 
 0 hitsU !
 0 hits !
 5 11 put-ship
 2 0 do 4 9 I+ put-ship loop
 3 0 do 3 6 I+ put-ship loop
 4 0 do 2 2 I+ put-ship loop ;

: Get_mouse_click_empty ( -- ) 
Begin
 Get_mouse_click
 getxy
 gridU @ swap drop 0= not if
  soundon @ if
   30 5 beep then
  0 else
 1 then
until ;

: User_setup ( -- )           \ set up the Users ships in the array

Currentwindow @ Help?text Yestext Notext 0 0 400 100 AutoRequest 
                              \ requestor for the help menus. 
if
 Help.prog
then

5 0 do                        \ now put the ships in the
    20 186 " Please place the Aircraft-Carrier piece #   on the board"
    count print.text
    350 186 1 I+ <# # #> print.text
    Get_mouse_click_empty     \ array
    air.image 11 Placeum
loop

2 0 do
    4 0 do                    \ Battleships here
      20 186 " Please place Battleship( ) piece #   on the board       "
      count print.text
      300 186 1 I+ <# # #> print.text
      212 186 1 j + <# # #> print.text
      Get_mouse_click_empty
      Battle.image 9 j + Placeum
    loop
loop

3 0 do
    3 0 do                    \ Submarines
      20 186 " Please place Submarine( ) piece #   on the board        "
      count print.text
      290 186 1 I+ <# # #> print.text
      204 186 1 j + <# # #> print.text
      Get_mouse_click_empty
      s.image 6 j + Placeum
    loop
loop

4 0 do
    2 0 do                    \ Destroyers
      20 186 " Please place Destroyer( ) piece #   on the board        "
      count print.text
      290 186 1 I+ <# # #> print.text
      204 186 1 j + <# # #> print.text
      Get_mouse_click_empty
      dest.image 2 j + Placeum
    loop
loop
20 186 "                                                        "
count print.text
clr.window Cwin_active ;

: restart ( -- )        \ start the game over -- but first show the user the 
                        \ old screen and clean things up some.
Cwin_active
print-screen
20 186 "    This is where everything was !                   " count print.text 
200 delay 
20 186 " *** Press the left mouse button to continue ****    " count print.text 
get_mouse_click
clr.window startup-sequence draw_grid 
Uwin_active clr.window draw_grid User_setup ;

: Saiyonara ( -- )      \ say goodbye but give the user one last chance.

Currentwindow @ Byetext Yestext Notext 0 0 300 65 AutoRequest 
                        \ a simple requestor to quit. 
if                      \ the asshole says he wants to leave.
 Cleanup goodbye
then ;

: do.menu ( -- )        \ Find out what the User has asked us to do.
whichmenu case 
 0 of whichitem 
  case
   0 of About.prog endof      \ About program menu
   1 of Saiyonara endof       \ Quit menu
  endcase 
 endof
 1 of whichitem 
  case
   0 of whichsubmenu case
    0 of Turn_Sound_off endof     \ Sound off
    1 of Turn_on_Sound endof      \ Sound on
   endcase endof
   1 of restart endof         \ New game
   2 of Help.prog endof       \ Help
  endcase 
 endof
 2 of Who_is_Tom? endof       \ So Who is Tom anyway?
endcase ;

: sEvents   ( -- )            \ process IDCMP events
   GetEvent
   case
      fCLOSEWINDOW of  CleanUp goodbye endof
      MENUPICK  of  do.menu endof
   endcase ;


: Save_next ( x y -- )        \ save the position to fire next missle
locals| ly lx |
lx ly ?oor if exit then
lx ly gridU @ 1 = not
if lx newx ! ly newy ! then ;

: Kill_ship ( -- )            \ shoot the next piece of the ship
                              \ or get the next ramdom place
lastx @ 0 < not if
lastx @ newx ! lasty @ newy !
 2 -1 do
  2 -1 do
   
   j -1 = i 0 = and j 0 = i -1 = and |
   j 0 = i 1 = and j 1 = i 0 = and | |
   if lastx @ j + lasty @ i+ Save_next then
  loop
 loop

 lastx @ newx @ =
 lasty @ newy @ = and
 if randcomp -1 -1 lastx ! lasty !
 else newx @ newy @ then 
else randcomp -1 -1 lastx ! lasty ! then ;

: Comp_fire ( -- )            \ Ok - the computer gets a turn
Uwin_active
20 186 "                                    " count print.text
hits @ 30 = not if
 soundon @ if bombsound then
 Kill_ship
 Locals| y x |
 x y gridU @ case
  0 of rport water.image y 64 * x 18 * Drawimage 
  40 186 "                           " count print.text 
  1 x y gridU ! endof
  2 5 range.of rport dest.image y 64 * x 18 * Drawimage 
   hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  6 8 range.of rport s.image y 64 * x 18 * Drawimage 
   hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  9 10 range.of rport battle.image y 64 * x 18 * Drawimage 
   hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  11 of rport air.image y 64 * x 18 * Drawimage 
   hitsound x y ?sinkU hitsU @ 1+ hitsU ! endof
  endcase
 hitsU @ 30 = if 
  20 186 " Sorry I WIN !!!! Better luck next time !!!! " count print.text
  soundon @ if 5 play 5 kill-sound then
  3 0 do
   15 0 do Viewaddress +vViewport @ 0 0 0 I setrgb4 10 delay loop 
  loop
  then 
 150 0 do sEvents 1 delay loop
 Cwin_active 
then ;

: Fire ( -- )     \ Ok. player has fired a missle ... do sounds and images
getxy
locals| y x rprt |
x y grid @ 1 = not 
x y ?oor not and if
 soundon @ if bombsound then
 x y grid @ case
 0 of rprt water.image y 64 * x 18 * Drawimage 
 40 186 "                           " count print.text 
 1 x y grid ! endof
 2 5 range.of rprt dest.image y 64 * x 18 * Drawimage 
  hitsound x y ?sink hits @ 1+ hits ! endof
 6 8 range.of rprt s.image y 64 * x 18 * Drawimage 
  hitsound x y ?sink hits @ 1+ hits ! endof
 9 10 range.of rprt battle.image y 64 * x 18 * Drawimage 
  hitsound x y ?sink hits @ 1+ hits ! endof
 11 of rprt air.image y 64 * x 18 * Drawimage 
  hitsound x y ?sink hits @ 1+ hits ! endof
 endcase
hits @ 30 = if 
 20 186 " CONGRADULATIONS !!!! YOU WIN !!!!     " count print.text
 soundon @ if 4 play 4 kill-sound then
 3 0 do
  15 0 do Viewaddress +vViewport @ 0 0 0 I setrgb4 10 delay loop 
 loop
 then
 Comp_fire                    \ It's the computers turn
else soundon @ if 50 5 beep then 
then ;

: screenEvents   ( -- )       \  process IDCMP events
   GetEvent
   case
      fCLOSEWINDOW of  CleanUp goodbye endof
      MENUPICK  of  do.menu endof
      MOUSEBUTTONS of Mstate SELECTUP = 
           Hits @ 30 < HitsU @ 30 < AND AND if fire then endof
endcase  ;

: Error!         \ Somthing bad happened ... put up an auto-requester

Currentwindow @ Badtext Stoptext Starttext 0 0 400 100 AutoRequest 
if cleanup goodbye then
cleanup ;

: doit   ( -- )               \ this becomes the turnkey token

On.error Error! resume        \ Forth found an error!
                              \ let the user decide the next action
Startup-sequence
0" BattleShip! " Bscreen +nsDefaultTitle !
0" Battleship! " Cwin +nwTitle !
Bscreen OpenScreen  verifyscreen        \ open the screen
CurrentScreen @ Cwin +nwScreen !        \ store screen ptr in window
Cwin OpenWindow verifywindow            \ open the window
currentwindow @ dup Project SetMenuStrip       \ Attach menu to screen
Cwindow_pntr !                                 \ save the windows pointer

ginit                                   \ must initialize csigraphics
change-colors                           \ set up the screen colors 
clr.window
Draw_grid

0" Battleship!  Your ships go here ! " Uwin +nwTitle !  
                                        \ open window for Users ships
CurrentScreen @ Uwin +nwScreen !        \ store screen ptr in window
Uwin OpenWindow verifywindow            \ open the window
Currentwindow @ dup Project SetMenuStrip       \ Attach menu to screen
Uwindow_pntr !                          \ save the windows pointer
Draw_grid

User_setup

Begin pause                            \ Main poling loop
     Screenevents
again  ;                               \ do it "forever"