rem Lecture Battleships 1.0d2
rem Daniel Beardsmore 2003
rem http://telcontar.net/Misc/LBShips/
rem The program is public domain.

app LBShips, &200033EF
	icon "app-32-icon.mbm"
	icon "app-32-mask.mbm"
	icon "app-24-icon.mbm"
	icon "app-24-mask.mbm"
	icon "app-48-icon.mbm"
	icon "app-48-mask.mbm"
enda

rem include "const.oph"
const KFontArialNormal11& = 268435955
const KFontCourierNormal11& = 268436066
const KFontSquashed& = 268435701

const KVersion$ = "1.0d2"

const KShip% = 2
rem {KClear% = 1} set later
const KShipRecLen% = 3

const KNotInGrid% = 0
const KInGrid% = 1

const KShipBtnWidth% = 84
const KDirBtnWidth% = 42
const KShipBtnLeft% = 175
const KDirBtnLeft% = 264
const KShipBtnRight% = 258
const KDirBtnRight% = 305

const KCheckForShip% = 0
const KSetShip% = 1
const KClearShip% = 2

const KPegExists% = -1
const KPegPlaced% = 0
const KHit% = 1
const KMiss% = 2

rem values of KSetup%/KTurn% are used for specifying the
rem grid side (1 or 2) to decode co-ordinates to
const KSetup% = 1
const KTurn% = 2
const KBoardHidden% = 3
const KWon% = 7
const KNew% = 8
const KClosing% = 9
const KSetupSideSw% = -1

const KClear% = 1
const KMark% = 2
const KUnset% = 3

PROC LBShips:
	loadm "Z:\System\Opl\Toolbar.opo"
	TBarLink:("init")
ENDP

PROC init:
	global gShipLengths%(5), gShipNames$(5, 16)
	global gGrids%(200), gFleet%(30), gCount%(2)
	global gState%, gWIds%(2)
	global gXOffsets%(2), gFOffsets%(2)
	
	global KCRLF$(2), KBTTurn$(10)
	
	local i%
	
	KCRLF$ = chr$(13) + chr$(10)
	KBTTurn$ = "Take" + KCRLF$ + "Turn"
	
	gXOffsets%(1) = 3 : gXOffsets%(2) = KShipBtnLeft%
	gFOffsets%(1) = 1 : gFOffsets%(2) = 16
	
	gShipNames$(1) = "cruiser" :gShipLengths%(1) = 2
	gShipNames$(2) = "destroyer" :gShipLengths%(2) = 3
	gShipNames$(3) = "submarine" :gShipLengths%(3) = 3
	gShipNames$(4) = "battleship" :gShipLengths%(4) = 4
	gShipNames$(5) = "aircraft carrier" :gShipLengths%(5) = 5
	
	TBarInit:("LBShips", gWidth, 126)
	TBarShow:
	TBarButt:("e", 2, "Exit", 0, &0, &0, 0)
	
	rem Create game windows
	gWIds%(1) = gCreate(0, 0, gWidth - TBWidth%, gHeight, 0, 1)
	gWIds%(2) = gCreate(0, 0, gWidth, gHeight, 0, 1)
	
	reset:(1)
	
	gState% = KSetup% :evtLoop:
ENDP

