RosettaCodeData/Task/Faces-from-a-mesh/FreeBASIC/faces-from-a-mesh.basic

' Check if a dynamic array contains a value
Function contains(s() As Integer, f As Integer) As Boolean
    For i As Integer = 0 To Ubound(s)
        If s(i) = f Then Return True
    Next
    Return False
End Function

' Check if two dynamic arrays are equal
Function sliceEqual(s1() As Integer, s2() As Integer) As Boolean
    If Ubound(s1) <> Ubound(s2) Then Return False

    For i As Integer = 0 To Ubound(s1)
        If s1(i) <> s2(i) Then Return False
    Next
    Return True
End Function

' Reverse a dynamic array in place
Sub reverse(s() As Integer)
    Dim As Integer i, j
    For i = 0 To (Ubound(s) + 1) \ 2 - 1
        j = Ubound(s) - i
        Swap s(i), s(j)
    Next
End Sub

' Check if two perimeters are equal
Function perimEqual(p1() As Integer, p2() As Integer) As Boolean
    Dim As Integer le = Ubound(p1) + 1
    If le <> Ubound(p2) + 1 Then Return False

    Dim As Integer i, r, t, j
    For i = 0 To Ubound(p1)
        If Not contains(p2(), p1(i)) Then Return False
    Next

    Dim As Integer c(Ubound(p1))
    For i = 0 To Ubound(p1)
        c(i) = p1(i)
    Next

    For r = 0 To 1
        For i = 0 To le - 1
            If sliceEqual(c(), p2()) Then Return True

            ' Circular shift to right
            t = c(le - 1)
            For j = le - 1 To 1 Step -1
                c(j) = c(j - 1)
            Next
            c(0) = t
        Next
        reverse(c())
    Next

    Return False
End Function

Type edge
    e(0 To 1) As Integer
End Type

' Translate a face to perimeter format
Function faceToPerim(face() As edge) As Integer Ptr
    Dim As Integer le = Ubound(face) + 1
    If le = 0 Then Return 0

    Dim edges(0 To le - 1) As edge
    Dim As Integer i, j
    For i = 0 To le - 1
        If face(i).e(1) <= face(i).e(0) Then Return 0
        edges(i) = face(i)
    Next

    ' Sort edges (bubble sort for simplicity)
    For i = 0 To le - 2
        For j = 0 To le - 2 - i
            If edges(j).e(0) > edges(j + 1).e(0) Or _
            (edges(j).e(0) = edges(j + 1).e(0) And _
            edges(j).e(1) > edges(j + 1).e(1)) Then
                Dim As edge temp = edges(j)
                edges(j) = edges(j + 1)
                edges(j + 1) = temp
            End If
        Next
    Next

    Dim As Integer Ptr perim = Callocate((le + 1) * Sizeof(Integer))
    Dim As Integer perimCount = 0, first = edges(0).e(0), last = edges(0).e(1)

    perim[perimCount] = first : perimCount += 1
    perim[perimCount] = last : perimCount += 1

    le -= 1
    For i = 0 To le - 1
        edges(i) = edges(i + 1)
    Next

    Do While le > 0
        Dim As Boolean found = False
        For i = 0 To le - 1
            If edges(i).e(0) = last Then
                perim[perimCount] = edges(i).e(1) : perimCount += 1
                last = edges(i).e(1)
                found = True
            Elseif edges(i).e(1) = last Then
                perim[perimCount] = edges(i).e(0) : perimCount += 1
                last = edges(i).e(0)
                found = True
            End If

            If found Then
                For j = i To le - 2
                    edges(j) = edges(j + 1)
                Next
                le -= 1
                If last = first Then
                    If le = 0 Then
                        ' Remove the last element (which is equal to the first)
                        perimCount -= 1
                        ' Terminate the array with a -1
                        perim[perimCount] = -1
                        Return perim
                    Else
                        Deallocate(perim)
                        Return 0
                    End If
                End If
                Exit For
            End If
        Next
        If Not found Then
            Deallocate(perim)
            Return 0
        End If
    Loop

    ' Terminate the array with a -1
    perim[perimCount] = -1
    Return perim
End Function

'Main program
Print "Perimeter format equality checks:"

Dim As Integer q(2) = {8, 1, 3}
Dim As Integer r(2) = {1, 3, 8}
Dim As Boolean areEqual = perimEqual(q(), r())
Print "  Q == R is "; areEqual

Dim As Integer u(6) = {18, 8, 14, 10, 12, 17, 19}
Dim As Integer v(6) = {8, 14, 10, 12, 17, 19, 18}
areEqual = perimEqual(u(), v())
Print "  U == V is "; areEqual

Print !"\nEdge to perimeter format translations:"

Dim As edge e(0 To 2)
e(0).e(0) = 7 : e(0).e(1) = 11
e(1).e(0) = 1 : e(1).e(1) = 11
e(2).e(0) = 1 : e(2).e(1) = 7

Dim As edge f(0 To 3)
f(0).e(0) = 11 : f(0).e(1) = 23
f(1).e(0) = 1  : f(1).e(1) = 17
f(2).e(0) = 17 : f(2).e(1) = 23
f(3).e(0) = 1  : f(3).e(1) = 11

Dim As edge g(0 To 6)
g(0).e(0) = 8  : g(0).e(1) = 14
g(1).e(0) = 17 : g(1).e(1) = 19
g(2).e(0) = 10 : g(2).e(1) = 12
g(3).e(0) = 10 : g(3).e(1) = 14
g(4).e(0) = 12 : g(4).e(1) = 17
g(5).e(0) = 8  : g(5).e(1) = 18
g(6).e(0) = 18 : g(6).e(1) = 19

Dim As edge h(0 To 3)
h(0).e(0) = 1 : h(0).e(1) = 3
h(1).e(0) = 9 : h(1).e(1) = 11
h(2).e(0) = 3 : h(2).e(1) = 11
h(3).e(0) = 1 : h(3).e(1) = 11

Dim As Integer Ptr perim
Dim As edge Ptr faces(3) = {@e(0), @f(0), @g(0), @h(0)}
Dim As Integer faceSizes(3) = {3, 4, 7, 4}

Dim As Integer i, j
For i = 0 To 3
    Redim As edge face(0 To faceSizes(i) - 1)
    For j = 0 To faceSizes(i) - 1
        face(j) = faces(i)[j]
    Next

    perim = faceToPerim(face())

    If perim = 0 Then
        Print "  "; Chr(69 + i); " => Invalid edge format"
    Else
        Print "  "; Chr(69 + i); " =>";
        j = 0
        While perim[j] <> -1
            Print perim[j];
            If perim[j + 1] <> -1 Then Print ",";
            j += 1
        Wend
        Print
        Deallocate(perim)
    End If
Next

Sleep