Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen Download
Dateidownload

GetPath.bas

Uploader:MitgliedThePuppetMaster
Datum/Zeit:20.03.2013 20:17:28

'################################################################################################################################################
'Screen
Dim Shared G_Width as Integer = 800
Dim Shared G_Height as Integer = 600
ScreenRes 800, 600, 32



'################################################################################################################################################
'Way-Map
Dim Shared G_WayMap() as UInteger
'------------------------------------------------------------------------------------------------------------------------------------------------
'BestWay-Map
Type Vector_Type
    V_X as Integer
    V_Y as Integer
End Type
Dim Shared G_WayBestD() as Vector_Type
Dim Shared G_WayBestC as UInteger




'################################################################################################################################################
'Map
Dim Shared G_MapRastX as Integer = 40
Dim Shared G_MapRastY as Integer = 30
Dim Shared G_MapW as Integer
Dim Shared G_MapH as Integer
Dim Shared G_Map() as UInteger

'------------------------------------------------------------------------------------------------------------------------------------------------
Sub Map_BuildRandom()
G_MapW = G_Width \ G_MapRastX
G_MapH = G_Height \ G_MapRastY
ReDim Preserve G_Map(1 to G_MapW, 1 to G_MapH) as UInteger
ReDim Preserve G_WayMap(1 to G_MapW, 1 to G_MapH) as UInteger
For Y as UInteger = 1 to G_MapH
    For X as UInteger = 1 to G_MapW
        G_Map(X, Y) = IIf(Int(Rnd * 4) = 0, 1, 0)
        'G_Map(X, Y) = 1
    Next
Next

For X as UInteger = 1 to 10
'   G_Map(5 + X, 5) = 0
'   G_Map(5 + X, 15) = 0
'   G_Map(5, 5 + X) = 0
'   G_Map(15, 5 + X) = 0
Next
End Sub



'################################################################################################################################################
'Mover
Dim Shared G_MoverX as Integer
Dim Shared G_MoverY as Integer

'------------------------------------------------------------------------------------------------------------------------------------------------
Sub Mover_Set(V_X as Integer, V_Y as Integer)
G_MoverX = V_X
G_MoverY = V_Y
If G_MoverX < 1 Then G_MoverX = 1
If G_MoverX > G_MapW Then G_MoverX = G_MapW
If G_MoverY < 1 Then G_MoverY = 1
If G_MoverY > G_MapH Then G_MoverY = G_MapH
G_Map(G_MoverX, G_MoverY) = 0
End Sub



'################################################################################################################################################
'Target
Dim Shared G_TargetX as Integer
Dim Shared G_TargetY as Integer



'################################################################################################################################################
'Draw
Sub DoDraw()
ScreenLock()
CLS()
'best way zeichnen
For X as UInteger = 1 to G_WayBestC
    With G_WayBestD(X)
        Line ((.V_X - 1) * (G_Width / G_MapW), (.V_Y - 1) * (G_Height / G_MapH))-(.V_X * (G_Width / G_MapW), .V_Y * (G_Height / G_MapH)), &H00888800, BF
    End With
Next
'mover zeichnen
Line ((G_MoverX - 1) * (G_Width / G_MapW), (G_MoverY - 1) * (G_Height / G_MapH))-(G_MoverX * (G_Width / G_MapW), G_MoverY * (G_Height / G_MapH)), &H00008800, BF
'target zeichen
Line ((G_TargetX - 1) * (G_Width / G_MapW), (G_TargetY - 1) * (G_Height / G_MapH))-(G_TargetX * (G_Width / G_MapW), G_TargetY * (G_Height / G_MapH)), &H00880000, BF
'raster und werte zeichnen
For Y as UInteger = 1 to G_MapH
    For X as UInteger = 1 to G_MapW
        If G_Map(X, Y) <> 0 Then
            Line ((X - 1) * (G_Width / G_MapW), (Y - 1) * (G_Height / G_MapH))-(X * (G_Width / G_MapW), Y * (G_Height / G_MapH)), &H00000088, BF
        End If
        'Draw String ((X - 1) * (G_Width / G_MapW) + 4, (Y - 1) * (G_Height / G_MapH) + 4), Str(X) & "x" & Str(Y), &H00444444
        Draw String ((X - 1) * (G_Width / G_MapW) + 5, (Y - 1) * (G_Height / G_MapH) + 14), Str(G_WayMap(X, Y)), &H00000000
        Draw String ((X - 1) * (G_Width / G_MapW) + 4, (Y - 1) * (G_Height / G_MapH) + 13), Str(G_WayMap(X, Y)), IIf(G_WayMap(X, Y) > 0, &H00FFFFFF, &H00444444)
    Next
Next
ScreenUnLock()
End Sub



