Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
BER Approach 18032020
| Uploader: |  grindstone |
| Datum/Zeit: | 18.03.2020 16:13:02 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts BER Approach, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
Warnung: Es steht bereits eine neuere Version des Quelltexts zur Verfügung. Die hier vorliegende alte Version könnte Fehler enthalten, die in der neuen Version vielleicht ausgebessert wurden.
#Include "vbcompat.bi"
Const pi As Double = Acos(0)*2
Const _2pi As Double = Acos(0)*4
Const NMft As Integer = 6076 '1 NM = 6076 ft
#Define IMG_OUTLINE 0
#Define IMG_FILLED 8
#Define IMG_LTGREEN 0
#Define IMG_RED 16
#Define IMG_CYAN 32
#Define IMG_YELLOW 48
#Define FS_ACCELERATINGFORTAKEOFF -3
#Define FS_CLEAREDFORTAKEOFF -2
#Define FS_SCHEDULED -1
#Define FS_FLYING 0
#Define FS_CLEAREDFORLANDING 1
#Define FS_LANDING_HEADINGTORUNWAY 2
#Define FS_LANDING_CLOSER5NM 3
#Define FS_LANDING_CLOSER1_5NM 4
#Define FS_LANDING_THRESHOLD 5
#Define FS_LANDING_TOUCHDOWN 6
#Define FS_REMOVE 7
#Define FS_RESCHEDULE 8
#Define FS_EXIT 9 '16
#Define FS_BADEXIT 10 '17
#Define FSA_NOAPPROACH -1
#Define FSA_ABOVERUNWAY -2
Dim Shared As ULong black = RGB(0,0,0), _
white = RGB(255,255,255), _
darkgrey = RGB(100,100,100), _
midgrey = RGB(128,128,128), _
ltgrey = RGB(200,200,200), _
red = RGB(255,0,0), _
darkred = RGB(128,0,0), _
tran = RGB(255,0,255), _
ltgreen = RGB(100,255,100), _
green = RGB(0,255,0), _
darkgreen = RGB(0,128,0), _
yellow = RGB(255,255,100), _
darkyellow = RGB(180,180,80), _
cyan = RGB(0,255,255)
Type tFlag
pause : 1 As ULong
setup : 1 As ULong
restart : 1 As ULong
resum : 1 As ULong
fired : 1 As ULong
End Type
Dim Shared As tFlag flag 'global flags
Type tSetup
lvlName As String
maxPlanes As Integer
newPlaneGap As Double
helpturn : 2 As UByte
helpdest : 2 As UByte
helpmessage :3 As UByte
End Type
Dim Shared As tSetup lvl
Type tPolar
r As Double
phi As Double
End Type
Type tPosition
x As Double
y As Double
End Type
'basic arithmetic operations for tPosition
Operator + (p1 As tPosition, p2 As tPosition) As tPosition
Return Type<tPosition>(p1.x + p2.x, p1.y + p2.y)
End Operator
Operator - (p1 As tPosition, p2 As tPosition) As tPosition
Return Type<tPosition>(p1.x - p2.x, p1.y - p2.y)
End Operator
Operator * (p1 As tPosition, f As Double) As tPosition
Return Type<tPosition>(p1.x * f, p1.y * f)
End Operator
Operator / (p1 As tPosition, f As Double) As tPosition
Return Type<tPosition>(p1.x / f, p1.y / f)
End Operator
Operator = (p1 As tPosition, p2 As tPosition) As boolean
If (p1.x = p2.x) AndAlso (p1.y = p2.y) Then
Return TRUE
Else
Return FALSE
EndIf
End Operator
Operator <> (p1 As tPosition, p2 As tPosition) As boolean
Return IIf(p1 = p2, FALSE, TRUE)
End Operator
Type tMMcolors 'mouse menu colors
foreground As ULong
background As ULong
frame As ULong
foregroundhi As ULong
backgroundhi As ULong
framehi As ULong
Declare Property text(col As ULong)
Declare Property bgnd(col As ULong)
End Type
Property tMMcolors.text(col As ULong)
this.foreground = col
this.backgroundhi = col
this.frame = col
this.framehi = col
End Property
Property tMMcolors.bgnd(col As ULong)
this.foregroundhi = col
this.background = col
End Property
Enum
_N '360
_NE '045
_E '090
_SE '135
_S '180
_SW '225
_W '270
_NW '315
End Enum
Enum 'runway / slot types
_bidir = 1
_unidir
_slot
End Enum
Dim Shared As Integer radar_sc, grid 'in pixels
Dim Shared As Double NMperGrid 'grid / NMperGrid = pixel/NM
Dim Shared As Double scale 'feet/pixel
'1 ft = 0.3048m
'1 NM = 1852m = 6076 ft
'1 kt = 6076 ft/h = 1.69 ft/s
Dim Shared As Any Ptr planeImg(&b00111111) 'array of image buffer pointers
' |/||||__+45° clockwise (north = 0°)
' | |||___+90°
' | ||____+180°
' | |_____0 = outline 1 = filled
' |_______color: 00 = ltgreen 01 = red 10 = cyan 11 = yellow
Dim Shared As tPosition gridOffset(_N To _NW) 'array of grid offsets
Dim Shared As Double headingAngle(_N To ...) = {Atan2(-1, 0), _ '_N (up)
Atan2(-1, 1), _ '_NE
Atan2( 0, 1), _ '_E (right)
Atan2( 1, 1), _ '_SE
Atan2( 1, 0), _ '_S (down)
Atan2( 1,-1), _ '_SW
Atan2( 0,-1), _ '_W (left)
Atan2(-1,-1) } '_NW
Dim Shared As ZString*3 cardinalPoint(_N To ...) = {"N", "NE", "E", "SE", "S", "SW", "W", "NW"}
Dim Shared As ZString*4 cardinalDegree(_N To ...) = {"360", "045", "090", "135", "180", "225", "270", "315"}
Dim Shared As ZString*30 companyIdentifier(0 To ..., 1) = {{"DA", "Delta Airlines"}, _
{"LH", "Lufthansa"}, _
{"GW", "German Wings"}, _
{"AF", "Air France"}, _
{"AA", "American Airlines"}}
Dim Shared As String messageQueue, messageCallsign, message, firedReason
Dim Shared As tMMcolors scheduleColor, neutralColor, buttonColor, outScreenScheduleColor
Dim Shared As Double gameTime, refTime, sessionTime, sessionStartTime, totalDelay, messageTime
Dim Shared As Any Ptr bigFontWhite, bigFontRed, bigFontYellow, bigFontLtgreyT, midFontWhite
Declare Function zoomText(text As String, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Declare Sub drawZoomText(x As Integer, y As Integer, text As String, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255))
Declare Function turnImg(img As Any Ptr, d As String = "r") As Any Ptr
Declare Function fix2grid(ByRef p As tPosition) As tPosition
Declare Function pol2cart(pk As tPolar) As tPosition
Declare Function cart2pol(pof As tPosition = Type(0,0), pto As tPosition = Type(0,0)) As tPolar
Declare Function angle2cardinal(angle As Double) As Integer
Declare Sub setup(ByRef lvl As tSetup)
Declare Sub saveini(lvl As tSetup)
Declare Function getini(varName As String) As String
Declare Function getVar(file As String, varName As String) As String
Declare Function putVar OverLoad (file As String, varName As String, value As String) As Integer
Declare Function putVar (file As String, varName As String, value As Integer) As Integer
Declare Function putVar (file As String, varName As String, value As Double) As Integer
Declare Function createBigFont(firstChr As Integer, lastChr As Integer, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Declare Function createMidFont(firstChr As Integer, lastChr As Integer, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Declare Function outScreen(p As tPosition) As boolean
Declare Sub waitRelease
Declare Function mouseMenu(text As String, _
separator As String = "", _
xPos As Integer = 0, _
yPos As Integer = 0, _
colors As tMMcolors, _
mode As UByte = 0, _
buffer As Any Ptr = 0) As Integer
'------------------------------
Type tRunway
runwayType As Integer
inColor As ULong
outColor As ULong
sign As String
Union
beginRunway As tPosition 'reference position of runway
slotIn As tPosition 'reference position of slot
End Union
Union
endRunway As tPosition 'if runway
exitHeading As UByte 'if slot
End Union
timerem As Double
Union
bea As Integer 'if runway
signImg As Any Ptr 'if slot
End Union
lockIn : 1 As UByte
lockOut : 1 As UByte
highlightIn : 1 As UByte
highlightOut : 1 As UByte
Declare Property direction() As Double
Declare Property slotOut As tPosition
Declare Sub drawRunway
Declare Sub saveRunway(filenr As Integer)
Declare Sub loadRunway(filenr As Integer)
End Type
Property tRunway.direction() As Double
Dim As tPosition p
Dim As Integer sc_width, sc_height
ScreenInfo sc_width, sc_height
Select Case runwayType
Case _unidir, _bidir
p = endRunway - beginRunway
Return Atan2(p.y, p.x) 'runway direction angle
Case _slot
If slotIn.x < 10 Then 'left (western border)
exitHeading = _W
ElseIf slotIn.x > radar_sc - 10 Then 'right (eastern border)
exitHeading = _E
ElseIf slotIn.y < 10 Then 'top (northern border)
exitHeading = _N
ElseIf slotIn.y > radar_sc - 10 Then 'bottom (southern border)
exitHeading = _S
EndIf
Return headingAngle(exitHeading)
End Select
End Property
Property tRunway.slotOut As tPosition
Dim As tPosition p
p = slotIn
Select Case direction
Case headingAngle(_W) 'west
p.y -= grid
Case headingAngle(_E) 'east
p.y += grid
Case headingAngle(_N) 'north
p.x += grid
Case headingAngle(_S) 'south
p.x -= grid
End Select
Return fix2grid(p)
End Property
Sub tRunway.drawRunway
Dim As Integer dx, dy, w, h, f, sc_width, sc_height, sw, sh, tw, th, ch_width, ch_height, _
lockInOffsX, lockInOffsY, lockOutOffs
Dim As Any Ptr tmpImg
Dim As tPosition signpos
Select Case runwayType
Case _bidir
w = 5
Select Case direction
Case headingAngle(_N), headingAngle(_S) 'north, south
Line (beginRunway.x - w, beginRunway.y) - (endRunway.x + w, endRunway.y), black, bf
Line (beginRunway.x - w, beginRunway.y) - (endRunway.x + w, endRunway.y), midgrey, b
Case headingAngle(_E), headingAngle(_W) 'east, west
Line (beginRunway.x, beginRunway.y - w) - (endRunway.x, endRunway.y + w), black, bf
Line (beginRunway.x, beginRunway.y - w) - (endRunway.x, endRunway.y + w), midgrey, b
End Select
Line (beginRunway.x, beginRunway.y) - (endRunway.x, endRunway.y), midgrey, , &b0000000011111111
Case _unidir
w = 5
Select Case direction
Case headingAngle(_N), headingAngle(_S) 'north, south
Line (beginRunway.x - w, beginRunway.y) - (endRunway.x + w, endRunway.y), black, bf
Line (beginRunway.x - w, beginRunway.y) - (endRunway.x + w, endRunway.y), midgrey, b
Draw String (beginRunway.x + w + 3, beginRunway.y - 8), sign, midgrey
Case headingAngle(_E), headingAngle(_W) 'east, west
Line (beginRunway.x, beginRunway.y - w) - (endRunway.x, endRunway.y + w), black, bf
Line (beginRunway.x, beginRunway.y - w) - (endRunway.x, endRunway.y + w), midgrey, b
Draw String (beginRunway.x, beginRunway.y + 10), sign, midgrey
End Select
Line (beginRunway.x, beginRunway.y) - (endRunway.x, endRunway.y), midgrey, , &b0000000011111111
'beaconing
If Timer > timerem Then
timerem = Timer + .1
bea = IIf(bea < 5, 60, bea - 5)
EndIf
For x As Integer = 5 To 40 Step 5
Dim As Integer b, bc = IIf(x = bea, yellow, midgrey)
Select Case direction
Case headingAngle(_N) 'north
b = beginRunway.y + x
PSet (beginRunway.x - 4, b), bc
PSet (beginRunway.x, b), bc
PSet (beginRunway.x + 4, b), bc
Case headingAngle(_E) 'east
b = beginRunway.x - x
PSet (b, beginRunway.y - 4), bc
PSet (b, beginRunway.y), bc
PSet (b, beginRunway.y + 4), bc
Case headingAngle(_S) 'south
b = beginRunway.y - x
PSet (beginRunway.x - 4, b), bc
PSet (beginRunway.x, b), bc
PSet (beginRunway.x + 4, b), bc
Case headingAngle(_W) 'west
b = beginRunway.x + x
PSet (b, beginRunway.y - 4), bc
PSet (b, beginRunway.y), bc
PSet (b, beginRunway.y + 4), bc
End Select
Next
Case _slot
direction 'asure exitHeading is set
ScreenInfo sc_width, sc_height
ImageInfo bigFontLtgreyT, ch_width, ch_height
ch_height -= 1 'character image height
ch_width = ch_height
ch_height -= 2 'real character height
sw = 60
sh = grid + 7
signImg = ImageCreate(sw, sh, tran)
Draw String signImg, (3,0), "<<<<", outColor
Draw String signImg, (3,grid), ">>>>", inColor
'sign
Select Case exitHeading
Case _W
Draw String signImg, (0, sh / 2 - ch_height / 2), sign,, bigFontLtgreyT
Case _E
tmpImg = turnImg(signImg, "r")
ImageDestroy signImg
signImg = tmpImg
tmpImg = turnImg(signImg, "r")
ImageDestroy signImg
signImg = tmpImg
Draw String signImg, (sw - Len(sign) * ch_width, sh / 2 - ch_height / 2), sign,, bigFontLtgreyT
Case _N
tmpImg = turnImg(signImg, "r")
ImageDestroy signImg
signImg = tmpImg
For x As Integer = 0 To Len(sign) - 1
Draw String signImg, (sh / 2 - ch_width / 2 + 3, x * (ch_height + 2) + 1), Chr(sign[x]),, bigFontLtgreyT
Next
Case _S
tmpImg = turnImg(signImg, "l")
ImageDestroy signImg
signImg = tmpImg
For x As Integer = 0 To Len(sign) - 1
Draw String signImg, (sh / 2 - ch_width / 2 + 3, (sh - Len(sign) * (ch_height + 2) + 3) + (x * (ch_height + 2) + 1)), Chr(sign[x]),, bigFontLtgreyT
Next
End Select
tmpImg = 0
'write slot image to screen
ImageInfo signImg, w, h
Select Case exitHeading
Case _W
Put (slotIn.x + 1, slotIn.y - grid - 3), signImg, Trans
Case _E
Put (slotIn.x - w - 1, slotIn.y - 3), signImg, Trans
Case _N
Put (slotIn.x - 3, slotIn.y + 1), signImg, Trans
Case _S
Put (slotIn.x - grid - 6, slotIn.y - h), signImg, Trans
End Select
'set lock signs
If lockIn Then
signpos = slotIn
Select Case exitHeading
Case _W
signpos.x += 15
Case _E
signpos.x -= 15
Case _N
signpos.y += 15
Case _S
signpos.y -= 15
End Select
Circle (signpos.x, signpos.y), 10, red,,,,F
Circle (signpos.x, signpos.y), 7, white,,,,F
EndIf
If lockOut Then
signpos = slotOut
Select Case exitHeading
Case _W
signpos.x += 15
Case _E
signpos.x -= 15
Case _N
signpos.y += 15
Case _S
signpos.y -= 15
End Select
Circle (signpos.x, signpos.y), 10, red,,,,F
Circle (signpos.x, signpos.y), 7, white,,,,F
EndIf
ImageDestroy signImg
signImg = 0
End Select
End Sub
Sub tRunway.saveRunway(filenr As Integer)
Print #filenr, "RUNWAY/SLOT"
Print #filenr, runwayType
Print #filenr, sign
direction 'to set exitHeading
Select Case runwayType
Case _unidir, _bidir
Print #filenr, cardinalPoint(angle2cardinal(cart2pol(beginRunway, endRunway).phi)) 'heading
Print #filenr, Int((beginRunway.x / grid) + .5)
Print #filenr, Int((beginRunway.y / grid) + .5)
Print #filenr, cart2pol(beginRunway, endRunway).r / (grid / NMperGrid) 'runway length in NM
Case _slot
Print #filenr, cardinalPoint(exitHeading)
Select Case exitHeading
Case _N, _S
Print #filenr, Int((slotIn.x / grid) + .5) 'grid points from left border
Case _E, _W
Print #filenr, Int((slotIn.y / grid) + .5) 'grid points from top
End Select
End Select
End Sub
Sub tRunway.loadRunway(filenr As Integer)
Dim As String card
Dim As Double rwlen
Dim As Integer hdg, sc_w, sc_h
ScreenInfo sc_w, sc_h
Input #filenr, runwayType
Line Input #filenr, sign
Line Input #filenr, card
Select Case runwayType
Case _unidir, _bidir
For hdg = LBound(cardinalPoint) To UBound(cardinalPoint)
If cardinalPoint(hdg) = card Then
Exit For
EndIf
Next
Input #filenr, beginRunway.x
Input #filenr, beginRunway.y
Input #filenr, rwlen
beginRunway = fix2grid(beginRunway * grid)
endRunway = beginRunway + pol2cart(Type<tPolar>(rwlen * (grid / NMperGrid), headingAngle(hdg)))
Case _slot
Select Case card
Case "N"
Input #filenr, slotIn.x
slotIn.x *= grid
slotIn.y = 0
Case "E"
Input #filenr, slotIn.y
slotIn.y *= grid
slotIn.x = radar_sc
Case "S"
Input #filenr, slotIn.x
slotIn.x *= grid
slotIn.y = radar_sc
Case "W"
Input #filenr, slotIn.y
slotIn.y *= grid
slotIn.x = 0
End Select
fix2grid(slotIn)
End Select
End Sub
ReDim Shared As tRunway runway(0)
'##########
Type tMark
heading : 3 As UByte
filled : 1 As UByte
colors : 2 As UByte
circ : 1 As UByte
End Type
Type tPlaneflag
conflict : 1 As UByte
crash : 1 As UByte
turn : 1 As UByte
tagStop : 1 As UByte
underCursor : 1 As UByte
getMessage : 2 As UByte
'takeoff : 1 As UByte
Union
Type
changeAltitude : 1 As UByte
changeSpeed : 1 As UByte
changeTurn : 1 As UByte
takeoff : 1 As UByte
End Type
changeAny : 4 As UByte
End Union
End Type
Type tPlane
callsign As String
origin As String
destination As String
position As tPosition
target As tPosition
xdisp As Integer
ydisp As Integer
tagDispx As Integer
tagDispy As Integer
tagDispBasex As Integer = 15 '10
tagDispBasey As Integer = -29 '-24
Union
selbuffer_ As Byte
selbuffer As tMark
End Union
altitude As Double 'ft
targetAltitude As Integer 'ft
messageAltitude As Integer 'ft
climbrate As Integer = 30 'ft/min
descendrate As Integer = 30 'ft/min
tagAltitude As String
direction As Double 'as angle
turn As String
messageTurn As String
speed As Double 'kt
targetSpeed As Integer 'kt
messageSpeed As Integer 'kt
maxSpeed As Integer = 450 'kt (450kt = 833 km/h) '(500kt = 910 km/h)
stallSpeed As Integer = 120 'kt (120kt = 222 km/h)
approachSpeed As Integer = 150 'kt (150kt = 278 km/h)
cruiseSpeed As Integer = 400 'kt (400kt = 740 km/h)
acceleration As Integer = 5 'kt/s
deceleration As Integer = 5 'kt/s
tagSpeed As String
timerem As Double
scheduledDepartureTime As Double
fuel As Double 'as time
messageLock As Double '= 2
Union
planeflags As UShort 'for saving / loading
planeflag As tPlaneflag
End Union
Union
mark_ As Byte
mark As tMark
End Union
flightstatus As Byte
runway_ As Byte
wheelrem As Integer
listColor As tMMcolors
comment As String
Static As Integer tagTop
Static As Integer tagBottom
Static As Integer tagLeft
Static As Integer tagRight
Static As tPlane plane() 'planes array
Declare Static Function create(org As Integer = 0) As boolean
Declare Sub operate(mode As Integer)
Declare Function checkApproach(runway As tRunway) As Integer
Declare Sub savePlane(filenr As Integer)
Declare Sub loadPlane(filenr As Integer)
End Type
'dim static variables
Static As Integer tPlane.tagTop = -29 '-24
Static As Integer tPlane.tagBottom = 29 '24
Static As Integer tPlane.tagLeft = -35 '-30
Static As Integer tPlane.tagRight = 15 '10
ReDim As tPlane tPlane.plane(0)
Function tPlane.create(org As Integer = 0) As boolean
Dim As Integer x, rwmax, pl, rw, dst, w, h, mx, my, wheel, buttons
'org = -1 --> ignore lock of random origin
rwmax = UBound(runway)
'runway / slot where to place the new plane
Select Case org
Case 0
Do
For x = 1 To 10 'try max 10 times (to prevent game deadlock if all slots are locked)
rw = Int(Rnd * rwmax) + 1
If runway(rw).lockIn = 0 Then
Exit Do 'unlocked slot found
EndIf
Next
Return FALSE 'no free slot
Loop
Case -1
rw = 1
Case Else
rw = org
If runway(rw).lockIn Then
Return FALSE 'desired slot is locked
EndIf
End Select
If (runway(rw).runwayType = _slot) AndAlso (org <> -1) Then
For pl = 1 To UBound(plane)
If (plane(pl).target = runway(rw).slotIn) AndAlso (outScreen(plane(pl).position) = TRUE) Then
Return FALSE 'another plane is currently approaching the entry point
EndIf
Next
EndIf
pl = UBound(plane) + 1 'index of new plane
ReDim Preserve plane(pl)
With plane(pl)
.origin = runway(rw).sign
GetMouse(mx,my,.wheelrem,buttons) 'get current mousewheel value
Do 'create a callsign
.callsign = companyIdentifier(Int(Rnd * UBound(companyIdentifier,1)), 0) + Str(Int(Rnd * 899) + 100)
For x = 1 To UBound(plane) 'check if callsign is unique
If x = pl Then 'skip own index
Continue For
Else
If plane(x).callsign = .callsign Then 'callsign already exists
Continue Do 'create another callsign
EndIf
EndIf
Next
Exit Do
Loop
.timerem = Timer
Select Case runway(rw).runwayType
Case _unidir, _bidir 'origin is a runway --> plane becomes scheduled
.position = runway(rw).beginRunway
.target = fix2grid(.position + pol2cart(Type<tPolar>(grid, runway(rw).direction)))
.direction = cart2pol(.position, .target).phi 'ttttttttttttt
.speed = 0
.targetspeed = 0
.targetaltitude = 0
.altitude = 0
.flightstatus = FS_SCHEDULED
Case _slot 'origin is a slot --> plane is entering the radar screen
runway(rw).direction
'place the plane outside the screen, heading to the entry point
.target = runway(rw).slotIn
.position = .target + gridOffset(runway(rw).exitHeading)
.direction = cart2pol(.position, .target).phi 'ttttttttttttt
.speed = .cruiseSpeed
.targetspeed = .cruiseSpeed
.targetaltitude = 5000
.altitude = 5000
.flightstatus = FS_FLYING
End Select
.scheduledDepartureTime = DateAdd("n", 3, gameTime) 'add 3 minutes 'add 2 minutes
Do 'get random flight destination
dst = Int(Rnd * rwmax) + 1
Loop While dst = rw 'repeat if destination = origin
.destination = runway(dst).sign
End With
Return TRUE
End Function
Sub tPlane.operate(mode As Integer)
Dim As Integer w, h, mx, my, wheel, buttons, x, index, chk, chk2, _
rw, chkApp, sc_width, sc_height, merken
Dim As ULong turnColor
Dim As String chk3, text
Dim As Double timediff, angle, runwayDirection, distance, delay
Dim As tPolar pol
Dim As tPosition p
Dim As tMMcolors tagColor, tagColorStd, tagColorConflict, tagColorMessage, tagColorMessageQueue
tagColorStd.text = ltgreen
tagColorStd.bgnd = black
tagColorConflict = tagColorStd
tagColorConflict.text = red
tagColorMessage = tagColorStd
tagColorMessage.text = yellow
tagColorMessageQueue = tagColorStd
tagColorMessageQueue.text = darkyellow
listColor = tagColorStd
listColor.text = darkgreen
Swap listColor.foregroundhi, listColor.backgroundhi
timediff = Timer - timerem
timerem = Timer
If flag.pause Or flag.setup Then 'game halted
Return
EndIf
index = (Cast(UInteger,@This) - Cast(UInteger,@tPlane.plane(0))) / SizeOf(tPlane) 'calculate the own index within the plane array
' | |_pointer to the beginning of the plane array
' |__________________________pointer to the actual plane
ScreenInfo sc_width, sc_height
'1 ft = 0,3048m
'1 NM = 1852m = 6076 ft
'1 kt = 6076 ft/h = 1,69 ft/s
'scale = 6076 / grid 'ft/px
'diff distance[ft] = speed[kt] * 1,69 ft/sec * timediff[s]
'diff distance[px] = (speed[kt] * 1,69 ft/sec * timediff[s]) / scale[ft/px]
pol = cart2pol(position, target) 'get the current direction angle
pol.r = (speed * 1.69 * timediff) / scale 'distance covered since the last call
position += pol2cart(pol) 'new position of the plane
If Abs(position.y) < .0000001 Then 'prevent flickering when plane is at top of screen
position.y = 0
EndIf
'ttttttttttttttt
'If index = 4 Then
' Locate 40, 1
' ? direction;" ";angle2cardinal(direction);" ";position.x;" ";position.y;';outScreen(position)
' 'Dim As Integer ff = FreeFile
' 'Open "e:\ber.txt" For Append As #ff
' 'Print #ff, position.x;" ";position.y;" ";mark.heading'cardinalDegree(mark.heading)
' 'Close #ff
'EndIf
'ttttttttttttt
Dim As Integer tst = Abs(angle2cardinal(direction) - angle2cardinal(pol.phi))
If (tst = 1) Or (tst = 7) Then 'prevent turning to the opposite direction
direction = pol.phi
Else
selbuffer.colors = 2
EndIf
'ttttttttttttttttt
'If index = 1 Then
' Locate 41,1
' ? direction;" ";angle2cardinal(direction)
'EndIf
'ttttttttttttt
mark.heading = angle2cardinal(direction)
'chkApp * scale / NMft --> distance in NM
'chkApp * scale --> distance in ft
chkApp = checkApproach(runway(runway_))
'##### compute flightstatus #####
If (flightstatus = FS_SCHEDULED) Then 'scheduled but not launched, not visible
ImageInfo planeImg(mark.heading), w, h
xdisp = position.x - w / 2
ydisp = position.y - h / 2
'calculate delay
If scheduledDepartureTime < gameTime Then
delay = gameTime - scheduledDepartureTime
totalDelay += delay
EndIf
'if ready for takeoff
If (planeflag.takeoff) And _
(InStr(messagequeue, callsign) = 0) And _
(messageCallsign <> callsign) Then
messagequeue += callsign 'add plane to message queue
EndIf
Select Case planeflag.getMessage
Case 0 'send takeoff order if plane is on the 1st place of the message queue and there's
' no message being sent at the moment
If (InStr(messageQueue, callsign) = 1) And (message = "") Then
messageQueue = Mid(messageQueue, Len(callsign) + 1) 'delete this plane from message queue
'##### generate takeoff message #####
messageCallsign = callsign
For c As Integer = LBound(companyIdentifier) To UBound(companyIdentifier)
If Left(callsign, 2) = companyIdentifier(c, 0) Then
message = companyIdentifier(c, 1) + " " + Mid(callsign, 3)
Exit For
EndIf
Next
messageTime = 1.5
If planeflag.takeoff Then
message += " Cleared for takeoff"
messageTime += 1.5
EndIf
messageTime += Timer
'##### end generate takeoff message #####
planeflag.getMessage = 1
EndIf
Exit Sub
Case 1 'set plane to be displayed
If messageTime < Timer Then
flightstatus = FS_CLEAREDFORTAKEOFF
EndIf
Exit Sub
End Select
'takeoff procedure
ElseIf (flightstatus = FS_CLEAREDFORTAKEOFF) Then 'cleared for takeoff
targetspeed = 250
planeflag.takeoff = 1
flightstatus = FS_ACCELERATINGFORTAKEOFF 'accelerating, still on the ground
ElseIf (flightstatus = FS_ACCELERATINGFORTAKEOFF) And (speed >= approachspeed) Then 'takeoff
targetaltitude = 1000
flightstatus = FS_FLYING 'flying
'landing procedure
ElseIf (flightstatus = FS_LANDING_TOUCHDOWN) AndAlso (altitude = 0) AndAlso (speed < 15) Then
If runway(runway_).sign = destination Then
flightstatus = FS_REMOVE 'phase 6 --> remove
Else 'wrong landing --> replace to schedule
position = runway(runway_).beginRunway
target = fix2grid(position + pol2cart(Type<tPolar>(grid, runway(runway_).direction)))
flightstatus = FS_RESCHEDULE
EndIf
ElseIf (flightstatus = FS_LANDING_THRESHOLD) AndAlso (altitude = 0) Then
targetspeed = 0
flightstatus = FS_LANDING_TOUCHDOWN 'phase 5 --> touchdown
ElseIf (flightstatus = FS_LANDING_CLOSER1_5NM) AndAlso _
(chkApp = FSA_ABOVERUNWAY) AndAlso _
(speed <= approachspeed) AndAlso _
(altitude <= 100) Then
targetaltitude = 0
flightstatus = FS_LANDING_THRESHOLD 'phase 4 --> crossing runway threshold
ElseIf (flightstatus = FS_LANDING_CLOSER5NM) AndAlso (chkApp > 0) AndAlso ((chkApp * scale / NMft) < 1.5) Then
targetspeed = IIf(targetspeed > approachspeed, approachspeed, targetspeed)
flightstatus = FS_LANDING_CLOSER1_5NM 'phase 3 --> closer than 1.5 NM
ElseIf (flightstatus = FS_LANDING_HEADINGTORUNWAY) AndAlso (chkApp > 0) AndAlso ((chkApp * scale / NMft) < 5) Then
targetspeed = IIf(targetspeed > 250, 250, targetspeed)
flightstatus = FS_LANDING_CLOSER5NM 'phase 2 --> closer than 5 NM
ElseIf flightstatus = FS_CLEAREDFORLANDING Then 'cleared for landing --> get the runway heading to
For rw = 1 To UBound(runway)
chkApp = checkApproach(runway(rw))
If (chkApp > 0) AndAlso (turn = "") Then 'heading to runway
flightstatus = FS_LANDING_HEADINGTORUNWAY 'phase 1 --> heading to the runway
runway_ = rw 'store runway
Exit For
EndIf
Next
ElseIf flightstatus = FS_FLYING Then
runway_ = 0
EndIf
Select Case flightstatus
Case FS_LANDING_CLOSER5NM, FS_LANDING_CLOSER1_5NM 'glide slope
If (chkApp > 0) And (targetaltitude > (chkApp * scale / 20)) Then
targetaltitude = (chkApp * scale / 20)
targetaltitude = IIf(targetaltitude < 100, 100, targetaltitude)
EndIf
End Select
'##### end compute flightstatus #####
'calculate altitude
If Abs(altitude - targetaltitude) < 1 Then
altitude = targetaltitude
ElseIf (altitude < targetaltitude) And (speed >= approachspeed) Then
altitude += timediff * climbrate
ElseIf altitude > targetaltitude Then
altitude -= timediff * IIf(flightstatus < FS_LANDING_THRESHOLD, descendrate, 5)
EndIf
'calculate speed
If Abs(speed - targetspeed) < 1 Then
speed = targetspeed
ElseIf speed < targetspeed Then
speed += timediff * acceleration
ElseIf speed > targetspeed Then
speed -= timediff * deceleration
EndIf
'check for conflict
planeflag.conflict = 0
For x = 1 To UBound(plane) 'all planes
If (x = index) OrElse (plane(x).flightstatus = FS_SCHEDULED) Then
Continue For 'skip if own index or plane not airborne
EndIf
distance = cart2pol(plane(x).position, plane(index).position).r
If distance < 2 * (grid / NMperGrid) And _ 'less than 2 NM
Abs(plane(x).altitude - plane(index).altitude) < 1000 Then
planeflag.conflict = 1
If distance < (150 / scale) AndAlso Abs(plane(x).altitude - plane(index).altitude) < 50 Then
planeflag.crash = 1 'crash
plane(x).planeflag.crash = 1
EndIf
EndIf
Next
chk3 = Str(flightstatus) + " " + Str(chkApp)
If (flightstatus > FS_LANDING_CLOSER1_5NM) And (chkApp = FSA_NOAPPROACH) Then
planeflag.conflict = 1
If (flightstatus > FS_LANDING_THRESHOLD) Then
planeflag.crash = 1 'crash
EndIf
EndIf
'arriving target position
'If cart2pol(target, position).r < .5 Then
If cart2pol(target, position).r <= .5 Then
position = target 'correct misalignment
Select Case Left(turn, 1)
Case "r" 'turn right
mark.heading += 1
turn = Mid(turn, 2) 'delete the first character from the turn string
Case "l" 'turn left
mark.heading -= 1
turn = Mid(turn, 2)
End Select
target += gridOffset(mark.heading) 'set next grid point in heading direction as new target
fix2grid(target) 'correct misalignment
EndIf
'##### check exit #####
If outScreen(target) Then
flightstatus = FS_BADEXIT 'preset
comment = "NOT AN EXIT POINT"
For x = 1 To UBound(runway) 'find index of destination slot
With runway(x)
If (.runwayType = _slot) AndAlso (cart2pol(position, .slotOut).r < 0.1) Then
comment = ""
Exit For
EndIf
End With
Next
If comment = "" Then 'regular exit point
With runway(x)
If (mark.heading <> .exitHeading) Then
comment = "WRONG HEADING (" + cardinalPoint(mark.heading) + ")"
ElseIf (destination <> .sign) Then
comment = "WRONG DESTINATION (" + destination + ")"
ElseIf (speed > 400) Then
comment = "SPEED TOO HIGH (" + Str(Int(speed)) + "kt)"
ElseIf (altitude <> 5000) Then
comment = "WRONG ALTITUDE (" + Str(Int(altitude)) + "ft)"
EndIf
End With
EndIf
If comment = "" Then 'regular exit
flightstatus = FS_EXIT
EndIf
EndIf
'##### end check exit #####
'##### update radar display position #####
ImageInfo planeImg(mark.heading), w, h 'get plane icon size
If mode And (planeflag.turn = 0) Then 'update radar display
xdisp = position.x - w / 2
ydisp = position.y - h / 2
'keep tag inside the radar display area
If xdisp < 40 Then 'left border
tagDispBasex = tagRight
If mark.heading = _W Then
tagDispBasey = tagTop
Else
tagDispBasey = tagBottom
EndIf
ElseIf xdisp > radar_sc - 70 Then 'right border
tagDispBasex = tagLeft
If mark.heading = _E Then
tagDispBasey = tagBottom
Else
tagDispBasey = tagTop
EndIf
EndIf
If ydisp < 30 Then 'top border
If mark.heading = _N Then
tagDispBasex = tagRight
Else
tagDispBasex = tagLeft
EndIf
tagDispBasey = tagBottom
ElseIf ydisp > radar_sc - 51 Then 'bottom border
If mark.heading = _S Then
tagDispBasex = tagLeft
Else
tagDispBasex = tagRight
EndIf
tagDispBasey = tagTop
EndIf
EndIf
'##### end update radar display position #####
If Not outScreen(position) Then 'display plane and tag
listColor = tagColorStd
Swap listColor.foregroundhi, listColor.backgroundhi
selbuffer_ = mark.heading 'get the correct plane icon
'test if cursor is touching the plane icon
GetMouse (mx,my,wheel,buttons)
If (Abs(position.x - mx) < 10) AndAlso _
(Abs(position.y - my) < 10) Then 'mouse cursor is touching the plane icon
selbuffer.filled = 1
planeflag.underCursor = 1
Else
planeflag.underCursor = 0
EndIf
'get plane icon color
If planeflag.conflict Then
selbuffer.colors = 1 'red
If Frac(Timer) > .5 Then 'flashing icon
selbuffer.filled = 1
EndIf
Else
selbuffer.colors = mark.colors 'selected color
'ttttttttttttt
'If index = 1 Then
' selbuffer.colors = 2
'EndIf
'ttttttttttttt
EndIf
If messageLock > Timer Then
selbuffer.filled = 1
EndIf
If planeflag.turn Then 'get the correct turning preview plane icon
If Left(messageTurn, 1) = "l" Then
selbuffer.heading = mark.heading - Len(messageTurn)
ElseIf Left(messageTurn, 1) = "r" Then
selbuffer.heading = mark.heading + Len(messageTurn)
EndIf
EndIf
Put (xdisp, ydisp), planeImg(selbuffer_), Trans 'draw plane icon
''--------- for testing-----------
'If Len(turn) Then
' mark.circ = 1
'Else
' mark.circ = 0
'EndIf
''---------------------------------
If mark.circ Then
For x As Integer = 10 To 14 Step 2
Circle (xdisp + 10, ydisp + 10), x, green 'red
'Circle (xdisp + 10, ydisp + 10), Int(Frac(Timer)*10) + 5, green 'red
Next
EndIf
'draw tag
listColor.foreground = ltgreen
If planeflag.tagStop = 0 Then 'set tag position relative to plane position
tagDispx = tagDispBasex + xdisp
tagDispx = IIf(tagDispx < 1, 1, tagDispx)
tagDispy = tagDispBasey + ydisp
tagDispy = IIf(tagDispy < 1, 1, tagDispy)
If planeflag.changeAltitude = 0 Then messageAltitude = targetAltitude
If planeflag.changeSpeed = 0 Then messageSpeed = targetSpeed
If planeflag.changeTurn = 0 Then messageTurn = turn
Else
listColor.foreground = white 'highlight list entry
EndIf
If planeflag.underCursor Then 'cursor is touching the plane icon
listColor.foreground = white 'highlight list entry
EndIf
'set tag color
tagColor = tagColorStd 'no conflict
If ((lvl.helpmessage = 1) And (planeflag.underCursor)) OrElse (lvl.helpmessage = 2) Then
If messageCallsign = callsign Then
tagColor = tagColorMessage
ElseIf InStr(messageQueue, callsign) Then
tagColor = tagColorMessageQueue
EndIf
EndIf
If planeflag.conflict And (Frac(Timer) > .5) Then 'flashing tag / list
listcolor.foreground = red
tagColor = tagColorConflict
EndIf
planeflag.tagStop = 0
'callsign / marking
Select Case mouseMenu(IIf(((lvl.helpdest = 1) And (planeflag.underCursor)) Or (lvl.helpdest = 2), _
destination, callsign),, tagDispx, tagDispy, tagColor)
Case 8
planeflag.tagStop = 1 'cursor touching tag --> avoid tag moving
Case 9
mark.colors += 1 'switch colors
planeflag.tagStop = 1
Case 10
mark.colors = 0 'reset to ltgreen
planeflag.tagStop = 1
End Select
'altitude
Select Case mouseMenu(tagAltitude,, 0, -8, tagColor)
Case 0 'display actual altitude
tagAltitude = Str(Int(altitude)) + " ft"
Case 8 'mousecursor touches item --> display target altitude
If flightstatus Then
tagAltitude = "LANDING "
Else
tagAltitude = Str(messageAltitude) + " ft"
EndIf
planeflag.tagStop = 1
Case 9 'left button --> increase target altitude
If messageAltitude < 6000 Then
messageAltitude += 1000
planeflag.changeAltitude = 1
EndIf
flightstatus = FS_FLYING
planeflag.tagStop = 1
Case 10 'right button --> decrease target altitude
If messageAltitude > 1000 Then
messageAltitude -= 1000
planeflag.changeAltitude = 1
Else
flightstatus = FS_CLEAREDFORLANDING
planeflag.changeAltitude = 1
EndIf
planeflag.tagStop = 1
End Select
'speed
Select Case mouseMenu(tagSpeed + " kt",, 0, -8, tagColor)
Case 0
tagSpeed = Str(Int(speed))
Case 8
tagSpeed = Str(messageSpeed)
planeflag.tagStop = 1
Case 9 'accelerate
If (messageSpeed = 0) And (planeflag.takeoff = 1) Then
messageSpeed = 300
ElseIf messageSpeed < maxspeed Then
messageSpeed += 50
planeflag.changeSpeed = 1
If messageSpeed > maxspeed Then
messageSpeed = maxspeed
EndIf
EndIf
planeflag.tagStop = 1
Case 10 'slow down
If messageSpeed > stallSpeed Then
messageSpeed -= 50
planeflag.changeSpeed = 1
If messageSpeed < stallSpeed Then
messageSpeed = stallSpeed
EndIf
EndIf
planeflag.tagStop = 1
End Select
'################################
#Macro turnIndicator
If Left(turn, 1) = "r" Then
Circle (xdisp + 10, ydisp + 10), 15, green, _
_2pi - headingAngle((mark.heading + Len(turn)) And &b111), _
(_2pi - headingAngle(mark.heading))
ElseIf Left(turn, 1) = "l" Then
Circle (xdisp + 10, ydisp + 10), 15, green, _
(_2pi - headingAngle(mark.heading)), _
_2pi - headingAngle((mark.heading - Len(turn)) And &b111)
EndIf
#EndMacro
'################################
If (Bit(lvl.helpturn, 1)) Then
turnIndicator 'macro
EndIf
GetMouse (mx,my,wheel,buttons)
'turning (mouse cursor touches the plane icon)
If planeflag.underCursor = 1 Then 'mouse cursor touches the plane icon
'-------------------------------
Locate 5,1
? " index ";index
? " turn ";turn
? "messageturn ";messageturn
? planeflag.turn
? cardinalDegree(mark.heading)
'-------------------------------
If (Bit(lvl.helpturn, 0)) AndAlso (Len(turn) <> 0) AndAlso (planeflag.turn = 0) Then
turnIndicator 'macro
EndIf
If buttons Then
If (planeflag.turn = 0) And (Bit(buttons, 2) = 0) Then 'no mid button
messageTurn = "" 'cancel previous turning order
EndIf
planeflag.turn = 1
If (buttons = 1) And (InStr(messageTurn, "r") = 0) And (Len(messageTurn) <= 7) Then 'left button --> turn left
messageTurn += "l"
planeflag.changeTurn = 1
waitRelease
ElseIf buttons = 2 And (InStr(messageTurn, "l") = 0) And (Len(messageTurn) <= 7) Then 'right button --> turn right
messageTurn += "r"
planeflag.changeTurn = 1
waitRelease
ElseIf buttons = 4 Then 'mid mutton --> cancel turning
messageTurn = "c"
planeflag.changeTurn = 1
waitRelease
EndIf
EndIf
'##### move tag #####
GetMouse (mx,my,wheel,buttons)
If wheel > wheelrem Then 'move tag
If (tagDispBasex = tagRight) And (tagDispBasey = tagTop) Then 'top right
tagDispBasex = tagLeft
ElseIf (tagDispBasex = tagLeft) And (tagDispBasey = tagTop) Then 'top left
tagDispBasey = tagBottom
ElseIf (tagDispBasex = tagLeft) And (tagDispBasey = tagBottom) Then 'bottom left
tagDispBasex = tagRight
Else 'set to top right
tagDispBasex = tagRight
tagDispBasey = tagTop
EndIf
ElseIf wheel < wheelrem Then
If (tagDispBasex = tagRight) And (tagDispBasey = tagTop) Then 'top right
tagDispBasey = tagBottom
ElseIf (tagDispBasex = tagRight) And (tagDispBasey = tagBottom) Then 'bottom right
tagDispBasex = tagLeft
ElseIf (tagDispBasex = tagLeft) And (tagDispBasey = tagBottom) Then 'bottom left
tagDispBasey = tagTop
Else 'set to top right
tagDispBasex = tagRight
tagDispBasey = tagTop
EndIf
EndIf
'##### end move tag #####
Else 'mouse cursor doesn't touch the plane icon
planeflag.turn = 0
EndIf
EndIf 'display plane and tag
wheelrem = wheel
If planeflag.tagStop Or planeflag.underCursor Then
messageLock = Timer + .6
EndIf
'submit message
If (messageLock < Timer) AndAlso _
(planeflag.changeAny <> 0) AndAlso _
(InStr(messageQueue, callsign) = 0) AndAlso _
(messageCallsign <> callsign) Then 'add callsign to message queue
messageQueue += callsign
EndIf
'proceed message
Select Case planeflag.getMessage
Case 0 'send message if plane is on the 1st place of the message queue and there's
' no message being sent at the moment
If (InStr(messageQueue, callsign) = 1) And (message = "") Then
messageQueue = Mid(messageQueue, Len(callsign) + 1) 'delete this plane from message queue
'##### generate message #####
messageCallsign = callsign
For c As Integer = LBound(companyIdentifier) To UBound(companyIdentifier)
If Left(callsign, 2) = companyIdentifier(c, 0) Then
message = companyIdentifier(c, 1) + " " + Mid(callsign, 3)
Exit For
EndIf
Next
messageTime = 1.5
If (planeflag.changeTurn) Then
If Left(messageTurn, 1) = "r" Then
message += " Turn right to " + cardinalDegree((mark.heading + Len(messageTurn)) Mod 8)
messageTime += 1.5
ElseIf Left(messageTurn, 1) = "l" Then
message += " Turn left to " + cardinalDegree((mark.heading - Len(messageTurn)) Mod 8)
messageTime += 1.5
ElseIf messageTurn = "c" Then
message += " Keep heading"
messageTime += 1.5
EndIf
'ElseIf Left(turn, 1) = "r" Then
' message += " Turn right to " + cardinalDegree((mark.heading + Len(turn)) Mod 8)
' messageTime += 1.5
'ElseIf Left(turn, 1) = "l" Then
' message += " Turn left to " + cardinalDegree((mark.heading - Len(turn)) Mod 8)
' messageTime += 1.5
EndIf
'If (planeflag.changeAltitude = 0) And (altitude <> targetaltitude) Then
' messagealtitude = targetaltitude
' planeflag.changeAltitude = 1
'EndIf
If (planeflag.changeAltitude) And (flightstatus <> FS_CLEAREDFORLANDING)Then
'If flightstatus <> FS_CLEAREDFORLANDING Then
If messageAltitude > altitude Then
message += " Climb to " + Str(messageAltitude) + " feet"
messageTime += 1.5
ElseIf messageAltitude < altitude Then
message += " Descend to " + Str(messageAltitude) + " feet"
messageTime += 1.5
Else
planeflag.changeAltitude = 0
EndIf
'EndIf
EndIf
If (planeflag.changeSpeed) Then
If messageSpeed > speed Then
message += " Accelerate to " + Str(messageSpeed) + " knots"
messageTime += 1.5
ElseIf messageSpeed < speed Then
message += " Slow down to " + Str(messageSpeed) + " knots"
messageTime += 1.5
Else
planeflag.changeSpeed = 0
EndIf
EndIf
If flightstatus = FS_CLEAREDFORLANDING Then
message += " Cleared for landing"
messageTime += 1.5
EndIf
messageTime += Timer
'##### end generate message #####
planeflag.getMessage = 1
EndIf
Case 1 'wait for order to be transmitted, then execute
If messageTime < Timer Then
If planeflag.changeAltitude Then
If flightstatus = FS_CLEAREDFORLANDING Then
targetAltitude = 1000
Else
targetAltitude = messageAltitude
EndIf
EndIf
If (planeflag.takeoff = 1) And (planeflag.changeSpeed = 0) Then
messagespeed = 250
planeflag.changeSpeed = 1
EndIf
If (planeflag.changeSpeed) Then
targetSpeed = messageSpeed
EndIf
If planeflag.changeTurn Then
If messageTurn = "c" Then
turn = ""
Else
turn = messageTurn
EndIf
EndIf
planeflag.changeAny = 0
planeflag.getMessage = 2
message = " Roger"
messageTime = Timer + 1.8
mark.circ = 1
EndIf
Case 2 'confirm
If messageTime < Timer Then
planeflag.getMessage = 0
mark.circ = 0
message = ""
messageCallsign = ""
EndIf
End Select
End Sub
Function tPlane.checkApproach(runway As tRunway) As Integer
Dim As tPosition p2
Dim As Double oppdirection
With runway
Select Case .runwayType
Case _bidir
p2 = .beginRunway - .endRunway
oppdirection = Atan2(p2.y, p2.x)
If (Abs(.direction - direction) < .001) AndAlso _
(Abs(cart2pol(position, .beginRunway).phi - direction) < .001) Then
Return cart2pol(position, runway.beginRunway).r 'distance to runway threshold
ElseIf (Abs(oppdirection - direction) < .001) AndAlso _
(Abs(cart2pol(position, .endRunway).phi - direction) < .001) Then
Return cart2pol(position, runway.endRunway).r 'distance to runway threshold
Else
If (Abs(cart2pol(.beginRunway, position).phi - .direction) < .001) And _
(Abs(cart2pol(position, .endRunway).phi - .direction) < .001) Then
Return FSA_ABOVERUNWAY '-2 'plane above the runway
Else
Return FSA_NOAPPROACH '-1 'no approach
EndIf
EndIf
Case _unidir
If (Abs(.direction - direction) < .001) AndAlso _
(Abs(cart2pol(position, .beginRunway).phi - direction) < .001) Then
Return cart2pol(position, runway.beginRunway).r 'distance to runway threshold
Else
If (Abs(cart2pol(.beginRunway, position).phi - .direction) < .001) And _
(Abs(cart2pol(position, .endRunway).phi - .direction) < .001) And _
(Abs(direction - .direction) < .001) Then
Return FSA_ABOVERUNWAY '-2 'plane correct above the runway
Else
Return FSA_NOAPPROACH '-1 'no approach
EndIf
EndIf
End Select
End With
End Function
Sub tPlane.savePlane(filenr As Integer)
Print #filenr, "PLANE"
Print #filenr, callsign
Print #filenr, destination
Print #filenr, origin
Print #filenr, position.x
Print #filenr, position.y
Print #filenr, tagDispBasex
Print #filenr, tagDispBasey
Print #filenr, target.x
Print #filenr, target.y
Print #filenr, selbuffer_
Print #filenr, altitude
Print #filenr, targetAltitude
Print #filenr, messageAltitude
Print #filenr, direction
Print #filenr, turn
Print #filenr, messageTurn
Print #filenr, speed
Print #filenr, targetSpeed
Print #filenr, messageSpeed
Print #filenr, timerem
Print #filenr, scheduledDepartureTime
Print #filenr, fuel
Print #filenr, planeflags
Print #filenr, mark_
Print #filenr, flightstatus
Print #filenr, runway_
End Sub
Sub tPlane.loadPlane(filenr As Integer)
Input #filenr, callsign
Input #filenr, destination
Input #filenr, origin
Input #filenr, position.x
Input #filenr, position.y
Input #filenr, tagDispBasex
Input #filenr, tagDispBasey
Input #filenr, target.x
Input #filenr, target.y
Input #filenr, selbuffer_
Input #filenr, altitude
Input #filenr, targetAltitude
Input #filenr, messageAltitude
Input #filenr, direction
Input #filenr, turn
Input #filenr, messageTurn
Input #filenr, speed
Input #filenr, targetSpeed
Input #filenr, messageSpeed
Input #filenr, timerem
Input #filenr, scheduledDepartureTime
Input #filenr, fuel
Input #filenr, planeflags
Input #filenr, mark_
Input #filenr, flightstatus
Input #filenr, runway_
timerem = Timer
operate(0)
End Sub
'####################################################################
'####################################################################
'####################################################################
'####################################################################
'####################################################################
Dim As Integer sc_width, sc_height, messageLine, x, y, z, p, w, h, ff, w2, h2, bpp, _
update, flightsDone, planes, remColumns, remLines
Dim As Integer mx, my, buttons, wheel
Dim As String g, key
Dim As Double conflictTime, timenew, timepause, timeupd, timeremPause, timerem = Timer
Dim As Any Ptr fontColor
Dim As tPosition scalePos
Randomize
ScreenRes 600, 400, 32
'ScreenSet 1,0
'create plane icon images
w = 20 'icon width
h = 20 'icon height
'&b01111111
' ||/||||__+45° clockwise (north = 0°)
' || |||___+90°
' || ||____+180°
' || |_____0 = outline 1 = filled
' ||_______color 00 = ltgreen 01 = red 10 = cyan 11 = yellow
' |________1 = circle around the plane icon
'outline straight
planeImg(IMG_LTGREEN) = ImageCreate(w, h, tran)
planeImg(IMG_RED) = ImageCreate(w, h, tran)
planeImg(IMG_CYAN) = ImageCreate(w, h, tran)
planeImg(IMG_YELLOW) = ImageCreate(w, h, tran)
Restore outlineStraight
For y = 0 To h - 1
Read g
For x = 0 To Len(g) - 1
If g[x] = Asc("x") Then
PSet planeImg(IMG_LTGREEN), (x, y), ltgreen
PSet planeImg(IMG_RED), (x, y), red
PSet planeImg(IMG_CYAN), (x, y), cyan
PSet planeImg(IMG_YELLOW), (x, y), yellow
EndIf
Next
Next
'outline diagonal
planeImg(IMG_LTGREEN Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_RED Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_CYAN Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_YELLOW Or _NE) = ImageCreate(w, h, tran)
Restore outlineDiagonal
For y = 0 To h - 1
Read g
For x = 0 To Len(g) - 1
If g[x] = Asc("x") Then
PSet planeImg(IMG_LTGREEN Or _NE), (x, y), ltgreen
PSet planeImg(IMG_RED Or _NE), (x, y), red
PSet planeImg(IMG_CYAN Or _NE), (x, y), cyan
PSet planeImg(IMG_YELLOW Or _NE), (x, y), yellow
EndIf
Next
Next
'filled straight
planeImg(IMG_LTGREEN Or IMG_FILLED) = ImageCreate(w, h, tran)
planeImg(IMG_RED Or IMG_FILLED) = ImageCreate(w, h, tran)
planeImg(IMG_CYAN Or IMG_FILLED) = ImageCreate(w, h, tran)
planeImg(IMG_YELLOW Or IMG_FILLED) = ImageCreate(w, h, tran)
Restore filledStraight
For y = 0 To h - 1
Read g
For x = 0 To Len(g) - 1
If g[x] = Asc("x") Then
PSet planeImg(IMG_LTGREEN Or IMG_FILLED), (x, y), ltgreen
PSet planeImg(IMG_RED Or IMG_FILLED), (x, y), red
PSet planeImg(IMG_CYAN Or IMG_FILLED), (x, y), cyan
PSet planeImg(IMG_YELLOW Or IMG_FILLED), (x, y), yellow
EndIf
Next
Next
'filled diagonal
planeImg(IMG_LTGREEN Or IMG_FILLED Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_RED Or IMG_FILLED Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_CYAN Or IMG_FILLED Or _NE) = ImageCreate(w, h, tran)
planeImg(IMG_YELLOW Or IMG_FILLED Or _NE) = ImageCreate(w, h, tran)
Restore filledDiagonal
For y = 0 To h - 1
Read g
For x = 0 To Len(g) - 1
If g[x] = Asc("x") Then
PSet planeImg(IMG_LTGREEN Or IMG_FILLED Or _NE), (x, y), ltgreen
PSet planeImg(IMG_RED Or IMG_FILLED Or _NE), (x, y), red
PSet planeImg(IMG_CYAN Or IMG_FILLED Or _NE), (x, y), cyan
PSet planeImg(IMG_YELLOW Or IMG_FILLED Or _NE), (x, y), yellow
EndIf
Next
Next
'create images of the other 7 directions
For d As Integer = _E To _NW 'all directions
For c As Integer = IMG_LTGREEN To IMG_YELLOW Step IMG_RED 'all colors
planeImg(d + c) = turnImg(planeImg(d - 2 + c)) 'outline
planeImg(d + c + IMG_FILLED) = turnImg(planeImg(d - 2 + c + IMG_FILLED)) 'filled
Next
Next
'set mouse menu colors
With neutralColor
.text = white
.bgnd = black
Swap .foregroundhi, .backgroundhi 'no change of colors when touching the item
End With
With scheduleColor
.text = yellow
.bgnd = black
End With
With outScreenScheduleColor
.text = darkyellow
.bgnd = black
Swap .foregroundhi, .backgroundhi 'no change of colors when touching the item
End With
With buttonColor
.text = white
.bgnd = black
End With
'create big fonts
bigFontWhite = createBigFont(32, 127, white, black)
bigFontRed = createBigFont(32, 127, red, black)
bigFontYellow = createBigFont(32, 127, yellow, black)
bigFontLtgreyT = createBigFont(32, 127, ltgrey, tran)
midFontWhite = createMidFont(32, 127, white, black)
Randomize
Do '##### GAME LOOP #####
'##### LEVEL SETUP #####
ChDir ExePath
'load setup data
lvl.lvlName = getini("actLevel") 'get actual level file
lvl.maxPlanes = Val(getini("maxPlanes"))
lvl.newPlaneGap = Val(getini("newPlaneGap"))
lvl.helpturn = Val(getini("helpturn"))
lvl.helpdest = Val(getini("helpdest"))
lvl.helpmessage = Val(getini("helpmessage"))
If lvl.lvlName = "" Or _
Not(FileExists(lvl.lvlName)) Or _
lvl.maxPlanes = 0 Or _
lvl.newPlaneGap = 0 Then
ScreenRes 1000, 900, 32, 2 'screen for setup
ScreenSet 1,0
setup(lvl)
Continue Do 'restart level
EndIf
grid = Val(getVar(lvl.lvlName, "grid")) 'pixels
NMperGrid = Val(getVar(lvl.lvlName, "NMperGrid")) 'NM per grid point
scale = NMperGrid * NMft / grid 'ft/pixel
messageLine = 32
radar_sc = Int(900 / grid) * grid
ScreenRes radar_sc + 140, radar_sc + messageLine + 1, 32, 2 'game screen
ScreenSet 1,0
ScreenInfo sc_width, sc_height
'Open Cons For Output As #100
'Print #100, sc_width, sc_height
'Print #100, grid
'Print #100, lvl.lvlName
'Close 100
'calculate grid offsets
gridOffset(_N) = Type<tPosition>(0,-grid)
gridOffset(_NE) = Type<tPosition>(grid,-grid)
gridOffset(_E) = Type<tPosition>(grid,0)
gridOffset(_SE) = Type<tPosition>(grid,grid)
gridOffset(_S) = Type<tPosition>(0,grid)
gridOffset(_SW) = Type<tPosition>(-grid,grid)
gridOffset(_W) = Type<tPosition>(-grid,0)
gridOffset(_NW) = Type<tPosition>(-grid,-grid)
'set runway(s) and slot(s)
ReDim runway(0)
ff = FreeFile
Open lvl.lvlName For Input As #ff
Do Until Eof(ff)
Input #ff, g
If g = "RUNWAY/SLOT" Then
x = UBound(runway) + 1
ReDim Preserve runway(x)
runway(x).loadRunway(ff)
EndIf
Loop
Close ff
'For x = 1 To UBound(runway)
' runway(x).inColor = green
' runway(x).outColor = white
'Next
If FileExists("resume.pln") Then
remLines = HiWord(Width)
remColumns = LoWord(Width)
Width sc_width / 8, sc_height / 16
Draw String (sc_width / 2 - 185, 50), "Welcome to BER Approach!",,bigFontWhite
Do
If mouseMenu(" Resume last game ",, sc_width / 2 - 65, 150, buttonColor, 2) = 9 Then
ff = FreeFile
Open "resume.pln" For Input As #ff
Input #ff, gameTime
refTime = Now - gameTime
Input #ff, conflictTime
Input #ff, flightsDone
Input #ff, messageQueue
Input #ff, messageCallsign
Input #ff, message
Input #ff, messageTime
messageTime += Timer
ReDim tPlane.plane(0)
p = 0
Do Until Eof(ff)
Input #ff, g
If g = "PLANE" Then
p += 1
tPlane.create(-1)
tPlane.plane(p).loadPlane(ff)
EndIf
Loop
Close ff
flag.resum = 1
sessionStartTime = Now
Exit Do
ElseIf mouseMenu(" Start new game ",, sc_width / 2 - 55, -40, buttonColor, 2) = 9 Then
Exit Do
ElseIf mouseMenu(" Quit ",, sc_width / 2 - 20, -40, buttonColor, 2) = 9 Then
For x = LBound(planeImg) To UBound(planeImg)
ImageDestroy planeImg(x)
Next
ImageDestroy bigFontWhite
ImageDestroy bigFontRed
ImageDestroy bigFontLtgreyT
End
EndIf
ScreenCopy
Sleep 1
Loop
Width remColumns, remLines 'restore character size
EndIf
''Open "default.lvl" For Output As #1
''For x As Integer = 1 To UBound(runway)
'' runway(x).saveRunway(1)
''Next
''Close
'#########################################################
If flag.resum = 0 Then 'initialize a new game
ReDim tPlane.plane(0)
For x = 1 To UBound(runway)
Select Case runway(x).runwayType
Case _unidir, _bidir
'For y as Integer = 1 To 3
tPlane.create(x)
'Next
Case _slot
runway(x).inColor = white
runway(x).outColor = white
End Select
Next
''======== for testing bad exit ====================
'With tPlane.plane(1)
' .destination = "HAM"
' .position.x = grid * 9
' .position.y = grid * 0 + 25
' .xdisp = .position.x
' .ydisp = .position.y
' .target = fix2grid(.position + pol2cart(Type<tPolar>(grid, headingAngle(_N))))
' .speed = 400
' .targetspeed = 400
' .targetaltitude = 5000
' .altitude = 5000
' .flightstatus = FS_FLYING
' .tagDispx = .tagDispBasex + .xdisp
' .tagDispy = .tagDispBasey + .ydisp
'End With
''===================================================
'runway(1).lockIn = 1
For x = 1 To UBound(runway)
tPlane.create(x)
Next
refTime = Now
gameTime = 0
sessionStartTime = Now
EndIf
timenew = Timer + lvl.newPlaneGap
scalePos = fix2grid(Type<tPosition>(grid, radar_sc))
scalePos = Type<tPosition>(scalePos.x - 10, scalePos.y)
Do '##### MAIN LOOP #####
key = InKey
Line (0, 0) - (sc_width - 1, sc_height - 1), black, bf 'clear screen
If flag.pause Then
timenew = Timer + timepause
Draw String (radar_sc / 2 - 100, radar_sc / 2), "GAME PAUSED",, bigFontWhite
EndIf
If Timer > timenew Then 'new plane
If planes < lvl.maxPlanes Then
If tPlane.create() Then 'plane creation successful
timenew = Timer + lvl.newPlaneGap 'set time gap for next plane
EndIf
EndIf
EndIf
planes = 0
'draw grid
For x = 0 To radar_sc - 1 Step grid
For y = 0 To radar_sc - 1 Step grid
PSet (x, y), white
Next
Next
'draw scale
Line (scalePos.x - 1, scalePos.y - grid) - (scalePos.x + 1, scalePos.y - 2*grid), ltgrey, bf
Line (scalePos.x - 4, scalePos.y - grid) - (scalePos.x + 4, scalePos.y - grid - 1), ltgrey, bf
Line (scalePos.x - 4, scalePos.y - 2*grid) - (scalePos.x + 4, scalePos.y - 2*grid + 1), ltgrey, bf
Draw String (scalePos.x + 5, scalePos.y - 1.5 * grid - 4), Str(NMperGrid) + " NM", ltgrey
'draw runway(s) and slot(s)
For x = 1 To UBound(runway)
If runway(x).runwayType = _slot Then 'set colors for slot direction marks
runway(x).outColor = white
runway(x).inColor = white
For p = 1 To UBound(tPlane.plane)
With tPlane.plane(p)
If outScreen(.position) AndAlso runway(x).sign = .origin Then 'incoming plane
runway(x).inColor = green
EndIf
End With
Next
EndIf
runway(x).drawRunway
Next
If Timer > timeupd Then
update = 1
timeupd = Timer + 2.0
Else
update = 0
EndIf
'----------------------
totalDelay = 0
For p = 1 To UBound(tPlane.plane) 'all planes
With tPlane.plane(p)
.operate(update)
End With
Next
'----------------------
'----------------------
Locate 2,1
'Color ltgrey
'If (message.mlock - Timer) > 0 Then
' Color red
'EndIf
'? "message.mlock ";message.mlock - Timer
Color ltgrey
If (messageTime - Timer) > 0 Then
Color red
EndIf
? " messageTime";messageTime - Timer
Color ltgrey
? " messageQueue ";messageQueue
? " messageCallsign ";messageCallsign
'? "message.message ";message.message
'----------------------
Line (radar_sc, 0) - (sc_width - 1, sc_height - 1), black, bf 'clear legend area
'draw schedule / list
mouseMenu("CALL DST",,radar_sc + 25, 226, neutralColor)
mouseMenu("",,0, -10, neutralColor)
'list of scheduled planes
For p = 1 To UBound(tPlane.plane)
With tPlane.plane(p)
If (.flightstatus = FS_SCHEDULED) And (.planeflag.takeoff = 0) Then
Select Case mouseMenu(.callsign + " " + .destination,, 0, -10, scheduleColor)
Case 8 'show position of scheduled plane
Circle (.position.x, .position.y), 5, ltgreen,,,,f
Case 9 'left button --> launch plane
.planeflag.takeoff = 1
End Select
EndIf
End With
Next
mouseMenu("-----------",,0, -10, neutralColor) 'line between scheduled and airborne
'list of airborne planes
For p = 1 To UBound(tPlane.plane)
With tPlane.plane(p)
If .flightstatus <> FS_SCHEDULED Then
planes += 1
mouseMenu(.callsign + " " + IIf(outScreen(.position), .origin, .destination),, 0, -10, .listColor)
EndIf
End With
Next
'legend
If (mouseMenu(" LOAD ",,radar_sc + 40, radar_sc - 100, buttonColor, 2) = 9) Or (key = "l") Then
ff = FreeFile
Open "planes.pln" For Input As #ff
Input #ff, gameTime
refTime = Now - gameTime
sessionStartTime = Now
Input #ff, conflictTime
Input #ff, flightsDone
ReDim tPlane.plane(0)
p = 0
Do Until Eof(ff)
Input #ff, g
If g = "PLANE" Then
p += 1
tPlane.create(-1)
tPlane.plane(p).loadPlane(ff)
EndIf
Loop
Close ff
flag.resum = 1 'restart
EndIf
If (mouseMenu(" SAVE ",,0, -25, buttonColor, 2) = 9) Or (key = "s") Then
ff = FreeFile
Open "planes.pln" For Output As #ff
Print #ff, gameTime
Print #ff, conflictTime
Print #ff, flightsDone
For p = 1 To UBound(tPlane.plane)
tPlane.plane(p).savePlane(ff)
Next
Close ff
EndIf
If (mouseMenu(" SETUP ",,0, -25, buttonColor, 2 + 4) = 9) Or (key = "S") Then
setup(lvl)
If flag.restart Then
flag.restart = 0
Continue Do, Do
EndIf
EndIf
If (mouseMenu(" PAUSE ",,0, -25, buttonColor, 2 + 4) = 9) Or (key = "p") Then
timepause = timenew - Timer
If flag.pause Then
flag.pause = 0
refTime += (Now - timeremPause)
sessionStartTime += (Now - timeremPause)
Else
flag.pause = 1
timeremPause = Now
EndIf
EndIf
Line (radar_sc - 1, 0) - (radar_sc + 4, radar_sc - 1), midgrey, bf 'right radar screen border
Line (0, radar_sc + 1) - (sc_width - 1, radar_sc + 2), midgrey, bf 'radar screen bottom border
'print delay
If (60 * Hour(totalDelay) + Minute(totalDelay)) >= 100 Then
Draw String (300, 230), Str(60 * Hour(totalDelay) + Minute(totalDelay)) + " MINUTES DELAY",, bigfontRed
firedReason = "Delay"
flag.fired = 1 'game over
EndIf
'print conflict time
For p = 1 To UBound(tPlane.plane)
With tPlane.plane(p)
If .planeflag.conflict Then
conflictTime += (Timer - timerem)
If conflictTime > 60 Then
Draw String (300, 230), Str(Int(conflictTime)) + " SECONDS OF CONFLICT", red, bigFontRed
firedReason = "Conflict"
flag.fired = 1 'game over
EndIf
Exit For
EndIf
End With
Next
timerem = Timer
'delete exited/landed planes
x = UBound(tPlane.plane)
For p = 1 To x
With tPlane.plane(p)
If .planeflag.crash Then 'plane crashed
Circle (.position.x, .position.y), 25, red
Draw String (300, 250), "YOU CAUSED A CRASH",, bigFontRed
firedReason = "Crash"
flag.fired = 1 'game over
EndIf
If (.flightstatus = FS_EXIT) Then 'correct exit
.flightstatus = FS_REMOVE
ElseIf (.flightstatus = FS_BADEXIT) Then 'bad exit
Draw String (200, 270), .callsign + " BAD EXIT: " + .comment,, bigFontRed
For x As Integer = 40 To 53 Step 4
Circle (.position.x, .position.y), x, red
Next
'Locate 2,1
'Print "destination ";.destination
'Print " position x ";.position.x
'Print " position y ";.position.y
'Print " target x ";.target.x
'Print " target y ";.target.y
'Print " altitude ";.altitude
'Print " direction ";.direction
'Print " heading ";.mark.heading;" (";cardinalPoint(.mark.heading);")"
'Print " turn ";.turn
'Print " speed ";.speed
firedReason = "Bad exit " + .comment
flag.fired = 1
EndIf
If (.flightstatus = FS_REMOVE) Then 'remove plane from array
If InStr(messageQueue, .callsign) Then 'remove callsign from messegeQueue
Dim As Integer cs = InStr(messageQueue, .callsign)
messageQueue = Left(messageQueue, cs - 1) + Mid(messageQueue, cs + Len(.callsign))
EndIf
If .callsign = messageCallsign Then
message = ""
messageCallsign = ""
EndIf
For y = p To x - 1
Swap tPlane.plane(y), tPlane.plane(y + 1)
Next
ReDim Preserve tPlane.plane(x - 1)
flightsDone += 1
Exit For
ElseIf (.flightstatus = FS_RESCHEDULE) Then '--> replace to schedule
.flightstatus = FS_SCHEDULED
EndIf
End With
Next
gameTime = Now - refTime - IIf(flag.pause, Now - timeremPause, 0)
sessionTime = Now - sessionStartTime - IIf(flag.pause, Now - timeremPause, 0)
x = radar_sc + 10
y = 5
Draw String (x, y), "TOTAL TIME",white
Draw String (x, y + 12), Format(gameTime, "hh:mm:ss"),, bigFontLtgreyT
Line (x - 5, Y + 29) - (sc_width, y + 32), midgrey, bf
y += 36
Draw String (x, y), "SESSION TIME",white
Draw String (x, y + 12), Format(sessionTime, "hh:mm:ss"),, bigFontLtgreyT
Line (x - 5, Y + 29) - (sc_width, y + 32), midgrey, bf
y += 36
Draw String (x, y), "AIRBORNE",white
Draw String (x + 40, y + 12), Str(planes),, bigFontLtgreyT
Line (x - 5, y + 29) - (sc_width, y + 32), midgrey, bf
y += 36
Draw String (x, y), "DONE",white
Draw String (x + 40, y + 12), Str(flightsDone),, bigFontLtgreyT
Line (x - 5, y + 29) - (sc_width, y + 32), midgrey, bf
y += 36
Select Case conflictTime
Case Is >= 60
fontColor = bigfontRed
Case Is > 50
fontColor = bigFontYellow
Case Else
fontColor = bigFontLtgreyT
End Select
Draw String (x, y), "CONFLICT",white
Draw String (x + 40, y + 12), Str(Int(conflictTime)),, fontColor
Line (x - 5, y + 29) - (sc_width, y + 32), midgrey, bf
y += 36
Select Case 60 * Hour(totalDelay) + Minute(totalDelay)
Case Is >= 100
fontColor = bigfontRed
Case Is > 80
fontColor = bigFontYellow
Case Else
fontColor = bigFontLtgreyT
End Select
Draw String (x, y), "DELAY",white
Draw String (x + 20, y + 12), Str(60 * Hour(totalDelay) + Minute(totalDelay)) + ":" + Format(totalDelay, "ss"),, fontColor
Line (x - 5, y + 29) - (sc_width, y + 32), midgrey, bf
Line (0, radar_sc + 3) - (sc_width - 1, sc_height), black, bf 'clear message area
Draw String (100, radar_sc + 10), message,, midFontWhite 'print message
ScreenCopy
Sleep 1
Loop Until (key = " " And flag.pause = 0) Or (flag.fired = 1)
Exit Do 'game over
Loop 'level setup loop --> to restart the game
If flag.fired Then
ff = FreeFile
Open ExePath + "/history.ber" For Append As #ff
Print #ff, "----------"
'Print #ff, Date;" ";Time
Print #ff, Format(Now, "dd.mm.yyyy hh:mm:ss")
Print #ff, firedReason
Print #ff, "Flights completed: ";flightsDone
Print #ff, "Total time: ";Format(Now - refTime, "hh:mm:ss")
Print #ff, "Conflict: ";conflictTime
Print #ff, "Delay: ";Format(totalDelay, "ss")
Print #ff, "Level: ";lvl.maxPlanes
Close ff
Draw String (350, 300), "YOU ARE FIRED!",, bigFontRed
Kill (ExePath + "/resume.pln")
Else 'save actual game for resume
Draw String (300, 300), "YOU COMPLETED " + Str(flightsDone) + " FLIGHTS",, bigFontWhite
Draw String (300, 330), "IN " + Format(Now - refTime, "hh:mm:ss"),,bigFontWhite
ff = FreeFile
Open "resume.pln" For Output As #ff
Print #ff, gameTime
Print #ff, conflictTime
Print #ff, flightsDone
Print #ff, messageQueue
Print #ff, messageCallsign
Print #ff, message
Print #ff, messageTime - Timer
For p = 1 To UBound(tPlane.plane)
tPlane.plane(p).savePlane(ff)
Next
Close ff
EndIf
ScreenCopy
Sleep
For x = LBound(planeImg) To UBound(planeImg)
ImageDestroy planeImg(x)
Next
ImageDestroy bigFontWhite
ImageDestroy bigFontRed
ImageDestroy bigFontLtgreyT
End
outlineStraight:
Data ".........xx........."'1
Data "........x..x........"'2
Data "........x..x........"'3
Data "........x..x........"'4
Data "........x..x........"'5
Data ".......x....x......."'6
Data ".......x....x......."'7
Data ".....xx......xx....."'8
Data "....x..........x...."'9
Data "..xx....x..x....xx.."'10
Data ".x.....x....x.....x."'11
Data "x...x.x.x..x.x.x...x"'12
Data "xx.x....x..x....x.xx"'13
Data "........x..x........"'14
Data "........x..x........"'15
Data "........x..x........"'16
Data ".......x....x......."'17
Data "......x......x......"'18
Data ".....x...xx...x....."'19
Data ".....x.x....x.x....."'20
filledStraight:
Data ".........xx........."'1
Data "........xxxx........"'2
Data "........xxxx........"'3
Data "........xxxx........"'4
Data "........xxxx........"'5
Data ".......xxxxxx......."'6
Data ".......xxxxxx......."'7
Data ".....xxxxxxxxxx....."'8
Data "....xxxxxxxxxxxx...."'9
Data "..xxxxxxxxxxxxxxxx.."'10
Data ".xxxxxxxxxxxxxxxxxx."'11
Data "xxxxxxx.xxxx.xxxxxxx"'12
Data "xxxx....xxxx....xxxx"'13
Data "........xxxx........"'14
Data "........xxxx........"'15
Data "........xxxx........"'16
Data ".......xxxxxx......."'17
Data "......xxxxxxxx......"'18
Data ".....xxxxxxxxxx....."'19
Data ".....x.x....x.x....."'20
outlineDiagonal:
Data ".................../"'1*
Data "................xxx."'2*
Data "...............x./x."'3*
Data "..xxxxxxxxxxxxx./.x."'4*
Data ".x............./.x.."'5*
Data "..xxxx......../.x..."'6
Data "......xxxxx../..x..."'7
Data ".........x../...x..."'8
Data "........x../....x..."'9
Data ".......x../..x..x..."'10
Data "........./..xx..x..."'11
Data "..x...x./..x.x..x..."'12
Data ".x.xxx./..x..x..x..."'13
Data ".x..../.x....x..x..."'14
Data "..xx./.x......x.x..."'15
Data "....x..x......x.x..."'16
Data ".../.x.x......x.x..."'17
Data "../..x..x.....x.x..."'18
Data "./....xx.......x...."'19
Data "/..................."'20
filledDiagonal:
Data ".................../"'1*
Data "................xxx."'2*
Data "...............xxxx."'3*
Data "..xxxxxxxxxxxxxxxxx."'4*
Data ".xxxxxxxxxxxxxxxxx.."'5*
Data "..xxxxxxxxxxxxxxx..."'6
Data "......xxxxxxxxxxx..."'7
Data ".........xxxxxxxx..."'8
Data "........xxxxxxxxx..."'9
Data ".......xxxxxxxxxx..."'10
Data ".......xxxxxxxxxx..."'11
Data "..x...xxxxxx.xxxx..."'12
Data ".xxxxxxxxxx..xxxx..."'13
Data ".xxxxxxxx....xxxx..."'14
Data "..xxxxxx......xxx..."'15
Data "....xxxx......xxx..."'16
Data ".../.xxx......xxx..."'17
Data "../..xxxx.....xxx..."'18
Data "./....xx.......x...."'19
Data "/..................."'20
Function zoomText(text As String, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Dim As Any Ptr img, imgz
Dim As Integer w, h
Dim As Integer sc_width, sc_height, ch_width, ch_height
Dim As ULong pnt
'character size
ScreenInfo sc_width, sc_height
ch_width = sc_width / LoWord(Width)
ch_height = sc_height / HiWord(Width)
img = ImageCreate(Len(text) * ch_width, ch_height, background, 32)
ImageInfo img, w, h
imgz = ImageCreate(w * 2, h * 2, background, 32)
Draw String img, (0,0), text, foreground
For x As Integer = 0 To w - 1
For y As Integer = 0 To h - 1
pnt = Point(x, y, img)
PSet imgz, (x * 2, y * 2), pnt
PSet imgz, (x * 2 + 1, y * 2), pnt
PSet imgz, (x * 2, y * 2 + 1), pnt
PSet imgz, (x * 2 + 1, y * 2 + 1), pnt
Next
Next
ImageDestroy img
Return imgz
End Function
Function turnImg(img As Any Ptr, d As String = "r") As Any Ptr
Dim As Integer w, h, bpp, x, y
Dim As Any Ptr ret
ImageInfo img, w, h, bpp
ret = ImageCreate(h, w, RGB(0,0,0), bpp/8)
For x = 0 To w - 1
For y = 0 To h - 1
Select Case d
Case "l"
PSet ret, (y, x), Point(w - 1 - x, y, img) 'turn left
Case "r"
PSet ret, (y, x), Point(x, h - 1 - y, img) 'turn right
Case Else
ImageDestroy ret
Return 0
End Select
Next
Next
Return ret
End Function
Function fix2grid(ByRef p As tPosition) As tPosition
p.x = Int(p.x / grid + .5) * grid
p.y = Int(p.y / grid + .5) * grid
Return p
End Function
Sub setup(ByRef lvl As tSetup)
Dim As Integer sc_width, sc_height, remColumns, remLines, px, py, x
Dim As Integer Zeilen, Spalten
Dim As Double timerem = Now
Dim As String text
Dim As tMMcolors listColor, buttonColorChecked
Dim As tSetup remSetup = lvl
ReDim As String level(1)
'? remSetup.lvlName
'? remSetup.maxPlanes
'? remSetup.newPlaneGap
'?
'? lvl.lvlName
'? lvl.maxPlanes
'? lvl.newPlaneGap
'ScreenCopy
'Sleep
'End
With buttonColorChecked
.text = yellow
.bgnd = black
End With
With lvl
'save current character size
remLines = HiWord(Width)
remColumns = LoWord(Width)
flag.pause = 1
ScreenInfo sc_width, sc_height
Width sc_width / 8, sc_height / 16
level(1) = Dir("*.lvl")
Do 'get all level files
ReDim Preserve level(UBound(level) + 1)
level(UBound(level)) = Dir("")
Loop While Len(level(UBound(level)))
ReDim Preserve level(UBound(level) - 1)
Do
Cls
px = sc_width / 2 - 100
py = 30
Put (px,py),zoomText("SETUP"), Trans
'max planes
px = sc_width / 2 + 40
py = 150
Draw String (px - 240,py), "Maximum planes airborne " + Str(.maxPlanes), white
If mouseMenu(" + ",,px,py - 15, buttonColor, 2) = 9 Then
.maxPlanes += 1
ElseIf mouseMenu(" - ",,px,py + 15, buttonColor, 2) = 9 Then
If .maxPlanes > 1 Then
.maxPlanes -= 1
EndIf
ElseIf mouseMenu(" reset ",,px + 35,py, buttonColor, 2) = 9 Then
.maxPlanes = remSetup.maxPlanes
EndIf
'gap
px = sc_width/2 + 40
py = 250
Draw String (px - 288,py), "Gap between new planes " + Str(.newPlaneGap) + " seconds", white
If mouseMenu(" + ",,px,py - 15, buttonColor, 2) = 9 Then
.newPlaneGap += 1
ElseIf mouseMenu(" - ",,px,py + 15, buttonColor, 2) = 9 Then
'If .newPlaneGap > 17 Then
If .newPlaneGap > 1 Then
.newPlaneGap -= 1
EndIf
ElseIf mouseMenu(" reset ",,px + 35,py, buttonColor, 2) = 9 Then
.newPlaneGap = remSetup.newPlaneGap
EndIf
'helping features
'turning indicator
px = sc_width/2 - 218
py = 350
text = "Show turning "
Draw String (px, py), text, white
px += Len(text) * 8
If mouseMenu(" permanent ",,px, py, IIf(.helpturn = 2, buttonColorChecked, buttonColor), 2) = 9 Then
.helpturn = 2
ElseIf mouseMenu(" at touch ",,px + 98, py, IIf(.helpturn = 1, buttonColorChecked, buttonColor), 2) = 9 Then
.helpturn = 1
ElseIf mouseMenu(" off ",,px + 98 + 90,py, IIf(.helpturn = 0, buttonColorChecked, buttonColor), 2) = 9 Then
.helpturn = 0
EndIf
'destination in tag
px = sc_width/2 - 282
py = 380
text = "Show callsign in tag "
Draw String (px, py), text, white
px += Len(text) * 8
If mouseMenu(" permanent ",,px, py, IIf(.helpdest = 2, buttonColorChecked, buttonColor), 2) = 9 Then
.helpdest = 2
ElseIf mouseMenu(" at touch ",,px + 98, py, IIf(.helpdest = 1, buttonColorChecked, buttonColor), 2) = 9 Then
.helpdest = 1
ElseIf mouseMenu(" off ",,px + 98 + 90,py, IIf(.helpdest = 0, buttonColorChecked, buttonColor), 2) = 9 Then
.helpdest = 0
EndIf
'cange tag color if message
px = sc_width/2 - 338
py = 410
text = "Change tag color if message "
Draw String (px, py), text, white
px += Len(text) * 8
If mouseMenu(" permanent ",,px, py, IIf(.helpmessage = 2, buttonColorChecked, buttonColor), 2) = 9 Then
.helpmessage = 2
ElseIf mouseMenu(" at touch ",,px + 98, py, IIf(.helpmessage = 1, buttonColorChecked, buttonColor), 2) = 9 Then
.helpmessage = 1
ElseIf mouseMenu(" off ",,px + 98 + 90,py, IIf(.helpmessage = 0, buttonColorChecked, buttonColor), 2) = 9 Then
.helpmessage = 0
EndIf
'levels
px = sc_height/2 - 50
py = 480
For x = 1 To UBound(level)
listColor = buttonColor
If .lvlName = level(x) Then
listColor.text = yellow
EndIf
If mouseMenu(level(x),, px, py + 15 * x, listColor) = 9 Then
.lvlName = level(x)
EndIf
Next
'back to game
px = sc_height/2 - 50
py = sc_height - 50
If mouseMenu(" Return to game ",,px, py, buttonColor, 2) = 9 Then
Exit Do
EndIf
ScreenCopy
Sleep 1
Loop
End With
saveini(lvl)
If lvl.lvlName <> remSetup.lvlName Then
flag.restart = 1
EndIf
'update plane times
For p As Integer = 1 To UBound(tPlane.plane)
tPlane.plane(p).operate(0)
Next
Width remColumns, remLines 'restore character size
flag.pause = 0
refTime += (Now - timerem)
sessionStartTime += (Now - timerem)
End Sub
Sub saveini(lvl As tSetup)
Dim As Integer ff
ff = FreeFile
Open "ber.ini" For Output As #ff
Print #ff, "maxPlanes=";lvl.maxPlanes
Print #ff, "newPlaneGap=";lvl.newPlaneGap
Print #ff, "actLevel=";lvl.lvlName
Print #ff, "helpturn=";lvl.helpturn
Print #ff, "helpdest=";lvl.helpdest
Print #ff, "helpmessage=";lvl.helpmessage
Close ff
End Sub
Function getini(varName As String) As String
Dim As Integer ff, eq
Dim As String value, g
Dim As tSetup lvlDefault
ff = FreeFile
If Open ("ber.ini" For Input As #ff) Then 'open or create ini - file
'create ini - file with default values
With lvlDefault
.lvlName = "BER_TXL.lvl"
.maxPlanes = 8
.newPlaneGap = 30
End With
saveini(lvlDefault)
ff = FreeFile
Open "ber.ini" For Input As #ff
EndIf
Do 'get <varName> value
Line Input #ff, g
eq = InStr(g, "=")
value = Mid(g, eq + 1)
If LCase(Left(g, eq - 1)) = LCase(varName) Then 'varName found
Close ff
Return value
EndIf
Loop Until Eof(ff)
Close ff
Return "" 'varName not found
End Function
Function getVar (file As String, varName As String) As String
Dim As Integer ff, eq
Dim As String g
ff = FreeFile
Open file For Input As #ff
Do
Line Input #ff, g
eq = InStr(g, "=")
If LCase(Left(g, eq - 1)) = LCase(varName) Then
Close ff
Return Mid(g, eq + 1)
EndIf
Loop Until Eof(ff)
Close ff
Return ""
End Function
Function putVar(file As String, varName As String, value As Integer) As Integer
Return putVar(file, varName, Str(value))
End Function
Function putVar(file As String, varName As String, value As Double) As Integer
Return putVar(file, varName, Str(value))
End Function
Function putVar(file As String, varName As String, value As String) As Integer
Dim As Integer ff, ff2, eq
Dim As String g, temp
Dim As Integer flag = TRUE
ff = FreeFile
Open file For Input As #ff
ff2 = FreeFile
Open "temp.tmp" For Output As #ff2
Do
Line Input #ff, g
eq = InStr(g, "=")
If LCase(Left(g, eq - 1)) = LCase(varName) Then
g = varName + "=" + value
flag = FALSE
EndIf
Print #ff2, g
Loop Until Eof(ff)
If flag Then
Print #ff2, varName + "=" + value
EndIf
Close ff
Close ff2
Kill(file)
Name("temp.tmp", file)
Return TRUE
End Function
Function pol2cart(pk As tPolar) As tPosition
Return Type<tPosition>(pk.r * Cos(pk.phi), pk.r * Sin(pk.phi))
End Function
Function cart2pol(pof As tPosition = Type(0,0), pto As tPosition = Type(0,0)) As tPolar
Dim As tPosition p = pto - pof
Return Type<tPolar>(Sqr(p.x * p.x + p.y * p.y), Atan2(p.y, p.x))
End Function
#Macro PrintMenuItem(fg, bg, fr)
Line buffer, (xPos,yPos - 1)-(xPos + Len(text) * ch_width, yPos + ch_height), bg, bf
Draw String buffer, (xPos + IIf(Bit(mode, 2),ch_width / 2, 0), yPos), text, fg
If Bit(mode, 1) Then 'draw frame around text
Line buffer, (xPos - 1, yPos - 2)-(xPos + 1 + Len(text) * ch_width, yPos + ch_height + 1), fr, b
EndIf
#EndMacro
Function mouseMenu(text As String, _
separator As String = "", _
xPos As Integer = 0, _
yPos As Integer = 0, _
colors As tMMcolors, _
mode As UByte = 0, _
buffer As Any Ptr = 0) As Integer
'mode bit 1 set (2) -> draw a frame around the text
'mode bit 2 set (4) -> shift the text right half a character
Dim As Integer mx, my, wheel, buttons, separatorpos, returnValue = 0
Dim As Integer sc_width, sc_height, ch_width, ch_height
Static As Integer xrem, yrem
'get character size
ScreenInfo sc_width, sc_height
ch_width = sc_width / LoWord(Width)
ch_height = sc_height / HiWord(Width)
If yPos = 0 Then
yPos = yrem
ElseIf yPos < 0 Then
yPos = yrem - yPos
yPos = IIf(yPos < 0, 0, yPos)
EndIf
If xPos = 0 Then
xPos = xrem
ElseIf xPos < 0 Then
xPos = xrem - xPos
xPos = IIf(xPos < 0, 0, xPos)
EndIf
'adjust text position
If separator = "" Then
separatorpos = Len(text) * ch_width
Else
separatorpos = (InStr(text,separator) - 1) * ch_width
xPos = xPos - separatorpos + ch_width 'position text at separator
EndIf
xrem = xPos
yrem = yPos
GetMouse (mx, my, wheel, buttons)
If (mx >= xpos) AndAlso (mx <= xpos + Len(text) * ch_width) AndAlso _
(my >= yPos) AndAlso (my <= ypos + ch_height) Then 'mouse cursor touches the text
returnValue Or= 8
PrintMenuItem(colors.foregroundhi, colors.backgroundhi, colors.framehi) 'highlight menu item
If buttons Then 'mouse button pressed
returnValue Or= buttons
Do 'wait for release of the mouse button
GetMouse (mx, my, wheel, buttons)
Sleep 1
Loop While buttons
EndIf
Return returnValue
EndIf
PrintMenuItem(colors.foreground, colors.background, colors.frame)
End Function
Function angle2cardinal(angle As Double) As Integer
Select Case angle
Case headingAngle(_N) - pi/8 To headingAngle(_N) + pi/8
Return _N
Case headingAngle(_NE) - pi/8 To headingAngle(_NE) + pi/8
Return _NE
Case headingAngle(_E) - pi/8 To headingAngle(_E) + pi/8
Return _E
Case headingAngle(_SE) - pi/8 To headingAngle(_SE) + pi/8
Return _SE
Case headingAngle(_S) - pi/8 To headingAngle(_S) + pi/8
Return _S
Case headingAngle(_SW) - pi/8 To headingAngle(_SW) + pi/8
Return _SW
Case headingAngle(_W) - pi/8 To headingAngle(_W) + pi/8
Return _W
Case headingAngle(_NW) - pi/8 To headingAngle(_NW) + pi/8
Return _NW
Case Else
Return -1
End Select
End Function
Sub drawZoomText(x As Integer, y As Integer, text As String, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255))
Dim ztp As Any Ptr
ztp = zoomText(text, foreground, background)
Put(x, y), ztp, Trans
ImageDestroy ztp
ztp = 0
End Sub
Function createBigFont(firstChr As Integer, lastChr As Integer, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Dim As UByte Ptr p
Dim As Any Ptr charPtr, fontPtr, img
Dim As Integer sc_width, sc_height, bpp, ch_width, ch_height, numberOfChr, x, y, c
Dim As ULong pnt
'character size
ScreenInfo sc_width, sc_height,,bpp
ch_width = sc_width / LoWord(Width)
ch_height = sc_height / HiWord(Width)
numberOfChr = lastChr - firstChr + 1
fontPtr = ImageCreate(numberOfChr * ch_width * 2, ch_height * 2 + 1)
p = fontPtr
p += IIf(p[0] = 7, 32, 4)
p[0] = 0
p[1] = firstChr
p[2] = lastChr
charPtr = ImageCreate(ch_width * 2, ch_height * 2, background)
For c = firstChr To lastChr
p[3 + c - firstChr] = ch_width * 2
img = ImageCreate(ch_width, ch_height, background)
Draw String img, (0,0), Chr(c), foreground
For x = 0 To ch_width - 1
For y = 0 To ch_height - 1
pnt = Point(x, y, img)
PSet charPtr, (x * 2, y * 2), pnt
PSet charPtr, (x * 2 + 1, y * 2), pnt
PSet charPtr, (x * 2, y * 2 + 1), pnt
PSet charPtr, (x * 2 + 1, y * 2 + 1), pnt
Next
Next
ImageDestroy img
Put fontPtr, ((c - firstChr) * ch_width * 2, 1), charPtr, Trans
Next
ImageDestroy charPtr
Return fontPtr
End Function
Function createMidFont(firstChr As Integer, lastChr As Integer, foreground As ULong = RGB(255,255,255), background As ULong = RGB(255,0,255)) As Any Ptr
Dim As UByte Ptr p
Dim As Any Ptr charPtr, fontPtr, img
Dim As Integer sc_width, sc_height, bpp, ch_width, ch_height, numberOfChr, x, y, c, _
remLines, remColumns
Dim As ULong pnt
'character size
ScreenInfo sc_width, sc_height,,bpp
remLines = HiWord(Width)
remColumns = LoWord(Width)
Width sc_width / 8, sc_height / 16
ch_width = sc_width / LoWord(Width)
ch_height = sc_height / HiWord(Width)
numberOfChr = lastChr - firstChr + 1
fontPtr = ImageCreate(numberOfChr * ch_width, ch_height + 1)
p = fontPtr
p += IIf(p[0] = 7, 32, 4)
p[0] = 0
p[1] = firstChr
p[2] = lastChr
charPtr = ImageCreate(ch_width, ch_height, background)
For c = firstChr To lastChr
p[3 + c - firstChr] = ch_width
img = ImageCreate(ch_width, ch_height, background)
Draw String img, (0,0), Chr(c), foreground
For x = 0 To ch_width - 1
For y = 0 To ch_height - 1
pnt = Point(x, y, img)
PSet charPtr, (x, y), pnt
Next
Next
ImageDestroy img
Put fontPtr, ((c - firstChr) * ch_width, 1), charPtr, Trans
Next
ImageDestroy charPtr
Width remColumns, remLines 'restore character size
Return fontPtr
End Function
Function outScreen(p As tPosition) As boolean
Dim As Integer sc_width, sc_height
'ScreenInfo sc_width, sc_height
If (p.x < 0) OrElse (p.x > radar_sc) OrElse _
(p.y < 0) OrElse (p.y > radar_sc) Then 'p is outside the screen
Return TRUE
EndIf
Return FALSE
End Function
Sub waitRelease
Dim As Integer x, y, wheel, buttons
Do
GetMouse (x,y,wheel,buttons)
Sleep 1
Loop While buttons
End Sub