#Include Once "cairo/cairo.bi"

#Ifndef NULL
#Define NULL 0
#EndIf

#Ifndef VA_UBOUND
#Define VA_UBOUND(ARRAY) ARRAY##_UBound

#MACRO VARARRAY(ARRAY, VARTYPE)
    ARRAY As VARTYPE Ptr = NULL
    ARRAY##_UBound As Integer = -1
#EndMacro

#Macro VA_FREE(ARRAY)
    If ARRAY <> NULL Then Delete[] ARRAY
    ARRAY = NULL
    ARRAY##_UBound = -1
#EndMacro

#MACRO VA_REDIM(ARRAY, NEW_UBOUND, VARTYPE)
    If ARRAY <> NULL Then Delete[] ARRAY
    ARRAY##_UBound = (NEW_UBOUND)
    ARRAY = New VARTYPE[ARRAY##_UBound + 1]
#EndMacro

'ReDim Preserve shortened to ReDimP
#MACRO VA_REDIMP(ARRAY, NEW_UBOUND, VARTYPE)
    If ARRAY = NULL Then
        ARRAY = New VARTYPE[(NEW_UBOUND) + 1]
    Else
        Scope
            Dim Temp_Array_Ptr As VARTYPE Ptr = New VARTYPE[(NEW_UBOUND) + 1]
            Dim Temp_Array_Index As Integer
            If (NEW_UBOUND) > ARRAY##_UBound Then
                For Temp_Array_Index = 0 To ARRAY##_UBound
                    Temp_Array_Ptr[Temp_Array_Index] = ARRAY[Temp_Array_Index]
                Next Temp_Array_Index
            Else
                For Temp_Array_Index = 0 To (NEW_UBOUND)
                    Temp_Array_Ptr[Temp_Array_Index] = ARRAY[Temp_Array_Index]
                Next Temp_Array_Index
            End If
            Delete[] ARRAY
            ARRAY = Temp_Array_Ptr
        End Scope
    End If
    ARRAY##_UBound = (NEW_UBOUND)
#EndMacro
#EndIf 'VA_UBOUND

Public Type DoublePoint
    X As Double
    Y As Double
End Type

Public Type CurvePoints
    VARARRAY(InplPt, Integer) 'lpPoint
    NextTanContCurve As Integer 'lpCurve
    PrevTanContCurve As Integer 'lpCurve
    Declare Destructor()
End Type
Destructor CurvePoints()
    VA_FREE(InplPt)
End Destructor

Public Type BShape
    VARARRAY(Seg, Integer) 'lpCurve
    Color As Integer
    CurveThickness As Integer
    LineColor As Integer
    
    Closed As Short
    ShadeShape As Integer 'lpShape
    Declare Destructor()
End Type
Destructor BShape()
    VA_FREE(Seg)
End Destructor

Public Type BShapeData
    VARARRAY(PointArray, DoublePoint)
    VARARRAY(CurveArray, CurvePoints)
    VARARRAY(ShapeArray, BShape)
    Declare Destructor()
End Type
Destructor BShapeData()
    VA_FREE(PointArray)
    VA_FREE(CurveArray)
    VA_FREE(ShapeArray)
End Destructor

Public Type BShapeHeader
    ScreenScale As Double
    ScreenShift As DoublePoint
    ScreenWidth As Integer
    ScreenHeight As Integer
End Type

Public Type DrawCurve
    VARARRAY(Pts, DoublePoint)
    Declare Operator Let(ByRef Seg As DrawCurve)
    Declare Destructor()
End Type
Operator DrawCurve.Let(ByRef Seg As DrawCurve)
    Dim I As Integer
    VA_ReDim(Pts, VA_UBound(Seg.Pts), DoublePoint)
    For I = 0 To VA_UBound(Pts)
        Pts[I] = Seg.Pts[I]
    Next I
End Operator
Destructor DrawCurve()
    VA_FREE(Pts)
End Destructor

Public Type DrawShape
    VARARRAY(Seg, DrawCurve)
    Color As Integer
    Thickness As Integer
    SrcShape As Integer 'lpShape
    Declare Operator Let(ByRef S As DrawShape)
    Declare Destructor()
End Type
Operator DrawShape.Let(ByRef S As DrawShape)
    Dim I As Integer
    VA_ReDim(Seg, VA_UBound(S.Seg), DrawCurve)
    For I = 0 To VA_UBound(Seg)
        Seg[I] = S.Seg[I]
    Next I
    Color = S.Color
    Thickness = S.Thickness
    SrcShape = S.SrcShape
End Operator
Destructor DrawShape()
    VA_FREE(Seg)
End Destructor

Public Function EuclidGCD(ByVal A As Integer, ByVal B As Integer) As Integer
    Do While A <> 0
        B = B Mod A
        If B = 0 Then Return A
        A = A Mod B
    Loop
    Return B
End Function

Public Sub ComputeBiezierPoints(SD As BShapeData, ShapeI As Integer, Pts() As DoublePoint)
    Dim I As Integer, J As Integer, K As Integer, CurveI As Integer
    
    Dim Tan1 As DoublePoint, Tan2 As DoublePoint, CurveI2 As Integer
    Dim P0 As Integer, P1 As Integer, P2 As Integer, P3 As Integer
    
    ReDim Pts(3) As DoublePoint
    
    For I = 0 To VA_UBound(SD.ShapeArray[ShapeI].Seg)
        CurveI = SD.ShapeArray[ShapeI].Seg[I]
        For J = 1 To VA_UBound(SD.CurveArray[CurveI].InplPt)
            P0 = 0
            P3 = 0
            If J > 1 Then
                P0 = SD.CurveArray[CurveI].InplPt[J - 2]
               Else
                CurveI2 = SD.CurveArray[CurveI].PrevTanContCurve
                If CurveI2 <> 0 Then
                    If CurveI2 > 0 Then
                        P0 = SD.CurveArray[CurveI2].InplPt[VA_UBound(SD.CurveArray[CurveI2].InplPt) - 1]
                       Else
                        P0 = SD.CurveArray[-CurveI2].InplPt[1]
                    End If
                End If
            End If
            P1 = SD.CurveArray[CurveI].InplPt[J - 1]
            P2 = SD.CurveArray[CurveI].InplPt[J]
            If J + 1 <= VA_UBound(SD.CurveArray[CurveI].InplPt) Then
                P3 = SD.CurveArray[CurveI].InplPt[J + 1]
               Else
                CurveI2 = SD.CurveArray[CurveI].NextTanContCurve
                If CurveI2 <> 0 Then
                    If CurveI2 > 0 Then
                        P3 = SD.CurveArray[CurveI2].InplPt[1]
                       Else
                        P3 = SD.CurveArray[-CurveI2].InplPt[VA_UBound(SD.CurveArray[-CurveI2].InplPt) - 1]
                    End If
                End If
            End If
            
            If P0 > 0 Then
                Tan2.X = (SD.PointArray[P2].X - SD.PointArray[P0].X) / 6 + SD.PointArray[P1].X
                Tan2.Y = (SD.PointArray[P2].Y - SD.PointArray[P0].Y) / 6 + SD.PointArray[P1].Y
               Else
                Tan2.X = SD.PointArray[P1].X
                Tan2.Y = SD.PointArray[P1].Y
            End If
            If P3 > 0 Then
                Tan1.X = (SD.PointArray[P1].X - SD.PointArray[P3].X) / 6 + SD.PointArray[P2].X
                Tan1.Y = (SD.PointArray[P1].Y - SD.PointArray[P3].Y) / 6 + SD.PointArray[P2].Y
               Else
                Tan1.X = SD.PointArray[P2].X
                Tan1.Y = SD.PointArray[P2].Y
            End If
            
            If (J + K) * 3 > UBound(Pts) Then ReDim Preserve Pts(2 * UBound(Pts)) As DoublePoint
            Pts((J + K) * 3 - 3) = SD.PointArray[P1]
            Pts((J + K) * 3 - 2) = Tan2
            Pts((J + K) * 3 - 1) = Tan1
            Pts((J + K) * 3 - 0) = SD.PointArray[P2]
        Next J
        K = K + J - 1
    Next I
    ReDim Preserve Pts(K * 3) As DoublePoint
End Sub

Public Function Modula(Numerator As Double, Denominator As Double) As Double
    Return Numerator - Fix(Numerator / Denominator) * Denominator
End Function

Public Function DoubleBCurveOfT(T As Double, Pts() As DoublePoint, PtI As Integer) As DoublePoint
    Dim TT As Double, S As Double, SS As Double, R As DoublePoint
    S = 1 - T
    TT = T * T
    SS = S * S
    R.X = Pts(PtI).X * SS * S + 3 * Pts(PtI + 1).X * T * SS + 3 * Pts(PtI + 2).X * TT * S + Pts(PtI + 3).X * T * TT
    R.Y = Pts(PtI).Y * SS * S + 3 * Pts(PtI + 1).Y * T * SS + 3 * Pts(PtI + 2).Y * TT * S + Pts(PtI + 3).Y * T * TT
    Return R
End Function

Public Function dBCurveOfTdT(T As Double, Pts() As DoublePoint, PtI As Integer) As DoublePoint
    Dim A As Double, B As Double, C As Double, R As DoublePoint
    A = Pts(PtI + 3).X - 3 * Pts(PtI + 2).X + 3 * Pts(PtI + 1).X - Pts(PtI).X
    B = 2 * (Pts(PtI + 2).X - 2 * Pts(PtI + 1).X + Pts(PtI).X)
    C = Pts(PtI + 1).X - Pts(PtI).X
    R.X = A * T * T + B * T + C
    A = Pts(PtI + 3).Y - 3 * Pts(PtI + 2).Y + 3 * Pts(PtI + 1).Y - Pts(PtI).Y
    B = 2 * (Pts(PtI + 2).Y - 2 * Pts(PtI + 1).Y + Pts(PtI).Y)
    C = Pts(PtI + 1).Y - Pts(PtI).Y
    R.Y = A * T * T + B * T + C
    Return R
End Function

Public Sub SplitBCurve(T1 As Double, T2 As Double, Pts() As DoublePoint, PtI As Integer, RetP() As DoublePoint, RetPtI As Integer)
    RetP(RetPtI) = DoubleBCurveOfT(T1, Pts(), PtI)
    RetP(RetPtI + 1) = dBCurveOfTdT(T1, Pts(), PtI)
    RetP(RetPtI + 2) = dBCurveOfTdT(T2, Pts(), PtI)
    RetP(RetPtI + 3) = DoubleBCurveOfT(T2, Pts(), PtI)
    RetP(RetPtI + 1).X = RetP(RetPtI + 1).X * (T2 - T1) + RetP(RetPtI).X
    RetP(RetPtI + 1).Y = RetP(RetPtI + 1).Y * (T2 - T1) + RetP(RetPtI).Y
    RetP(RetPtI + 2).X = RetP(RetPtI + 3).X - RetP(RetPtI + 2).X * (T2 - T1)
    RetP(RetPtI + 2).Y = RetP(RetPtI + 3).Y - RetP(RetPtI + 2).Y * (T2 - T1)
End Sub

Public Sub SplitPolyCurve(T1 As Double, T2 As Double, Pts() As DoublePoint, RetP() As DoublePoint, ByRef RetPtI As Integer)
    Dim I As Integer
    If Int(T1) = Int(T2) Then
        SplitBCurve Modula(T1, 1), Modula(T2, 1), Pts(), Int(T1) * 3, RetP(), RetPtI
        RetPtI = RetPtI + 3
       Else
        If 1 - Modula(T1, 1) > 0.0000000001 Then
            SplitBCurve Modula(T1, 1), 1, Pts(), Int(T1) * 3, RetP(), RetPtI
            RetPtI = RetPtI + 3
        End If
        For I = (Int(T1) + 1) * 3 To (Int(T2) - 1) * 3 Step 3
            'SplitBCurve 0, 1, Pts, I * 3, RetP, RetPtI
            RetP(RetPtI) = Pts(I)
            RetP(RetPtI + 1) = Pts(I + 1)
            RetP(RetPtI + 2) = Pts(I + 2)
            RetP(RetPtI + 3) = Pts(I + 3)
            RetPtI = RetPtI + 3
        Next I
        If Modula(T2, 1) > 0.0000000001 Then
            SplitBCurve 0, Modula(T2, 1), Pts(), Int(T2) * 3, RetP(), RetPtI
            RetPtI = RetPtI + 3
        End If
    End If
End Sub

Public Sub FillPointArray(SD As BShapeData, ShapeI As Integer, Pts() As DoublePoint, N As Integer)
    Dim P() As DoublePoint, T As Double, I As Integer
    ComputeBiezierPoints SD, ShapeI, P()
    
    For T = 0 To (UBound(P) \ 3) * (N - 0.5) / N Step (UBound(P) \ 3) / N
        SplitPolyCurve T, T + (UBound(P) \ 3) / N, P(), Pts(), I
    Next T
End Sub

Public Function ColorBlend(T As Double, ColorA As Integer, ColorB As Integer) As Integer
    Dim S As Double, R As Integer
    S = 1 - T
    R = Int(S * (ColorA \ 256 \ 256) + T * (ColorB \ 256 \ 256))
    R = R * 256 + Int(S * ((ColorA \ 256) Mod 256) + T * ((ColorB \ 256) Mod 256))
    R = R * 256 + Int(S * (ColorA Mod 256) + T * (ColorB Mod 256))
    Return R
End Function

Public Sub InterpolatePointArrays(T As Double, Pts() As DoublePoint, A() As DoublePoint, B() As DoublePoint)
    Dim I As Integer, S As Double
    S = 1 - T
    ReDim Pts(UBound(A)) As DoublePoint
    For I = 0 To UBound(A)
        Pts(I).X = S * A(I).X + T * B(I).X
        Pts(I).Y = S * A(I).Y + T * B(I).Y
    Next I
End Sub

Public Sub ComputeDrawShapes(SD As BShapeData, SH As BShapeHeader, DrawArray() As DrawShape)
    Dim I As Integer, J As Integer, K As Integer, L As Integer, CurveI As Integer
    Dim ShapeA() As DoublePoint, ShapeB() As DoublePoint, ShapeI As Integer, M As Integer
    Dim ShapeC() As DoublePoint, ShapeD() As DoublePoint, T As Double
    Dim Pts() As DoublePoint
    
    ReDim DrawArray(1) As DrawShape
    J = 1
    For I = 1 To VA_UBound(SD.ShapeArray)
        DrawArray(J).SrcShape = I
        VA_ReDim(DrawArray(J).Seg, 0, DrawCurve)
        ComputeBiezierPoints SD, I, Pts()
        VA_ReDim(DrawArray(J).Seg[0].Pts, UBound(Pts), DoublePoint)
        For K = 0 To VA_UBound(DrawArray(J).Seg[0].Pts)
            DrawArray(J).Seg[0].Pts[K].X = (Pts(K).X - SH.ScreenShift.X) / SH.ScreenScale
            DrawArray(J).Seg[0].Pts[K].Y = (Pts(K).Y - SH.ScreenShift.Y) / SH.ScreenScale
        Next K
        
        If SD.ShapeArray[I].Closed Then
            DrawArray(J).Thickness = -1
            DrawArray(J).Color = SD.ShapeArray[I].Color
            If J = UBound(DrawArray) Then ReDim Preserve DrawArray(UBound(DrawArray) * 2) As DrawShape
            If SD.ShapeArray[I].ShadeShape > 0 Then
                '----------------------------------------------------------------------------------
                ' Shaded Shape
                '----------------------------------------------------------------------------------
                
                ShapeI = SD.ShapeArray[I].ShadeShape
                L = 0
                For K = 0 To VA_UBound(SD.ShapeArray[I].Seg)
                    L = L + VA_UBound(SD.CurveArray[SD.ShapeArray[I].Seg[K]].InplPt)
                Next K
                M = 0
                For K = 0 To VA_UBound(SD.ShapeArray[ShapeI].Seg)
                    M = M + VA_UBound(SD.CurveArray[SD.ShapeArray[ShapeI].Seg[K]].InplPt)
                Next K
                K = EuclidGCD(L, M)
                
                ReDim ShapeA((L + M - K) * 3) As DoublePoint
                ReDim ShapeB(UBound(ShapeA)) As DoublePoint
                
                FillPointArray SD, I, ShapeA(), M
                FillPointArray SD, ShapeI, ShapeB(), L
                
                T = 0
                For K = 0 To UBound(ShapeA)
                    If (ShapeA(K).X - ShapeB(K).X) ^ 2 + (ShapeA(K).Y - ShapeB(K).Y) ^ 2 > T Then
                        T = (ShapeA(K).X - ShapeB(K).X) ^ 2 + (ShapeA(K).Y - ShapeB(K).Y) ^ 2
                    End If
                Next K
                T = Sqr(T) / SH.ScreenScale
                If T > 100 Then
                    L = 100
                   Else
                    L = Int(T) + 2
                End If
                
                For T = 2 / L To 1 + 0.5 / L Step 1 / L
                    InterpolatePointArrays T - 2 / L, ShapeD(), ShapeA(), ShapeB()
                    InterpolatePointArrays T, ShapeC(), ShapeA(), ShapeB()
                    J = J + 1
                    VA_ReDim(DrawArray(J).Seg, 1, DrawCurve)
                    VA_ReDim(DrawArray(J).Seg[0].Pts, UBound(ShapeD), DoublePoint)
                    VA_ReDim(DrawArray(J).Seg[1].Pts, UBound(ShapeC), DoublePoint)
                    DrawArray(J).Color = ColorBlend(T - 1 / L, SD.ShapeArray[I].Color, SD.ShapeArray[ShapeI].Color)
                    DrawArray(J).SrcShape = DrawArray(J - 1).SrcShape
                    DrawArray(J).Thickness = -1
                    For K = 0 To UBound(ShapeD)
                        DrawArray(J).Seg[0].Pts[K].X = (ShapeD(K).X - SH.ScreenShift.X) / SH.ScreenScale
                        DrawArray(J).Seg[0].Pts[K].Y = (ShapeD(K).Y - SH.ScreenShift.Y) / SH.ScreenScale
                    Next K
                    For K = 0 To UBound(ShapeC)
                        DrawArray(J).Seg[1].Pts[K].X = (ShapeC(K).X - SH.ScreenShift.X) / SH.ScreenScale
                        DrawArray(J).Seg[1].Pts[K].Y = (ShapeC(K).Y - SH.ScreenShift.Y) / SH.ScreenScale
                    Next K
                    If J = UBound(DrawArray) Then ReDim Preserve DrawArray(UBound(DrawArray) * 2) As DrawShape
                Next T
                Va_ReDimP(DrawArray(J).Seg, 0, DrawCurve)
                
                J = J + 1
                DrawArray(J) = DrawArray(J - L)
               Else
                ' Solid Shape
                J = J + 1
                DrawArray(J) = DrawArray(J - 1)
            End If
        End If
        'Path Boundary
        DrawArray(J).Thickness = SD.ShapeArray[I].CurveThickness
        DrawArray(J).Color = SD.ShapeArray[I].LineColor
        If J = UBound(DrawArray) Then ReDim Preserve DrawArray(UBound(DrawArray) * 2) As DrawShape
        J = J + 1
    Next I
    ReDim Preserve DrawArray(J - 1) As DrawShape
End Sub

Public Sub CairoDrawShape(cr As cairo_t Ptr, S As DrawShape)
    Dim I As Integer, J As Integer
    
    If S.Thickness = 0 Then Exit Sub
    cairo_set_source_rgb(cr, (S.Color And &H000000FF) / 256.0, (S.Color Shr 8 And &H000000FF) / 256.0, (S.Color Shr 16 And &H000000FF) / 256.0)
    For I = 0 To VA_UBound(S.Seg)
        cairo_move_to(cr, S.Seg[I].Pts[0].X, S.Seg[I].Pts[0].Y)
        For J = 1 To VA_UBound(S.Seg[I].Pts) Step 3
            cairo_curve_to(cr, S.Seg[I].Pts[J].X, S.Seg[I].Pts[J].Y, S.Seg[I].Pts[J+1].X, S.Seg[I].Pts[J+1].Y, S.Seg[I].Pts[J+2].X, S.Seg[I].Pts[J+2].Y)
        Next J
        J = VA_UBound(S.Seg[I].Pts)
        If S.Seg[I].Pts[0].X = S.Seg[I].Pts[J].X And S.Seg[I].Pts[0].Y = S.Seg[I].Pts[J].Y Then cairo_close_path(cr)
    Next I
    If S.Thickness < 0 Then
        cairo_set_fill_rule(cr, CAIRO_FILL_RULE_EVEN_ODD)
        cairo_fill(cr)
       Else
        cairo_set_line_cap(cr, CAIRO_LINE_CAP_ROUND)
        cairo_set_line_join(cr, CAIRO_LINE_JOIN_ROUND)
        cairo_set_line_width(cr, S.Thickness)
        cairo_stroke(cr)
    End If
End Sub

Public Sub ReadShapes(iFileNum As Integer, SD As BShapeData)
    Dim I As Integer, lTmp As Integer
    Get #iFileNum, , lTmp
    VA_ReDim(SD.PointArray, lTmp, DoublePoint)
    Get #iFileNum, , *SD.PointArray, lTmp + 1
    Get #iFileNum, , lTmp
    VA_ReDim(SD.CurveArray, lTmp, CurvePoints)
    For I = 1 To VA_UBound(SD.CurveArray)
        Get #iFileNum, , lTmp
        VA_ReDim(SD.CurveArray[I].InplPt, lTmp, Integer)
        Get #iFileNum, , *SD.CurveArray[I].InplPt, lTmp + 1
        Get #iFileNum, , SD.CurveArray[I].NextTanContCurve
        Get #iFileNum, , SD.CurveArray[I].PrevTanContCurve
    Next I
    Get #iFileNum, , lTmp
    VA_ReDim(SD.ShapeArray, lTmp, BShape)
    For I = 1 To VA_UBound(SD.ShapeArray)
        Get #iFileNum, , lTmp
        VA_ReDim(SD.ShapeArray[I].Seg, lTmp, Integer)
        Get #iFileNum, , *SD.ShapeArray[I].Seg, lTmp + 1
        Get #iFileNum, , SD.ShapeArray[I].Color
        Get #iFileNum, , SD.ShapeArray[I].CurveThickness
        Get #iFileNum, , SD.ShapeArray[I].LineColor
        Get #iFileNum, , SD.ShapeArray[I].Closed
        Get #iFileNum, , SD.ShapeArray[I].ShadeShape
        SD.ShapeArray[I].Color = SD.ShapeArray[I].Color And &HFFFFFF
        SD.ShapeArray[I].LineColor = SD.ShapeArray[I].LineColor And &HFFFFFF
    Next I
End Sub

' Returns "" for success, an error description string for failure
Public Function LoadShapeFile(SD As BShapeData, SH As BShapeHeader, FileName As String) As String
    Dim lTemp As Integer, sTemp As String * 17, bData() As Byte
    If FileName = "" Or Dir(FileName) = "" Then
        LoadShapeFile = "Cannot Find File: " & Chr(13) & Chr(10) & """" & FileName & """"
        Exit Function
    End If
    Open FileName For Binary As #1
        Get #1, , sTemp 'Identification Header
        If sTemp <> "Vast2D Shape File" And sTemp <> "Vast3D Shape File" Then
            Close #1
            LoadShapeFile = "Bad File Format: " & Chr(13) & Chr(10) & """" & FileName & """" & Chr(13) & Chr(10) & "Shape file header not recognized."
            Exit Function
        End If
        Do Until Loc(1) >= LOF(1)
            Get #1, , lTemp
            Select Case lTemp
            Case 1 'Header
                Get #1, , lTemp
                If lTemp >= 32 Then
                    Get #1, , SH.ScreenScale
                    Get #1, , SH.ScreenShift
                    Get #1, , SH.ScreenWidth
                    Get #1, , SH.ScreenHeight
                    lTemp = lTemp - 32
                End If
                If lTemp > 0 Then
                    ReDim bData(lTemp - 1) As Byte
                    Get #1, , bData()
                End If
            Case 2 'Shape Data
                Get #1, , lTemp
                ReadShapes 1, SD
            Case Else 'Unknown Extension
                Get #1, , lTemp
                ReDim bData(lTemp - 1) As Byte
                Get #1, , bData()
            End Select
        Loop
    Close #1
End Function