Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [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

myMaze4

Uploader:MitgliedEternal_Pain
Datum/Zeit:21.03.2013 20:41:32

Type tListNode
    NextEntry  as tListNode ptr
    PrevEntry  as tListNode ptr

    EntryValue as Integer
End Type

Type tList
    Declare Sub AddEntry(byval Value as Integer)
    Declare Sub DelEntry(byref ListNode as tListNode ptr)
    Declare Sub DestroyList()

    FirstEntry as tListNode ptr
    LastEntry  as tListNode ptr
End Type


Sub tList.AddEntry(byval Value as Integer)
    Dim NewEntry as tListNode ptr = NEW tListNode

    NewEntry -> EntryValue = Value

    If (LastEntry = 0) Then
        FirstEntry = NewEntry
        LastEntry  = NewEntry
        Exit Sub
    End If

    If LastEntry Then
        NewEntry -> PrevEntry = LastEntry
        LastEntry -> NextEntry = NewEntry
        LastEntry = NewEntry
    End If
End Sub

Sub tList.DestroyList()
    Dim ThisNode as tListNode ptr
    Dim TempNode as tListNode ptr
    ThisNode = LastEntry

    Do
        If ThisNode Then
            TempNode = ThisNode -> PrevEntry
            DelEntry(ThisNode)
            ThisNode = TempNode
        End If
    Loop while ThisNode
End Sub

Sub tList.DelEntry(byref ListNode as tListNode ptr)
    If ListNode -> NextEntry Then ListNode -> NextEntry -> PrevEntry = ListNode -> PrevEntry
    If ListNode -> PrevEntry Then ListNode -> PrevEntry -> NextEntry = ListNode -> NextEntry

    If FirstEntry = ListNode Then FirstEntry = FirstEntry -> NextEntry
    If LastEntry  = ListNode Then LastEntry  = LastEntry -> PrevEntry

    Delete ListNode
End Sub

Randomize Timer

#Define MazeFloor     &h00
#Define MazeStart     &h01
#Define MazeGoal      &h02
'Ready-Room-Floor: Experimental with ready rooms...
#Define MazeRRFloor_1 &h03
'...define... Items or anything else... here
'MazeReachPath: important to know, to set items and monsters... (or anything else...)
#Define MazeReachPath &h69
#Define MazeWall      &h70
'Ready-Room-Wall: Experimental with ready rooms...
#Define MazeRRWall_1  &h71
'...define other solid items like walls... here (up to &hFF)

Type Vector2
    X as Integer
    Y as Integer
End Type

Function Distance2i (byval XY1 as Vector2, Byval XY2 as Vector2) as Integer

    Dim PX as Integer = abs(XY1.X-XY2.X)*abs(XY1.X-XY2.X)
    Dim PY as Integer = abs(XY1.Y-XY2.Y)*abs(XY1.Y-XY2.Y)

    Function = SQR(PX+PY)
End Function

Function getRandom(Byval imin as Integer, Byval imax as Integer) as Integer
    Dim rndnum as Integer
    Dim as Integer min, max

    min = imin : max = imax
    If min>max then swap min,max

    rndnum = min + int( rnd*( max - (min-1) ) )

    return rndnum
End Function

Type tMaze
    Private:
    Declare Sub fillPath(byval posX as Integer, byval posY as Integer)
    Declare Sub fillPath2(byval posX as Integer, byval posY as Integer)

    MazeControl as Integer
    MazeStack   as UInteger

    MazeP as ubyte ptr
    MazeW as integer
    MazeH as integer

    Public:
    Declare Function genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
    Declare Function delMaze() as Integer

    Declare Function drawMaze(byval Wallsize as Integer = 10) as any ptr'for tests only
End Type

Sub tMaze.fillPath(byval posX as Integer, byval posY as Integer)

    MazeStack += 1

    Dim mappos as Integer
    mappos = posX+(posY*MazeW)

    If MazeP[mappos] = MazeFloor Then MazeP[mappos] = MazeReachPath

    If MazeP[mappos] = MazeGoal Then MazeControl = 1

    If (MazeStack < 8048) Then
        If (posX > 0)         and MazeP[mappos-1]     < MazeReachPath Then fillPath(posX-1,posY)
        If (posY > 0)         and MazeP[mappos-MazeW] < MazeReachPath Then fillPath(posX,posY-1)
        If (posX < (MazeW-1)) and MazeP[mappos+1]     < MazeReachPath Then fillPath(posX+1,posY)
        If (posY < (MazeH-1)) and MazeP[mappos+MazeW] < MazeReachPath Then fillPath(posX,posY+1)
    End If

    mazeStack -= 1
End Sub

Sub tMaze.fillPath2(byval posX as Integer, byval posY as Integer)
    Dim fillmap as byte ptr = NEW byte[MazeW*MazeH]
    Dim fillList as tList
    Dim fillNode as tListNode ptr

    Dim as Integer fX = posX
    Dim as Integer fY = posY
    Dim mappos as Integer = fX+(fY*MazeW)

    fillList.AddEntry(mappos)
    fillmap[mappos] = 1

    Do
        fillNode = fillList.FirstEntry
        If fillNode Then
            mappos = fillNode -> EntryValue
            fillList.DelEntry(fillNode)
        Else
            Exit Do
        End If

        fX = mappos mod MazeW
        fY = mappos \ MazeW

        If (fX > 0)         andalso ( (fillmap[mappos-1]     = 0) and (MazeP[mappos-1]     < MazeWall) ) Then fillList.AddEntry(mappos-1)     : fillmap[mappos-1]     = 1
        If (fY > 0)         andalso ( (fillmap[mappos-MazeW] = 0) and (MazeP[mappos-MazeW] < MazeWall) ) Then fillList.AddEntry(mappos-MazeW) : fillmap[mappos-MazeW] = 1
        If (fX < (MazeW-1)) andalso ( (fillmap[mappos+1]     = 0) and (MazeP[mappos+1]     < MazeWall) ) Then fillList.AddEntry(mappos+1)     : fillmap[mappos+1]     = 1
        If (fY < (MazeH-1)) andalso ( (fillmap[mappos+MazeW] = 0) and (MazeP[mappos+MazeW] < MazeWall) ) Then fillList.AddEntry(mappos+MazeW) : fillmap[mappos+MazeW] = 1
    Loop

    mappos = 0
    Do
        if (fillmap[mappos] = 1) Then
            If (MazeP[mappos] = MazeFloor) Then MazeP[mappos] = MazeReachPath
            If (MazeP[mappos] = MazeGoal ) Then MazeControl = 1
        End If

        mappos += 1
    Loop while (mappos < (MazeW*MazeH))

    Delete[] fillmap
    fillList.DestroyList()
End Sub




Function tMaze.drawMaze(byval Wallsize as Integer = 10) as any ptr
    If (MazeP = 0) or (MazeW = 0) or (MazeH = 0) Then return 0

    Dim mappos as Integer
    Dim C      as UInteger
    Dim startc as Vector2
    Dim goalc  as Vector2

    Dim MapImage as any ptr = ImageCreate(MazeW*WallSize,MazeH*WallSize)

    For Y as Integer = 0 to MazeH-1
        For X as Integer = 0 to MazeW-1
            mappos = X+(Y*MazeW)

            Select Case mazeP[mappos]
                Case MazeFloor
                    C = &h222222
                Case MazeStart
                    C = &h00FF00
                    startc.X = (Wallsize/2)+(X*Wallsize) : startc.Y = (Wallsize/2)+(Y*Wallsize)
                Case MazeGoal
                    C = &hFFFF00
                    goalc.X = (Wallsize/2)+(X*Wallsize) : goalc.Y = (Wallsize/2)+(Y*Wallsize)
                Case MazeWall
                    C = &hFFFFFF
                Case MazeReachPath 'important to know, to set items and monsters... (or anything else...)
                    C = &h6666FF'&h222222
                Case Else
                    C = &hFF8800
            End Select

            line MapImage,(X*Wallsize,Y*Wallsize)-((Wallsize-1)+(X*Wallsize),(Wallsize-1)+(Y*Wallsize)),C,bf
        Next X
    Next Y

    'start'n'goal help circles
    circle MapImage,(startc.X,startc.Y),100,&hFF0000'&h00FF00
    circle MapImage,(startc.X,startc.Y),Wallsize*4,&h00FF00
    circle MapImage,(goalc.X,goalc.Y),100,&hFF0000'&hFFFF00
    circle MapImage,(goalc.X,goalc.Y),Wallsize*4,&hFFFF00

    return MapImage
End Function


Function tMaze.genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer


    Dim MazeS as Vector2 'start position
    Dim MazeG as Vector2 'goal position
    Dim granularity  as Integer
    Dim randomLength as Integer
    Dim minLength    as Integer
    Dim maxLength    as Integer
    Dim numWalls     as Integer
    Dim rndWallPosX  as Integer
    Dim rndWallPosY  as Integer
    Dim rndDest      as Integer
    Dim dX           as Integer
    Dim dY           as Integer
    Dim mappos       as Integer

    Do
        If MazeP Then delMaze()
        MazeW = sizeW : MazeH = sizeH

        If (MazeW mod 2) = 0 Then MazeW -= 1
        If (MazeH mod 2) = 0 Then MazeH -= 1

        If (MazeW < 9) Then MazeW = 9
        If (MazeH < 9) Then MazeH = 9

        MazeP = NEW ubyte[MazeW*MazeH]

        'gen outwalls
        For WallW as Integer = 0 to MazeW-1
            MazeP[WallW] = MazeWall
            MazeP[((MazeH-1)*MazeW)+WallW] = MazeWall
        Next WallW

        For WallH as Integer = 0 to MazeH-1
            MazeP[WallH*MazeW] = MazeWall
            MazeP[(MazeW-1)+(WallH*MazeW)] = MazeWall
        Next WallH


        'gen random start position
        Do : MazeS.X = getRandom(1,MazeW-2) : Loop while ((MazeS.X mod 2) = 0)
        Do : MazeS.Y = getRandom(1,MazeH-2) : Loop while ((MazeS.Y mod 2) = 0)

        'gen random goal position (with minimal distance)
        Do
            Do : MazeG.X = getRandom(1,MazeW-2) : Loop while ((MazeG.X mod 2) = 0)
            Do : MazeG.Y = getRandom(1,MazeH-2) : Loop while ((MazeG.Y mod 2) = 0)
        Loop while (Distance2i(MazeS,MazeG) < 4)

        MazeP[MazeS.X+(MazeS.Y*MazeW)]=MazeStart
        MazeP[MazeG.X+(MazeG.Y*MazeW)]=MazeGoal

        For G as Integer = 4 to 1 step -1
            granularity = 2 ^ G '...16,8,4,2
            numWalls = (MazeW*MazeH)/G

            For W as Integer = 1 to numWalls '1 to...
                rndWallPosX = granularity * (getRandom(1,MazeW-1) \ granularity)
                rndWallPosY = granularity * (getRandom(1,MazeH-1) \ granularity)

                minLength   = getRandom(1,4)
                maxLength   = getRandom(2,10)

                rndDest     = getRandom(0,3)

                Select Case rndDest
                    Case 0 'North/Up
                        dX =  0 : dY = -1
                    Case 1 'East/Right
                        dX =  1 : dY =  0
                    Case 2 'South/Down
                        dX =  0 : dY =  1
                    Case 3 'West/Left
                        dX = -1 : dY =  0
                End Select

                randomLength = granularity * (getRandom(minLength,maxLength)+1)

                For L as Integer = 1 to randomLength
                    mappos = (rndWallPosX + (rndWallPosY*MazeW))
                    If MazeP[mappos] <> MazeFloor Then Exit For
                    MazeP[mappos] = MazeWall
                    rndWallPosX += dX : rndWallPosY += dY
                Next L

            Next W

        Next G

        'fillPath(MazeS.X,MazeS.Y) 'mark all reachable tiles (from start)
        fillPath2(MazeS.X,MazeS.Y) 'mark all reachable tiles (from start)
        If (MazeControl = 0) Then ?"Repeat"
    Loop until MazeControl 'not necassary | just for sure, the goal is reachable from start

    Return -1'TRUE
End Function

Function tMaze.delMaze() as Integer
    If MazeP Then Delete[] MazeP
    'If MazeP Then deallocate(MazeP)
    MazeP = 0
    MazeStack   = 0
    MazeControl = 0
    MazeW = 0
    MazeH = 0

    return -1'TRUE
End Function


''''TEST
screenres 1920,1080,32,,&h08

Dim myMaze as tMaze
Dim mapMaze as any ptr
Dim mappos as UInteger
Dim savenum as UInteger
Dim cycles as UInteger
Dim sizex as integer
dim sizey as integer

do
    cycles += 1

    'sizex=getRandom(50,80)
    'sizey=getRandom(40,60)

    myMaze.genMaze(1920,1080)
    mapMaze = myMaze.drawMaze(1)

    screenlock
        cls
        put(0,0),mapMaze,pset
    screenunlock

    sleep
    myMaze.delMaze()
    imagedestroy(mapMaze)
    mapMaze = 0
loop until multikey(&h01)