Data update

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

@@ -0,0 +1,213 @@
+' 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