Attribute VB_Name = "modShapeAPI"
Option Explicit

Public Declare Function MoveToEx Lib "gdi32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByRef lpPoint As Any) As Integer
Public Declare Function PolyBezier Lib "gdi32.dll" (ByVal hDC As Long, lpPt As POINT, ByVal cPoints As Long) As Integer
Public Declare Function PolyBezierTo Lib "gdi32.dll" (ByVal hDC As Long, lpPt As POINT, ByVal cCount As Long) As Integer

Public Declare Function BeginPath Lib "gdi32.dll" (ByVal hDC As Long) As Integer
Public Declare Function EndPath Lib "gdi32.dll" (ByVal hDC As Long) As Integer
Public Declare Function FillPath Lib "gdi32.dll" (ByVal hDC As Long) As Integer

Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Public Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32.dll" (ByRef lplb As LOGBRUSH) As Long

Public Type LOGBRUSH
   lbStyle As Long
   lbColor As Long
   lbHatch As Long
End Type

Public Type POINT
    X As Long
    Y As Long
End Type

Public Type DoublePoint
    X As Double
    Y As Double
End Type

Public Type CurvePoints
    InplPt() As Long 'lpPoint
    NextTanContCurve As Long 'lpCurve
    PrevTanContCurve As Long 'lpCurve
End Type

Public Type BShape
    Seg() As Long 'lpCurve
    Color As Long
    CurveThickness As Long
    LineColor As Long
    
    Closed As Boolean
    ShadeShape As Long 'lpShape
End Type

Public Type BShapeData
    PointArray() As DoublePoint
    CurveArray() As CurvePoints
    ShapeArray() As BShape
End Type

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

Public Type GDICurve
    Pt() As POINT
End Type

Public Type GDIShape
    Seg() As GDICurve
    Color As Long
    Thickness As Long
    SrcShape As Long 'lpShape
End Type


Public Sub ComputeGDIShapes(SD As BShapeData, SH As BShapeHeader, GDIArray() As GDIShape)
    Dim I As Long, J As Long, K As Long, L As Long, CurveI As Long
    Dim ShapeA() As DoublePoint, ShapeB() As DoublePoint, ShapeI As Long, M As Long
    Dim ShapeC() As DoublePoint, T As Double
    Dim ScreenPts() As POINT
    
    ReDim ScreenPts(UBound(SD.PointArray)) As POINT
    For I = 1 To UBound(SD.PointArray)
        ScreenPts(I).X = (SD.PointArray(I).X - SH.ScreenShift.X) / SH.ScreenScale
        ScreenPts(I).Y = (SD.PointArray(I).Y - SH.ScreenShift.Y) / SH.ScreenScale
    Next I
    
    ReDim GDIArray(1) As GDIShape
    J = 1
    For I = 1 To UBound(SD.ShapeArray)
        GDIArray(J).SrcShape = I
        ReDim GDIArray(J).Seg(UBound(SD.ShapeArray(I).Seg)) As GDICurve
        For K = 0 To UBound(SD.ShapeArray(I).Seg)
            CurveI = SD.ShapeArray(I).Seg(K)
            ReDim GDIArray(J).Seg(K).Pt(UBound(SD.CurveArray(CurveI).InplPt) * 3) As POINT
            For L = 0 To UBound(SD.CurveArray(CurveI).InplPt)
                GDIArray(J).Seg(K).Pt(L * 3) = ScreenPts(SD.CurveArray(CurveI).InplPt(L))
            Next L
            For L = 1 To UBound(SD.CurveArray(CurveI).InplPt)
                ComputeTanControlPts SD, SH, CurveI, L, GDIArray(J).Seg(K)
            Next L
        Next K
        If SD.ShapeArray(I).Closed Then
            GDIArray(J).Thickness = -1
            GDIArray(J).Color = SD.ShapeArray(I).Color
            If J = UBound(GDIArray) Then ReDim Preserve GDIArray(UBound(GDIArray) * 2) As GDIShape
            If SD.ShapeArray(I).ShadeShape > 0 Then
                '----------------------------------------------------------------------------------
                ' Shaded Shape
                '----------------------------------------------------------------------------------
                
                ShapeI = SD.ShapeArray(I).ShadeShape
                L = 0
                For K = 0 To UBound(SD.ShapeArray(I).Seg)
                    L = L + UBound(SD.CurveArray(SD.ShapeArray(I).Seg(K)).InplPt)
                Next K
                M = 0
                For K = 0 To UBound(SD.ShapeArray(ShapeI).Seg)
                    M = M + 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 = 1 / L To 1 - 0.5 / L Step 1 / L
                    InterpolatePointArrays T, ShapeC, ShapeA, ShapeB
                    J = J + 1
                    ReDim GDIArray(J).Seg(0) As GDICurve
                    ReDim GDIArray(J).Seg(0).Pt(UBound(ShapeC)) As POINT
                    GDIArray(J).Color = ColorBlend(T, SD.ShapeArray(I).Color, SD.ShapeArray(ShapeI).Color)
                    GDIArray(J).SrcShape = GDIArray(J - 1).SrcShape
                    GDIArray(J).Thickness = -1
                    For K = 0 To UBound(ShapeC)
                        GDIArray(J).Seg(0).Pt(K).X = (ShapeC(K).X - SH.ScreenShift.X) / SH.ScreenScale
                        GDIArray(J).Seg(0).Pt(K).Y = (ShapeC(K).Y - SH.ScreenShift.Y) / SH.ScreenScale
                    Next K
                    If J = UBound(GDIArray) Then ReDim Preserve GDIArray(UBound(GDIArray) * 2) As GDIShape
                Next T
                
                J = J + 1
                GDIArray(J) = GDIArray(J - L)
               Else
                ' Solid Shape
                J = J + 1
                GDIArray(J) = GDIArray(J - 1)
            End If
        End If
        'Path Boundary
        GDIArray(J).Thickness = SD.ShapeArray(I).CurveThickness
        GDIArray(J).Color = SD.ShapeArray(I).LineColor
        If J = UBound(GDIArray) Then ReDim Preserve GDIArray(UBound(GDIArray) * 2) As GDIShape
        J = J + 1
    Next I
    ReDim Preserve GDIArray(J - 1) As GDIShape
