#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(p1.x + p2.x, p1.y + p2.y) End Operator Operator - (p1 As tPosition, p2 As tPosition) As tPosition Return Type(p1.x - p2.x, p1.y - p2.y) End Operator Operator * (p1 As tPosition, f As Double) As tPosition Return Type(p1.x * f, p1.y * f) End Operator Operator / (p1 As tPosition, f As Double) As tPosition Return Type(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(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(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(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(0,-grid) gridOffset(_NE) = Type(grid,-grid) gridOffset(_E) = Type(grid,0) gridOffset(_SE) = Type(grid,grid) gridOffset(_S) = Type(0,grid) gridOffset(_SW) = Type(-grid,grid) gridOffset(_W) = Type(-grid,0) gridOffset(_NW) = Type(-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(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(grid, radar_sc)) scalePos = Type(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, -12, 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, -12, 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, -12, .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 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(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(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