fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
GetPath.bas

Uploader:	ThePuppetMaster
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