PROC evtLoop:
	global gSide%, gBtnTrackID%, gLastMenu%
	local ev&(16), turnResult%, x%, y%, pos%
	local oldX%, oldY%, ptrLoc%, currShip%, currOrient%
	local dragdX%, dragdY%
	
	gSide% = 1 :currShip% = 1 :currOrient% = 0
	
	rem Loop until user closes app
	while not (gState% = KClosing%)
		rem Handle transient modes before collecting event from OS
		if gState% = KSetupSideSw%
			rem Player 1 has clicked Accept fleet - switch visible side
			rem and return to set-up state
					
			drawButton:(currShip%, 0)
			
			currShip% = 1 :currOrient% = 0
			drawButton:(1, 1) :drawButton:(6, 1)
			
			gBtnTrackID% = 0
			
			rem Return to set-up state
			gState% = KSetup%
		
		elseif gState% = KNew%
			reset:(2) :gState% = KSetup%
			gSide% = 1 :currShip% = 1 :currOrient% = 0
			oldX% = 0 :oldY% = 0
			gBtnTrackID% = 0
		endif
	
		getevent32 ev&()
		rem Check for menu events
		if handleInputEvt:(ev&(1), ev&(4))
			continue
			
		rem Check for pointer events
		elseif ev&(1) = &408
			rem Offer pointer events to the toolbar
			if tbaroffer%:(ev&(3),ev&(4),ev&(6),ev&(7)) :continue :endif
			
			rem Utilise pointer event
			if gState% < KBoardHidden%
				rem Convert pointer co-ords to game co-ords
				ptrLoc% = getCoords%:(ev&(6), ev&(7), addr(x%), addr(y%), gState%)
				
				if gState% = KTurn%
					if ev&(4) = 0 and ptrLoc% = KInGrid%
						if doMove%:(x%, y%, oldX%, oldY%) = KPegPlaced%
							oldX% = x% :oldY% = y%
						endif
					endif
					
				elseif gState% = KSetup%
					if ptrLoc% = KInGrid%
						if ev&(4) = 0 rem on pen down, look for ship
							pos% = getLApos%:(gSide%, x%, y%)
							if not (gGrids%(pos%) = 0)
								rem Get 
								rem deselect current orientation button
								drawButton:(currOrient% + 6, 0)
								
								if gGrids%(pos%) = currShip%
									rem if reselecting current ship, ignore
								else
									rem deselect current ship button
									drawButton:(currShip%, 0)
									
									currShip% = gGrids%(pos%)
									pos% = gFOffsets%(gSide%) + ((currShip% - 1) * KShipRecLen%)
									currOrient% = gFleet%(pos% + 1)
									drawButton:(currShip%, 1)
								endif
								drawButton:(currOrient% + 6, 1)
							endif
						endif
						placeShip:(x%, y%, currShip%, currOrient%, ev&(4))
					else
						trackPtr:(ev&(4), ev&(6), ev&(7), addr(currShip%), addr(currOrient%))
					endif
				endif
			elseif gState% = KBoardHidden%
				rem gIPrint "Select to take your turn first", 2
				cmdG%:
			endif
		
		elseif ev&(1) = &404
			if getcmd$ = "X" :gState% = KClosing% :endif
		
		else
			rem giprint hex$(ev&(1)), 0
		endif
	endwh
ENDP

PROC drawSetup:
	local i%
	i% = 1: while i% <= 7
		drawButton:(i%, (i% = 1) or (i% = 6))
		i% = i% + 1
	endwh
ENDP

PROC drawButton:(pID%, pMode%)
	local width%, text$(16), localid%, x%

	gFont KFontSquashed& :gStyle 1
	if pID% < 6
		width% = KShipBtnWidth% :	x% =KShipBtnLeft%
		text$ = gShipNames$(pID%) :localid% = pID%
	else
		width% = KDirBtnWidth% :x% = KDirBtnLeft%
		if pID% = 6 :text$ = "across"
		else text$ = "down" :endif
		localid% = pID% - 5
	endif
	
	gAt x%, 3 + ((localid% - 1) * 28)	
	gButton text$, 2, width%, 25, abs(pMode%)
ENDP

PROC drawGrid:(pSide%)
	local i%
	
	gFont KFontCourierNormal11& :gColor 170, 170, 170 :gStyle 0
	
	i% = 2
	while i% <= 11
		rem vertical
		gAt gXOffsets%(pSide%) + (14 * i%), 3
		gLineby 0, 155
		
		rem horizontal
		gAt gXOffsets%(pSide%), 3 + (14 * i%)
		gLineby 155, 0
	
		i% = i% + 1
		if i% = 11 :gcolor 0, 0, 0 :endif
	endwh
		
	gAt gXOffsets%(pSide%), 17 : gLineby 0, 141
	gAt gXOffsets%(pSide%) + 14, 3 : gLineby 0, 155
	gAt gXOffsets%(pSide%) + 14, 3 : gLineby 141, 0
	gAt gXOffsets%(pSide%), 17 : gLineby 155, 0
		
	rem Text
	i% = 1
	while i% <= 10
		gAt gXOffsets%(pSide%) + 4, 14 + (i% * 14)
		gPrint chr$(64 + i%)
		gAt gXOffsets%(pSide%) + 4 + (i% * 14), 14
		gPrint chr$(47 + i%)
		i% = i% + 1
	endwh
