home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
120.lha
/
BattleShip
/
Battle.4th
< prev
next >
Wrap
Text File
|
1986-11-20
|
45KB
|
1,298 lines
\ 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.
\
\ Version 1.6 - More smarter Computer moves! (Although it can't be too
\ smart considering the author) Also a few bug fixes and I
\ prettied up the display some.
\
\ 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. (Really!)
Anew Battleship
decimal
Include IFF-sound.f \ Load in the sound words
200 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 3 bit planes
struct NewScreen Bscreen \ Tell Intuition what the screen looks like
Bscreen InitScreen \ copy default values to new screen
645 Bscreen +nsWidth w!
205 Bscreen +nsHeight w!
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!
645 Cwin +nwWidth w!
205 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!
645 Uwin +nwWidth w!
205 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.6 --------- 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] or GEinie XTH62381 under RAZ " 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
VBeamPos 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 /
0 9 range not if 9 > if 9 else 0 then then
Thisevent +eMousex w@ 1+ 64 /
0 9 range not if 9 > if 9 else 0 then then ;
: 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 ( -- )
181 0 do
0 I Moveto \ draw horizontal grid lines
640 I Drawto
18 +loop
641 0 do
I 0 Moveto \ same as above but with vertical.
I 180 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 188 " You sunk MY Destroyer ! " count print.text
sinksound endof
6 8 range.of 40 188 " You sunk MY Submarine ! " count print.text
sinksound endof
9 10 range.of 40 188 " You sunk MY Battleship! " count print.text
sinksound endof
11 of 40 188 " You sunk MY Carrier !!! " count print.text
sinksound endof
endcase
then ;
Variable Lastx Variable Newx 0 Newx ! 0 Lastx !
Variable Lasty Variable Newy 0 Newy ! 0 Lasty !
4 4 1Array Past \ This array is for remembering past moves
Variable Orientation -1 Orientation !
0 Constant Horizon
1 Constant Vertical
: ?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 ! false 0 past !
snum case
2 5 range.of 40 188 " I sunk YOUR Destroyer ! " count print.text
sinksound endof
6 8 range.of 40 188 " I sunk YOUR Submarine ! " count print.text
sinksound endof
9 10 range.of 40 188 " I sunk YOUR Battleship! " count print.text
sinksound endof
11 of 40 188 " I sunk YOUR Carrier !!! " count print.text
sinksound endof
endcase
else \ Didn't sink it ... so remember it!
0 past @ true = snum 3 past @ = and if \ is there a past hit?
x 1 past @ = if Horizon Orientation ! then
y 2 past @ = if Vertical Orientation ! then
else
true 0 past ! x 1 past ! y 2 past ! snum 3 past !
then
then ;
\ ========================================================================
\ == This is the Computer's "Intelligence" section ==
\ ========================================================================
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 !
Variable Toggl 0 toggl !
Variable Stopit 0 stopit !
Variable BeforeX 0 BeforeX !
Variable BeforeY 1 BeforeY !
Variable Stack_depth 0 Stack_depth !
Variable Pass2 false Pass2 !
: (randnum) ( -- x y ) \ get a not so random number.
depth Stack_depth ! \ in fact this is a stratagy for increased
false stopit ! \ efficiency in covering the board
10 BeforeX @ do
10 BeforeY @ do
I 7 > If toggl @
case
0 of -1 BeforeY ! 1 toggl ! leave endof
1 of -2 BeforeY ! 0 toggl ! leave endof
endcase
BeforeX @ 1+ dup 9 > if drop 0 then BeforeX !
else
BeforeX @ BeforeY @ 2+ 2dup
?emptyU If true stopit ! 2dup leave then
BeforeY ! BeforeX !
then
2 +loop
stopit @ If leave then
loop
depth Stack_depth @ = if \ are we at the end of the array?
1 toggl !
-1 BeforeY !
-1 Orientation ! \ If so, reset to scan not played squares.
false 0 past ! \ This fixes a bug in the routine (the computer
0 BeforeX ! \ gets confused when a different ship -
true Pass2 !
Myself \ other than the current one - is hit)
then ; \ never thought i'd use a recursive call!
: 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 \ here we look through the array for a ship
10 0 do \ with just 1 piece left
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 \ now we are looking to get a randum #
Begin \ because the search failed
2drop
(randnum)
2dup ?emptyU if
Pass2 @ not if 2dup no_bad_move \ don't do anything dumb!
temp-count @ if true else false then
else true then \ exit with co-ordinates
else false then
until
then ;
: Save_next ( x y -- ) \ save the position to fire next missle
locals| ly lx |
lx ly ?oor if exit then
lx ly ?emptyU
if lx newx ! ly newy ! then ;
: Kill_ship ( -- ) \ shoot the next piece of the ship
\ or get the next random place
lastx @ 0 < not if
lastx @ newx ! lasty @ newy !
2 -1 do
2 -1 do
Orientation @ \ look around for a not played square
case
-1 of
j -1 = i 0 = and j 0 = i -1 = and |
j 0 = i 1 = and j 1 = i 0 = and | | endof
HORIZON of j 0 = endof
VERTICAL of i 0 = endof
endcase
if lastx @ j + lasty @ i+ Save_next then
loop
loop
lastx @ newx @ =
lasty @ newy @ = and
if randcomp -1 -1 lastx ! lasty ! -1 Orientation ! false 0 past !
else newx @ newy @ then
else randcomp -1 -1 lastx ! lasty ! -1 Orientation ! false 0 past ! then ;
( =================================================================== )
( == Miscellaneous startup and menu stuff = )
( =================================================================== )
: 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
VBeamPos 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 BeforeX ! -2 BeforeY !
0 toggl !
-1 Orientation ! false 0 past !
false Pass2 !
-1 -1 Lastx ! Lasty !
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 ( -- ) \ get the `Click the mouse button-
Begin \ to continue' event.
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 188 " Please place the Aircraft-Carrier piece # on the board"
count print.text
350 188 1 I+ <# # #> print.text
Get_mouse_click_empty \ array
air.image 11 Placeum
loop
2 0 do
4 0 do \ Battleships here
20 188 " Please place Battleship( ) piece # on the board "
count print.text
300 188 1 I+ <# # #> print.text
212 188 1 j + <# # #> print.text
Get_mouse_click_empty
Battle.image 9 j + Placeum
loop
loop
3 0 do
3 0 do \ Submarines
20 188 " Please place Submarine( ) piece # on the board "
count print.text
290 188 1 I+ <# # #> print.text
204 188 1 j + <# # #> print.text
Get_mouse_click_empty
s.image 6 j + Placeum
loop
loop
4 0 do
2 0 do \ Destroyers
20 188 " Please place Destroyer( ) piece # on the board "
count print.text
290 188 1 I+ <# # #> print.text
204 188 1 j + <# # #> print.text
Get_mouse_click_empty
dest.image 2 j + Placeum
loop
loop
20 188 " "
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 188 " This is where everything was ! " count print.text
200 delay
20 188 " *** 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 ;
: Comp_fire ( -- ) \ Ok - the computer gets a turn
Uwin_active
20 188 " " 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 188 " " count print.text
1 x y gridU ! false 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 188 " 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
then
150 0 do sEvents 1 delay loop
Cwin_active ;
: 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 188 " " 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 188 " 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 polling loop
Screenevents
again ; \ do it "forever"