Wave Function Collapse

[aadityap0901]

Hello, this is my first post. 
I don't know where to post this, this place looked likely.

I learnt WFC yesterday, and it seemed easy, so I thought I would code and share it as my first program on this new forum:
If anyone wants to change images, you can change it in LoadImage function.
I wanna see how people use this idea, please share your creative designs (if possible)  .

Code: (Select All)

Screen _NewImage(640, 640, 32)



Type Tile

    As _Byte Omit 'BULDR in bits

    As _Byte STATE

End Type



Const TILE_STATE_BLANK = 1, TILE_STATE_UP = 2, TILE_STATE_LEFT = 3, TILE_STATE_DOWN = 4, TILE_STATE_RIGHT = 5



Dim As Tile Tile_Empty, Tiles(1 To 64, 1 To 64), Tile_Up, Tile_Down, Tile_Left, Tile_Right



Dim As Long TileImages(0 To 5): For I = 0 To 5: TileImages(I) = LoadImage(I): Next I



'Place a random tile at center'

Randomize Timer: RandomTile Tiles(16 + CInt(Rnd * 32), 16 + CInt(Rnd * 32))



'Start the loop

S = 1

Do

    Cls

    '_Limit 16

    If S = 0 Or Stuck Then

        If S = 0 Then _Title "Finished" Else _Title "Stuck"

        Do

            _Limit 60

            If _KeyDown(32) Then Run

            If _KeyDown(27) Then System

        Loop

    Else

        S = 0

        For I = 1 To 64

            For J = 1 To 64

                If J > 1 Then Tile_Up = Tiles(I, J - 1) Else Tile_Up = Tile_Empty

                If J < 64 Then Tile_Down = Tiles(I, J + 1) Else Tile_Down = Tile_Empty

                If I < 64 Then Tile_Right = Tiles(I + 1, J) Else Tile_Right = Tile_Empty

                If I > 1 Then Tile_Left = Tiles(I - 1, J) Else Tile_Left = Tile_Empty

                UpdateTile Tiles(I, J), Tile_Up, Tile_Down, Tile_Left, Tile_Right

                If J > 1 Then Tiles(I, J - 1) = Tile_Up

                If J < 64 Then Tiles(I, J + 1) = Tile_Down

                If I < 64 Then Tiles(I + 1, J) = Tile_Right

                If I > 1 Then Tiles(I - 1, J) = Tile_Left

                If Tiles(I, J).STATE Then _Continue

                If TryTile(Tiles(I, J)) = 0 Then Stuck = -1

                S = S + 1

        Next J, I

    End If

    _Title "Working"

    For I = 1 To 64: For J = 1 To 64: _PutImage (I * 10 - 10, J * 10 - 10)-(I * 10 - 1, J * 10 - 1), TileImages(Tiles(I, J).STATE): Next J, I

    _Display

Loop

System

'--------------

Sub RandomTile (T As Tile)

    Dim __T As Tile

    T.STATE = Int(Rnd * 5) + 1

    UpdateTile T, __T, __T, __T, __T

End Sub

Sub UpdateTile (T As Tile, TU As Tile, TD As Tile, TL As Tile, TR As Tile)

    Select Case T.STATE

        Case TILE_STATE_BLANK

            TU.Omit = TU.Omit Or &B00111

            TD.Omit = TD.Omit Or &B01101

            TL.Omit = TL.Omit Or &B01011

            TR.Omit = TR.Omit Or &B01110

        Case TILE_STATE_UP

            TU.Omit = TU.Omit Or &B11000

            TD.Omit = TD.Omit Or &B01101

            TL.Omit = TL.Omit Or &B10100

            TR.Omit = TR.Omit Or &B10001

        Case TILE_STATE_DOWN

            TU.Omit = TU.Omit Or &B00111

            TD.Omit = TD.Omit Or &B10010

            TL.Omit = TL.Omit Or &B10100

            TR.Omit = TR.Omit Or &B10001

        Case TILE_STATE_LEFT

            TU.Omit = TU.Omit Or &B11000

            TD.Omit = TD.Omit Or &B10010

            TL.Omit = TL.Omit Or &B10100

            TR.Omit = TR.Omit Or &B01110

        Case TILE_STATE_RIGHT

            TU.Omit = TU.Omit Or &B11000

            TD.Omit = TD.Omit Or &B10010

            TL.Omit = TL.Omit Or &B01011

            TR.Omit = TR.Omit Or &B10001

    End Select