ENDP

PROC getCoords%:(pInX&, pInY&, vpOutX&, vpOutY&, pSide%)
	if pInY& < 17 or pInY& > 156 :return KNotInGrid% :endif
	if pInX& < gXOffsets%(pSide%) + 14 :return KNotInGrid% :endif
	if pInX& > (gXOffsets%(pSide%) + 152) :return KNotInGrid% :endif
	
	pokeb vpOutX&, (pInX& - gXOffsets%(pSide%)) / 14
	pokeb vpOutY&, (pInY& - 3) / 14
	
	return KInGrid%
ENDP

PROC getLApos%:(pSide%, pX%, pY%)
	rem Converts (side, x, y) grid co-ordinates into a linear array
	rem pointer for the grids array
	
	return ((pSide% - 1) * 100) + ((pY% - 1) * 10) + pX%
ENDP

PROC getXYcvt:(pPos%, pSide%, vpX&, vpY&)
	local p%, y%
	
	p% = pPos% - ((pSide% - 1) * 100)
	y% = (p% - 1) / 10
			
	pokeb vpY&, y% + 1
	pokeb vpX&, p% - (10 * y%)
ENDP

PROC trackPtr:(pPtrEvt&, pX&, pY&, vpCurrShip&, vpCurrOrient&)
	local id%, type%
	
	rem See if pointer is over a button
	if pX& >= KShipBtnLeft% and pX& <= KShipBtnRight%
		rem pointer is in LH button column
		if pY& < 140 and (pY& - ((pY& / 28) * 28)) <= 25
			rem pointer over a LH button
			id% = (pY& / 28) + 1
		endif
	elseif pX& >= KDirBtnLeft% and pX& <= KDirBtnRight%
		rem pointer is in RH button column
		if pY& < 54 and (pY& - ((pY& / 28) * 28)) <= 25
			rem pointer over a RH button
			id% = (pY& / 28) + 6
		endif
	endif
	
	if pPtrEvt& = 0 :rem Pointer down
		if id% > 0
			gBtnTrackID% = id%
			drawButton:(id%, 1)
		endif
	
	elseif pPtrEvt& = 6 :rem Pointer drag
		if gBtnTrackID% > 0
			if id% = gBtnTrackID%
				drawButton:(gBtnTrackID%, 1)
			else
				drawButton:(gBtnTrackID%, 0)
			endif
		endif
		
	elseif pPtrEvt& = 1 :rem Pointer up
		if id% > 0 and id% = gBtnTrackID%
			if id% < 6
				drawButton:(peekb(vpCurrShip&), 0)
				pokeb vpCurrShip&, id%
				drawButton:(id%, 1)
			else
				drawButton:(peekb(vpCurrOrient&) + 6, 0)
				pokeb vpCurrOrient&, id% - 6
				drawButton:(id%, 1)
			endif
		endif
		gBtnTrackID% = 0
	endif
ENDP