End Sub

Public Sub ComputeTanControlPts(SD As BShapeData, SH As BShapeHeader, CurveI As Long, PointI As Long, Seg As GDICurve)
    Dim Tan1 As DoublePoint, Tan2 As DoublePoint, CurveI2 As Long
    Dim P0 As Long, P1 As Long, P2 As Long, P3 As Long
    If PointI > 0 Then
        If PointI > 1 Then
            P0 = SD.CurveArray(CurveI).InplPt(PointI - 2)
           Else
            CurveI2 = SD.CurveArray(CurveI).PrevTanContCurve
            If CurveI2 <> 0 Then
                If CurveI2 > 0 Then
                    P0 = SD.CurveArray(CurveI2).InplPt(UBound(SD.CurveArray(CurveI2).InplPt) - 1)
                   Else
                    P0 = SD.CurveArray(-CurveI2).InplPt(1)
                End If
            End If
        End If
        P1 = SD.CurveArray(CurveI).InplPt(PointI - 1)
        P2 = SD.CurveArray(CurveI).InplPt(PointI)
        If PointI + 1 <= UBound(SD.CurveArray(CurveI).InplPt) Then
            P3 = SD.CurveArray(CurveI).InplPt(PointI + 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(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
        
        Seg.Pt(PointI * 3 - 2).X = (Tan2.X - SH.ScreenShift.X) / SH.ScreenScale
        Seg.Pt(PointI * 3 - 2).Y = (Tan2.Y - SH.ScreenShift.Y) / SH.ScreenScale
        Seg.Pt(PointI * 3 - 1).X = (Tan1.X - SH.ScreenShift.X) / SH.ScreenScale
        Seg.Pt(PointI * 3 - 1).Y = (Tan1.Y - SH.ScreenShift.Y) / SH.ScreenScale
    End If
End Sub

Public Sub ComputeBiezierPoints(SD As BShapeData, ShapeI As Long, Pts() As DoublePoint)
    Dim I As Long, J As Long, K As Long, CurveI As Long
    
    Dim Tan1 As DoublePoint, Tan2 As DoublePoint, CurveI2 As Long
    Dim P0 As Long, P1 As Long, P2 As Long, P3 As Long
    
    ReDim Pts(3) As DoublePoint
    
    For I = 0 To UBound(SD.ShapeArray(ShapeI).Seg)
        CurveI = SD.ShapeArray(ShapeI).Seg(I)
        For J = 1 To 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(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 <= 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(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 EuclidGCD(ByVal A As Long, ByVal B As Long) As Long
    Do While A <> 0
        B = B Mod A
        If B = 0 Then EuclidGCD = A: Exit Function
        A = A Mod B
    Loop
    EuclidGCD = B
End Function

Public Sub FillPointArray(SD As BShapeData, ShapeI As Long, Pts() As DoublePoint, N As Long)
    Dim P() As DoublePoint, T As Double, I As Long
    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 Sub SplitPolyCurve(T1 As Double, T2 As Double, Pts() As DoublePoint, RetP() As DoublePoint, RetPtI As Long)
    Dim I As Long
    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 Function Modula(Numerator As Double, Denominator As Double) As Double
    Modula = Numerator - Fix(Numerator / Denominator) * Denominator
End Function

Public Function DoubleBCurveOfT(T As Double, Pts() As DoublePoint, PtI As Long) As DoublePoint
    Dim TT As Double, S As Double, SS As Double
    S = 1 - T
    TT = T * T
    SS = S * S
    DoubleBCurveOfT.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
    DoubleBCurveOfT.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
End Function

Public Function dBCurveOfTdT(T As Double, Pts() As DoublePoint, PtI As Long) As DoublePoint
    Dim A As Double, B As Double, C As Double
    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
    dBCurveOfTdT.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
    dBCurveOfTdT.Y = A * T * T + B * T + C
End Function

Public Sub SplitBCurve(T1 As Double, T2 As Double, Pts() As DoublePoint, PtI As Long, RetP() As DoublePoint, RetPtI As Long)
    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 Function ColorBlend(T As Double, ColorA As Long, ColorB As Long) As Long
    Dim S As Double
    S = 1 - T
    ColorBlend = Int(S * (ColorA \ 256 \ 256) + T * (ColorB \ 256 \ 256))
    ColorBlend = ColorBlend * 256 + Int(S * ((ColorA \ 256) Mod 256) + T * ((ColorB \ 256) Mod 256))
    ColorBlend = ColorBlend * 256 + Int(S * (ColorA Mod 256) + T * (ColorB Mod 256))
End Function

Public Sub InterpolatePointArrays(T As Double, Pts() As DoublePoint, A() As DoublePoint, B() As DoublePoint)
    Dim I As Long, 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 HdcDrawGDIShape(hDC As Long, S As GDIShape)
    Dim I As Long, hObj As Long, hObjOld As Long, lb As LOGBRUSH
    
    If S.Thickness = 0 Then Exit Sub
    If S.Thickness = -1 Then
        lb.lbStyle = 0 'BS_SOLID
        lb.lbColor = S.Color
        hObj = CreateBrushIndirect(lb)
        hObjOld = SelectObject(hDC, hObj)
        If CBool(BeginPath(hDC)) Then
            MoveToEx hDC, S.Seg(0).Pt(0).X, S.Seg(0).Pt(0).Y, ByVal 0
            For I = 0 To UBound(S.Seg)
                PolyBezierTo hDC, S.Seg(I).Pt(1), UBound(S.Seg(I).Pt)
            Next I
            If CBool(EndPath(hDC)) Then FillPath hDC
        End If
       Else
        hObj = CreatePen(0, S.Thickness, S.Color)
        hObjOld = SelectObject(hDC, hObj)
        For I = 0 To UBound(S.Seg)
            PolyBezier hDC, S.Seg(I).Pt(0), UBound(S.Seg(I).Pt) + 1
        Next I
    End If
    SelectObject hDC, hObjOld
    DeleteObject hObj
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 Long, sTemp As String * 17, Data() As Byte
    ReDim SD.PointArray(0) As DoublePoint
    ReDim SD.CurveArray(0) As CurvePoints
    ReDim SD.ShapeArray(0) As BShape
    If FileName = "" Or Dir(FileName) = "" Then
        LoadShapeFile = "Cannot Find File: " & vbCrLf & """" & 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
            LoadShapeFile = "Bad File Format: " & vbCrLf & """" & FileName & """" & vbCrLf & "Shape file header not recognized."
            Close #1
            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 Data(lTemp - 1) As Byte
                    Get #1, , Data
                End If
            Case 2 'Shape Data
                Get #1, , lTemp
                ReadShapes 1, SD
            Case Else 'Unknown Extension
                Get #1, , lTemp
                ReDim Data(lTemp - 1) As Byte
                Get #1, , Data
            End Select
        Loop
    Close #1
End Function

Public Sub ReadShapes(iFileNum As Integer, SD As BShapeData)
    Dim I As Long, lTmp As Long
    Get #iFileNum, , lTmp
    ReDim SD.PointArray(lTmp) As DoublePoint
    Get #iFileNum, , SD.PointArray
    Get #iFileNum, , lTmp
    ReDim SD.CurveArray(lTmp) As CurvePoints
    For I = 1 To UBound(SD.CurveArray)
        Get #iFileNum, , lTmp
        ReDim SD.CurveArray(I).InplPt(lTmp) As Long
        Get #iFileNum, , SD.CurveArray(I).InplPt
        Get #iFileNum, , SD.CurveArray(I).NextTanContCurve
        Get #iFileNum, , SD.CurveArray(I).PrevTanContCurve
    Next I
    Get #iFileNum, , lTmp
    ReDim SD.ShapeArray(lTmp) As BShape
    For I = 1 To UBound(SD.ShapeArray)
        Get #iFileNum, , lTmp
        ReDim SD.ShapeArray(I).Seg(lTmp) As Long
        Get #iFileNum, , SD.ShapeArray(I).Seg
        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