End Sub

Function TryTile (T As Tile)

    Options$ = "BULDR"

    SetOptions$ = ""

    If T.Omit And &B10000 Then Asc(Options$, 1) = 0

    If T.Omit And &B01000 Then Asc(Options$, 2) = 0

    If T.Omit And &B00100 Then Asc(Options$, 3) = 0

    If T.Omit And &B00010 Then Asc(Options$, 4) = 0

    If T.Omit And &B00001 Then Asc(Options$, 5) = 0

    For I = 1 To 5

        If Asc(Options$, I) > 0 Then SetOptions$ = SetOptions$ + Chr$(Asc(Options$, I))

    Next I

    If Len(SetOptions$) = 0 Then Exit Function

    If Len(SetOptions$) < 4 Then STATE = Asc(SetOptions$, Int(Rnd * Len(SetOptions$)) + 1)

    Select Case STATE

        Case 66: T.STATE = TILE_STATE_BLANK

        Case 85: T.STATE = TILE_STATE_UP

        Case 76: T.STATE = TILE_STATE_LEFT

        Case 68: T.STATE = TILE_STATE_DOWN

        Case 82: T.STATE = TILE_STATE_RIGHT

    End Select

    TryTile = -1

End Function

Function LoadImage& (I)

    Select Case I

        Case 0: LoadImage& = load_Empty&

        Case 1: LoadImage& = load_Blank&

        Case 2: LoadImage& = load_Up&

        Case 3: LoadImage& = load_Left&

        Case 4: LoadImage& = load_Down&

        Case 5: LoadImage& = load_Right&

    End Select

End Function

Function load_Empty&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Empty_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Empty = O&

    Exit Function

    Empty_data:

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

End Function

Function load_Blank&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Blank_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Blank = O&

    Exit Function

    Blank_data:

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

End Function

Function load_Up&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Up_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Up = O&

    Exit Function

    Up_data:

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

End Function

Function load_Left&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Left_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Left = O&

    Exit Function

    Left_data:

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

End Function

Function load_Down&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Down_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Down = O&

    Exit Function

    Down_data:

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

End Function

Function load_Right&

    O& = _NewImage(5, 5, 32)

    __Dest = _Dest: _Dest O&

    Restore Right_data

    For __X = 0 To 4: For __Y = 0 To 5

            Read __P&

            PSet (__X, __Y), __P&

    Next __Y, __X

    _Dest __Dest

    load_Right = O&

    Exit Function

    Right_data:

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,&HFF00CFD4,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

    Data &HFF1D2B3A,&HFF1D2B3A,&HFF00CFD4,&HFF1D2B3A,&HFF1D2B3A,

End Function

[bplus]

Welcome again @aadityap0901

a little introduction:
I think Aaditya is rising star like Ashish, only 18 years old from India. I had to invite here because of the work I've seen at the other forum and just about to start college.

I haven't tried the code yet but am sure it will be interesting

[bplus]

Ah cool, luv it!
   

Nice graphic, now to study it to see what makes it tick

This is way different than other bit of code I'd seen under Wave Collapse Function title.

[a740g]

Welcome to the QB64-PE forum Aaditya. 

[bplus]

Ah there's a guy whose brain you might wanna pick!

[aadityap0901]

Added a new tile and increased the size of the grid

  WaveFunctionCollapse.zip (Size: 2.87 KB / Downloads: 130)

[bplus]

Nice you cut the LOC by half by replacing DATA with images looks like it tiles in trapazoid screen fills now also.

[aadityap0901]

WFC based Sudoku Solver, cannot solve hard sudokus unfortunately 
An example sudoku is loaded, but you can use arrow keys and numbers from 0 to 9 (0 to clear) to input in grid...
Hit enter and see the magic

Code: (Select All)

Screen _NewImage(18, 11, 0)