PROC placeShip:(pX%, pY%, pType%, pOrient%, pPtrMode&)
	local pos%, p%, oldX%, oldY%, tX%, tY%
	
	tX% = pX%
	tY% = pY%
	
	rem Get fleet array index of current ship's position record
	p% = gFOffsets%(gSide%) + ((pType% - 1) * KShipRecLen%)
	
	rem Get grid array index of pointer (x, y) co-ords
	pos% = getLApos%:(gSide%, tX%, tY%)

	rem Check that ship has been placed at a new location compared
	rem to its recorded location
	if gFleet%(p%) = pos% :return :endif
	
	rem if dragging, try moving ship on-side
	if pPtrMode& > 0
		if pOrient% = 0
			if tX% + gShipLengths%(pType%) > 11
				tX% = 11 - gShipLengths%(pType%)
				pos% = getLApos%:(gSide%, tX%, tY%)
			endif
		else
			if tY% + gShipLengths%(pType%) > 11
				tY% = 11 - gShipLengths%(pType%)
				pos% = getLApos%:(gSide%, tX%, tY%)
			endif
		endif
	endif
	
	rem check that position is valid
	if pOrient% = 0 and (tX% + (gShipLengths%(pType%) - 1)) > 10
		if pPtrMode& = 0 :gIPrint "Off the side", 0 :endif :return
	elseif pOrient% = 1 and (tY% + (gShipLengths%(pType%) - 1)) > 10
		if pPtrMode& = 0 :gIPrint "Off the bottom", 0 :endif :return
	endif
	
	rem look for existing ships
	if gridSeq%:(pos%, pOrient%, pType%, KCheckForShip%)
		if pPtrMode& = 0 :gIPrint "Place taken", 0 :endif :return
	endif
	
	rem clear old ship pos if needed
	if gFleet%(p%) > 0
		gridSeq%:(gFleet%(p%), gFleet%(p% + 1), pType%, KClearShip%)
		getXYcvt:(gFleet%(p%), gSide%, addr(oldX%), addr(oldY%))
		drawShip:(oldX%, oldY%, pType%, gFleet%(p% + 1), KClear%)
	endif
	
	rem place ship
	gridSeq%:(pos%, pOrient%, pType%, KSetShip%)
	gFleet%(p%) = pos% :gFleet%(p% + 1) = pOrient%

	rem draw ship
	drawShip:(tX%, tY%, pType%, pOrient%, KShip%)
ENDP

PROC gridSeq%:(pPos%, pOrient%, pType%, pMode%)
	local i%, pos%
	
	pos% = pPos% :i% = 1 :while i% <= gShipLengths%(pType%)
		if pMode% = KCheckForShip%
			if gGrids%(pos%) > 0 and not (gGrids%(pos%) = pType%)
				return 1 :endif
		elseif pMode% = KSetShip%
			gGrids%(pos%) = pType%
		else
			gGrids%(pos%) = 0
		endif
		pos% = pos% + (pOrient% * 9) + 1 :i% = i% + 1
	endwh
ENDP