'################################################################################################################################################
'Distanz Pfad Funktion
Sub MapWay_RecrusivFillDist(V_TargetX as Integer, V_TargetY as Integer, V_FromX as Integer, V_FromY as Integer, V_Map() as UInteger, RV_WayMap() as UInteger, V_MapW as Integer, V_MapH as Integer, V_Deept as UInteger)
If RV_WayMap(V_TargetX, V_TargetY) > 0 Then If RV_WayMap(V_TargetX, V_TargetY) <= V_Deept Then Exit Sub
If RV_WayMap(V_FromX, V_FromY) > 0 Then If RV_WayMap(V_FromX, V_FromY) <= V_Deept Then Exit Sub
RV_WayMap(V_FromX, V_FromY) = V_Deept
If V_FromX > 1       Then If V_Map(V_FromX - 1   , V_FromY       ) = 0 Then MapWay_RecrusivFillDist(V_TargetX, V_TargetY, V_FromX - 1    , V_FromY       , V_Map(), RV_WayMap(), V_MapW, V_MapH, V_Deept + 1)
If V_FromY > 1       Then If V_Map(V_FromX       , V_FromY - 1   ) = 0 Then MapWay_RecrusivFillDist(V_TargetX, V_TargetY, V_FromX        , V_FromY - 1   , V_Map(), RV_WayMap(), V_MapW, V_MapH, V_Deept + 1)
If V_FromX < V_MapW  Then If V_Map(V_FromX + 1   , V_FromY       ) = 0 Then MapWay_RecrusivFillDist(V_TargetX, V_TargetY, V_FromX + 1    , V_FromY       , V_Map(), RV_WayMap(), V_MapW, V_MapH, V_Deept + 1)
If V_FromY < V_MapH  Then If V_Map(V_FromX       , V_FromY + 1   ) = 0 Then MapWay_RecrusivFillDist(V_TargetX, V_TargetY, V_FromX        , V_FromY + 1   , V_Map(), RV_WayMap(), V_MapW, V_MapH, V_Deept + 1)
'Wenn der aufbau betrachtet werden soll, folgende Zeile einkommentieren
'DoDraw(): Sleep 100, 1
End Sub



'################################################################################################################################################
'Distanz Pfad Funktion
Sub MapWay_GetBestWay(V_TargetX as Integer, V_TargetY as Integer, V_FromX as Integer, V_FromY as Integer, RV_WayMap() as UInteger, R_BestWayD() as Vector_Type, R_BestWayC as UInteger, V_MapW as Integer, V_MapH as Integer)
G_WayBestC = 0
If RV_WayMap(V_TargetX, V_TargetY) = 0 Then Exit Sub
Dim TX as Integer = V_TargetX
Dim TY as Integer = V_TargetY
Dim TM as Integer
Dim TD as Double = Sqr((V_FromX - V_TargetX) * (V_FromX - V_TargetX) + (V_FromY - V_TargetY) * (V_FromY - V_TargetY))
Dim TT as Double
Dim TVX as Integer
Dim TVY as Integer
Dim C as UInteger = RV_WayMap(V_TargetX, V_TargetY) - 1
Do
    If C = 0 Then Exit Do
    TM = 0
    If TX > 1        Then TM or= IIf(RV_WayMap(TX - 1    , TY        ) = C, &B00000001, 0)
    If TY > 1        Then TM or= IIf(RV_WayMap(TX        , TY - 1    ) = C, &B00000010, 0)
    If TX < V_MapW   Then TM or= IIf(RV_WayMap(TX + 1    , TY        ) = C, &B00000100, 0)
    If TY < V_MapH   Then TM or= IIf(RV_WayMap(TX        , TY + 1    ) = C, &B00001000, 0)
    For X as UInteger = 0 to 3
        If (TM and (2 ^ X)) <> 0 Then
            Select Case X
                Case 0: TVX = TX - 1    : TVY = TY
                Case 1: TVX = TX        : TVY = TY - 1
                Case 2: TVX = TX + 1    : TVY = TY
                Case 3: TVX = TX        : TVY = TY + 1
            End Select
            'TT = Sqr((V_FromX - TVX) * (V_FromX - TVX) + (V_FromY - TVY) * (V_FromY - TVY))
            'If TT < TD Then
                TX = TVX
                TY = TVY
            '   TD = TT
            'End If
            Exit For
        End If
    Next
    G_WayBestC += 1
    Redim Preserve G_WayBestD(G_WayBestC) as Vector_Type
    G_WayBestD(G_WayBestC).V_X = TX
    G_WayBestD(G_WayBestC).V_Y = TY
    C -= 1
Loop
End Sub



'################################################################################################################################################
'main-loop
'Randomize(Timer())
Randomize(1)
Map_BuildRandom()
Mover_Set(5, 5)
Dim TMX as Integer
Dim TMY as Integer
Dim TMB as Integer
Dim TMBL as Integer
Dim TTX as Integer
Dim TTY as Integer

Do Until InKey() = Chr(27)
    'Grab
    GetMouse(TMX, TMY, , TMB)
    TTX = Fix(TMX / G_MapRastX) + 1
    TTY = Fix(TMY / G_MapRastY) + 1
    If TTX < 1 Then TTX = 1
    If TTX > G_MapW Then TTX = G_MapW
    If TTY < 1 Then TTY = 1
    If TTY > G_MapH Then TTY = G_MapH

    'Fill WayMap (if changed)
    If (G_TargetX <> TTX) or (G_TargetY <> TTY) Then
        G_TargetX = TTX
        G_TargetY = TTY
        For Y as Integer = 1 to G_MapH
            For X as Integer = 1 to G_MapW
                G_WayMap(X, Y) = 0
            Next
        Next
        MapWay_RecrusivFillDist(G_MoverX, G_MoverY, G_TargetX, G_TargetY, G_Map(), G_WayMap(), G_MapW, G_MapH, 1)
        MapWay_GetBestWay(G_MoverX, G_MoverY, G_TargetX, G_TargetY, G_WayMap(), G_WayBestD(), G_WayBestC, G_MapW, G_MapH)
    End If

    'BTN Check
    If TMB <> TMBL Then
        Select Case TMB
            Case 1: Mover_Set(G_TargetX, G_TargetY)
            Case 2: Map_BuildRandom()
        End Select
        TMBL = TMB
    End If

    'Draw
    DoDraw()
    Sleep 10, 1
Loop



'################################################################################################################################################
'end
Screen 0
End 0