DefLng A-Z

Dim Grid(1 To 9, 1 To 9) As _Unsigned _Byte

Dim Omit(1 To 9, 1 To 9) As _Unsigned _Bit * 9

For I = 1 To 9: For J = 1 To 9

        Read Grid(J, I)

Next J, I

Color 15, 0

PX = 1: PY = 1

Do

    Cls , 0

    _Limit 60

    K$ = InKey$: Select Case K$

        Case "0" To "9": Grid(PX, PY) = Val(K$): PX = PX + 1: If PX = 10 Then PX = 1: PY = PY + 1

            If PY = 10 Then PY = 1

        Case Chr$(13): Exit Do

        Case Chr$(27): System

        Case Chr$(0) + "H": If PY > 1 Then PY = PY - 1

        Case Chr$(0) + "P": If PY < 9 Then PY = PY + 1

        Case Chr$(0) + "K": If PX > 1 Then PX = PX - 1

        Case Chr$(0) + "M": If PX < 9 Then PX = PX + 1

    End Select

    For I = 1 To 9

        For J = 1 To 9

            If PX = J And PY = I Then Color , 3 Else Color , 0

            If Grid(J, I) Then Print Str$(Grid(J, I)); Else Print "  ";

            If J = 9 Then Print

    Next J, I

    _Display

Loop

_Title "Working"

Do

    S = 0

    Cls , 0

    _Limit 10

    GoSub UpdateOmit

    For I = 1 To 9

        For J = 1 To 9

            '-------Solve-------

            If Grid(J, I) = 0 Then

                S = S + 1

            End If

            If Omit(J, I) Then

                For K = 1 To 9

                    If _SetBit(Omit(J, I), K - 1) = 511 Then

                        Grid(J, I) = K

                        Exit For

                    End If

                Next K

            End If

            '-------------------

            '------Display------

            If Grid(J, I) Then Print Str$(Grid(J, I)); Else Print "  ";

            If J = 9 Then Print

            '-------------------

    Next J, I

    _Display

Loop While S

_Title "Done"

_Delay 1

Sleep

System

UpdateOmit:

For I = 1 To 9

    For J = 1 To 9

        For K = 1 To 9

            If K = I Then _Continue

            If Grid(K, J) Then Omit(I, J) = _SetBit(Omit(I, J), Grid(K, J) - 1)

        Next K

        For K = 1 To 9

            If K = J Then _Continue

            If Grid(I, K) Then Omit(I, J) = _SetBit(Omit(I, J), Grid(I, K) - 1)

        Next K

        __I = 3 * ((I - 1) \ 3)

        __J = 3 * ((J - 1) \ 3)

        For II = __I + 1 To __I + 3

            For JJ = __J + 1 To __J + 3

                If II = I And JJ = J Then _Continue

                If Grid(II, JJ) Then Omit(I, J) = _SetBit(Omit(I, J), Grid(II, JJ) - 1)

        Next JJ, II

Next J, I

Return

Data 9,0,6,3,4,0,8,1,0

Data 0,5,1,7,0,0,3,0,0

Data 4,7,0,0,9,1,0,0,5

Data 0,0,0,9,0,3,0,0,2

Data 0,0,2,0,8,7,0,0,0

Data 1,0,7,2,0,0,6,0,0

Data 0,8,5,0,0,9,1,0,0

Data 0,3,4,0,6,0,0,0,9

Data 0,1,0,5,0,8,7,0,6

[bplus]

Yeah I tried an Intermediate puzzle from my Sudoku app

Code: (Select All)

Data 0,0,4,0,0,7,5,0,0
Data 0,6,0,0,0,0,0,0,0
Data 0,8,7,9,2,0,3,0,0
Data 0,0,0,0,5,0,0,3,2
Data 0,2,0,0,0,0,1,0,4
Data 1,0,0,0,4,0,8,0,5
Data 8,0,0,0,7,2,0,0,3
Data 0,5,0,0,0,0,6,1,0
Data 7,0,0,1,6,5,0,2,0

It got a couple lines solved but stopped
   

What is encouraging is that the numbers it did fill in were correct.