PROC doMove%:(pX%, pY%, pOldX%, pOldY%)
	local laPos%, moveType%, fapos%, n$(16)
	
	laPos% = getLApos%:(3 - gSide%, pX%, pY%)
	
	rem check that peg not already placed
	if gGrids%(laPos%) < 0 :return KPegExists% :endif
	
	rem remove marker on opponent's target grid
	if pOldX% > 0 and pOldY% > 0
		gUse gWIds%(3 - gSide%)
		setSquare:(2, pOldX%, pOldY%, KUnset%)
		gUse gWIds%(gSide%)
	endif
	
	rem determine hit or miss, display notification
	if gGrids%(laPos%) > 0
		moveType% = KHit%
				
		n$ = gShipNames$(gGrids%(laPos%))
		
		fapos% = gFOffsets%(gSide%) + ((gGrids%(laPos%) - 1) * KShipRecLen%) + 2
		gFleet%(fapos%) = gFleet%(fapos%) - 1
		if gFleet%(fapos%) = 0
			gCount%(gSide%) = gCount%(gSide%) - 1
			if gCount%(gSide%) = 0
				TBarButt:("n", 1, "New" + KCRLF$ + "Game", 0, &0, &0, 0)
				gIPrint "You win - hit and sunk " + n$, 2
				gState% = KWon%
			else
				gIPrint "Hit and sunk " + n$, 2
			endif
		else
			gIPrint "Hit on " + n$, 2
		endif
		
		gGrids%(laPos%) = 0 - gGrids%(laPos%)
	else
		moveType% = KMiss%
		gIPrint "Miss", 2
		gGrids%(laPos%) = -9
	endif
	
	rem show peg on target grid, remove marker from opponent's
	rem last move
	drawPeg:(2, pX%, pY%, moveType%)
	setSquare:(2, pX%, pY%, KMark%)
	if pOldX% > 0 and pOldY% > 0
		setSquare:(1, pOldX%, pOldY%, KUnset%)
	endif
	
	rem show move on opponent's fleet grid
	gUse gWIds%(3 - gSide%)
	drawPeg:(1, pX%, pY%, moveType%)
	setSquare:(1, pX%, pY%, KMark%)

	rem pause app to allow player to see action	
	lock on :pause 40 :lock off

	if gState% = KWon%
		gUse gWIds%(gSide%)
		if gSide% = 2 :gVisible off :gUse gWIds%(1) :gVisible on :endif
		gAt gXOffsets%(2), 3
		gCopy gWIds%(2), gXOffsets%(1), 3, 156, 156, 3
		rem gAt 345, 139 :gFill 135, 14, 1
		gTmode 3 :gAt 345, 150
		gFont KFontArialNormal11& :gColor 0, 0, 0 :gStyle 0
		gPrint "Player " + gen$(gSide%, 1) + " won."
		
	else
		rem hide window, switch sides
		gUse gWIds%(gSide%)
		gVisible off
		gSide% = 3 - gSide%
		rem gOrder gWIds%(gSide%), 1
		gUse gWIds%(gSide%)
		gState% = KBoardHidden%
	endif
		
	return KPegPlaced%
ENDP

PROC drawPeg:(pSide%, pCol%, pRow%, pType%)
	gAt gXOffsets%(pSide%) + (pCol% * 14) + 8, (pRow% * 14) + 11
	
	if pType% = KHit%
		gColor $50, $50, $50 :gCircle 4, 1
	else
		gColor $FF, $FF, $FF
		gCircle 4, 1 :gColor 0, 0, 0 :gCircle 4, 0
	endif
ENDP

PROC setSquare:(pSide%, pX%, pY%, pType%)
	gAt gXOffsets%(pSide%) + (14 * pX%), 3 + (14 * pY%)

	if pType% = KMark%
		gColor 0, 0, 0
		gLineby 14, 0 :gLineby 0, 14 :gLineby -14, 0 :gLineby 0, -14
		return
	endif
	
	if pY% = 1 :gColor 0, 0, 0 :else :gColor 170, 170, 170 :endif
	gLineby 14, 0
	
	if pX% = 10 :gColor 0, 0, 0 :else :gColor 170, 170, 170 :endif
	gLineby 0, 14
	
	if pY% = 10 :gColor 0, 0, 0 :else :gColor 170, 170, 170 :endif
	gLineby -14, 0
	
	if pX% = 1 :gColor 0, 0, 0 :else :gColor 170, 170, 170 :endif
	gLineby 0, -14
	
	if pType% = KClear%
		gMove 1, 1: gFill 13, 13, 1
	endif
ENDP

PROC drawShip:(pX%, pY%, pType%, pOrient%, pMode%)
	local i%

	if pMode% = KClear%
		i% = 0 :while i% <= gShipLengths%(pType%) - 1
			setSquare:(1, pX% + ((1 - pOrient%) * i%), pY% + (pOrient% * i%), KClear%)
			i% = i% + 1
		endwh
	else
		gAt gXOffsets%(1) + (14 * pX%) + 2, 5 + (14 * pY%)
		gColor 170, 170, 170
		gFill ((((1 - pOrient%) * (gShipLengths%(pType%) - 1)) + 1) * 14) - 3, (((pOrient% * (gShipLengths%(pType%) - 1)) + 1) * 14) - 3, 0
	endif
ENDP

PROC reset:(pLevel%)
	local i%

	if pLevel% = 2
		i% = 1 :while i% <= 200 :gGrids%(i%) = 0 :i% = i% + 1 :endwh
		i% = 1 :while i% <= 30 :gFleet%(i%) = 0 :i% = i% + 1 :endwh
		i% = 2 :while i% > 0
			gUse gWIds%(i%)
			gAt 0, 0 :gFill 480, 160, 1
			i% = i% - 1
		endwh
	endif
	
	i% = 2 :while i% > 0
		gCount%(i%) = 5
		gUse gWIds%(i%)
		drawgrid:(1) :drawSetup:
		gFont KFontArialNormal11& :gColor 0, 0, 0 :gStyle 0
		gAt 345, 150: gPrint "Player " + gen$(i%, 1)
		
		if i% = 2: gVisible off :else :gVisible on :endif
		
		i% = i% - 1
	endwh
	
	i% = 0 :while i% < 5
		gFleet%(gFOffsets%(1) + (i% * KShipRecLen%) + 2) = gShipLengths%(i% + 1)
		gFleet%(gFOffsets%(2) + (i% * KShipRecLen%) + 2) = gShipLengths%(i% + 1)
		i% = i% + 1
	endwh

	TBarButt:("f", 1, "Accept" + KCRLF$ + "Fleet", 0, &0, &0, 0)
ENDP

PROC handleInputEvt:(pEvtType&, pEvtArgs&)
	local code%
	
	if pEvtType& = &1036 or pEvtType& = &2710
		mInit
		mCard "File", "New game", -%n, "Close", %e
		mCard "Tools", "About LBShips…", %a
		lock on
		code% = menu(gLastMenu%)
		lock off
	
	elseif pEvtType& < &400 and pEvtArgs& = 4
		code% = pEvtType& + 64
	
	else
		return 0
	endif
	
	if code% > 0 and loc("anew", chr$(code%))
		@%("cmd" + chr$(code%)): 
	:endif
	
	return -1
ENDP

PROC confirm%:(pTitle$, pPrompt$)
	dInit pTitle$
	dText "", pPrompt$, 0
	dButtons "No", -(%n or $100 or $200), "Yes", (%y or $100 or $200)
	return (dialog = %y)
ENDP

PROC cmdE%:
	if confirm%:("Close", "Really close LBShips?")
		gState% = KClosing%
	endif
ENDP

PROC cmdN%:
	if gState% = KWon%
		gState% = KNew%
	elseif confirm%:("Confirm", "Really start new game?")
		gState% = KNew%
	endif
ENDP

PROC cmdF%:
	local i%
	
	i% = 1: while i% <= 5
		if gFleet%(gFOffsets%(gSide%) + ((i% - 1) * KShipRecLen%)) = 0
			gIPrint "Fleet set-up incomplete", 2
			return
		else
			i% = i% + 1
		endif
	endwh
	
	gAt gXOffsets%(2), 0
	gFill 156, 160, 1
	
	if gSide% = 1
		gVisible off :gUse gWIds%(2) :gVisible on :gSide% = 2
		gState% = KSetupSideSw%
		
	else
		gUse gWIds%(1) :drawGrid:(2)
		gUse gWIds%(2) :drawGrid:(2)
		gState% = KTurn%
		TBarButt:("g", 1, KBTTurn$, 0, &0, &0, 0)
		gIPrint "Commence play", 2
	endif
ENDP

PROC cmdG%:
	if gState% = KBoardHidden%
		gVisible on
		gState% = KTurn%
	elseif gState% = KTurn%
		gIPrint "Already waiting for move.", 2
	endif
ENDP

PROC cmdA%:
	dInit "About LBShips"
	dText "", "Lecture Battleships for the Revo " + KVersion$, 2
	dText "", "Daniel Beardsmore, 2003", 2
	dButtons "OK", 13 + 256
	dialog
ENDP

PROC cmdW%:
	local i%

	i% = 3 :while i% <= 30 :gFleet%(i%) = 1 :i% = i% + 3 :endwh
	gCount%(1) = 1 :gCount%(2) = 1
	giprint "Force-win activated.", 3
ENDP