Option Strict Off
Option Explicit On
Module modShapeAPI
	Public Structure DoublePoint
		Dim X As Double
		Dim Y As Double
	End Structure
	
	Public Structure CurvePoints
		Dim InplPt() As Integer 'lpPoint
		Dim NextTanContCurve As Integer 'lpCurve
		Dim PrevTanContCurve As Integer 'lpCurve
	End Structure
	
	Public Structure BShape
		Dim Seg() As Integer 'lpCurve
		Dim Color As Integer
		Dim CurveThickness As Integer
		Dim LineColor As Integer
		Dim Closed As Boolean
		Dim ShadeShape As Integer 'lpShape
	End Structure
	
	Public Structure BShapeData
		Dim PointArray() As DoublePoint
		Dim CurveArray() As CurvePoints
		Dim ShapeArray() As BShape
	End Structure
	
	Public Structure BShapeHeader
		Dim ScreenScale As Double
		Dim ScreenShift As DoublePoint
		Dim ScreenWidth As Integer
		Dim ScreenHeight As Integer
	End Structure
	
	Public Structure GDICurve
		Dim Pt() As POINT
	End Structure
	
	Public Structure GDIShape
		Dim Seg() As GDICurve
		Dim Color As Integer
		Dim Thickness As Integer
		Dim SrcShape As Integer 'lpShape
	End Structure
	
	
	Public Sub ComputeGDIShapes(ByRef SD As BShapeData, ByRef SH As BShapeHeader, ByRef GDIArray() As GDIShape)
		Dim L, J, I, K, CurveI As Integer
		Dim ShapeA() As DoublePoint
		Dim ShapeB() As DoublePoint
		Dim ShapeI As Integer
		Dim M As Integer
		Dim ShapeC() As DoublePoint
		Dim T As Double
		Dim ScreenPts() As POINT
		
		ReDim ScreenPts(UBound(SD.PointArray))
		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)
		J = 1
		For I = 1 To UBound(SD.ShapeArray)
			GDIArray(J).SrcShape = I
			ReDim GDIArray(J).Seg(UBound(SD.ShapeArray(I).Seg))
			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)
				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)
				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)
					ReDim ShapeB(UBound(ShapeA))
					
					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 = System.Math.Sqrt(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)
						ReDim GDIArray(J).Seg(0).Pt(UBound(ShapeC))
						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)
					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)
			J = J + 1
		Next I
		ReDim Preserve GDIArray(J - 1)
	End Sub
	
	Public Sub ComputeTanControlPts(ByRef SD As BShapeData, ByRef SH As BShapeHeader, ByRef CurveI As Integer, ByRef PointI As Integer, ByRef Seg As GDICurve)
		Dim Tan1, Tan2 As DoublePoint
		Dim CurveI2 As Integer
		Dim P2, P0, P1, P3 As Integer
		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(ByRef SD As BShapeData, ByRef ShapeI As Integer, ByRef Pts() As DoublePoint)
		Dim K, I, J, CurveI As Integer
		
		Dim Tan1, Tan2 As DoublePoint
		Dim CurveI2 As Integer
		Dim P2, P0, P1, P3 As Integer
		
		ReDim Pts(3)
		
		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))
				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)
	End Sub
	
	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 EuclidGCD = A : Exit Function
			A = A Mod B
		Loop 
		EuclidGCD = B
	End Function
	
	Public Sub FillPointArray(ByRef SD As BShapeData, ByRef ShapeI As Integer, ByRef Pts() As DoublePoint, ByRef N As Integer)
		Dim P() As DoublePoint
		Dim T As Double
		Dim 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 Sub SplitPolyCurve(ByRef T1 As Double, ByRef T2 As Double, ByRef Pts() As DoublePoint, ByRef 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 Function Modula(ByRef Numerator As Double, ByRef Denominator As Double) As Double
		Modula = Numerator - Fix(Numerator / Denominator) * Denominator
	End Function
	
	Public Function DoubleBCurveOfT(ByRef T As Double, ByRef Pts() As DoublePoint, ByRef PtI As Integer) As DoublePoint
		Dim S, TT, 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(ByRef T As Double, ByRef Pts() As DoublePoint, ByRef PtI As Integer) As DoublePoint
		Dim B, A, 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(ByRef T1 As Double, ByRef T2 As Double, ByRef Pts() As DoublePoint, ByRef PtI As Integer, ByRef RetP() As DoublePoint, ByRef 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 Function ColorBlend(ByRef T As Double, ByRef ColorA As Integer, ByRef ColorB As Integer) As Integer
		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(ByRef T As Double, ByRef Pts() As DoublePoint, ByRef A() As DoublePoint, ByRef B() As DoublePoint)
		Dim I As Integer
		Dim S As Double
		S = 1 - T
		ReDim Pts(UBound(A))
		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 GraphicsDrawGDIShape(ByRef G As Graphics, ByRef S As GDIShape)
        Dim I As Integer

		If S.Thickness = 0 Then Exit Sub
        Dim P As New System.Drawing.Drawing2D.GraphicsPath
		For I = 0 To UBound(S.Seg)
            P.AddBeziers(S.Seg(I).Pt)
		Next I
		If S.Thickness = -1 Then
            Dim B As New SolidBrush(System.Drawing.Color.FromArgb(S.Color Mod 256, S.Color\256 Mod 256, S.Color \256\256))
            G.FillPath(B, P)
            B.Dispose
           Else
            Dim Pen As New Pen(System.Drawing.Color.FromArgb(S.Color Mod 256, S.Color\256 Mod 256, S.Color \256\256))
            Pen.Width = S.Thickness
            Pen.LineJoin = Drawing2D.LineJoin.Round
            Pen.EndCap = Drawing2D.LineCap.Round
            G.DrawPath(Pen, P)
            Pen.Dispose
		End If
        P.Dispose
	End Sub
	
	' Returns "" for success, an error description string for failure
	Public Function LoadShapeFile(ByRef SD As BShapeData, ByRef SH As BShapeHeader, ByRef FileName As String) As String
		Dim lTemp As Integer
		Dim sTemp(16) As Byte  ' New VB6.FixedLengthString(17)
        Dim uTemp(16) As Char
        Dim Str As String
		Dim Data() As Byte
		ReDim SD.PointArray(0)
		ReDim SD.CurveArray(0)
		ReDim SD.ShapeArray(0)
		If FileName = "" Or Dir(FileName) = "" Then
			LoadShapeFile = "Cannot Find File: " & vbCrLf & """" & FileName & """"
			Exit Function
		End If
		FileOpen(1, FileName, OpenMode.Binary)
		FileGet(1, sTemp) 'Identification Header
        sTemp.CopyTo(uTemp, 0)
        Str = New String(uTemp)
		If Str <> "Vast2D Shape File" And Str <> "Vast3D Shape File" Then
			LoadShapeFile = "Bad File Format: " & vbCrLf & """" & FileName & """" & vbCrLf & "Shape file header not recognized."
			FileClose(1)
			Exit Function
		End If
		Do Until Loc(1) >= LOF(1)
			FileGet(1, lTemp)
			Select Case lTemp
				Case 1 'Header
					FileGet(1, lTemp)
					If lTemp >= 32 Then
						FileGet(1, SH.ScreenScale)
						FileGet(1, SH.ScreenShift)
						FileGet(1, SH.ScreenWidth)
						FileGet(1, SH.ScreenHeight)
						lTemp = lTemp - 32
					End If
					If lTemp > 0 Then
						ReDim Data(lTemp - 1)
						FileGet(1, Data)
					End If
				Case 2 'Shape Data
					FileGet(1, lTemp)
					ReadShapes(1, SD)
				Case Else 'Unknown Extension
					FileGet(1, lTemp)
					ReDim Data(lTemp - 1)
					FileGet(1, Data)
			End Select
		Loop 
		FileClose(1)
	End Function
	
	Public Sub ReadShapes(ByRef iFileNum As Short, ByRef SD As BShapeData)
		Dim I, lTmp As Integer
		FileGet(iFileNum, lTmp)
		ReDim SD.PointArray(lTmp)
		FileGet(iFileNum, SD.PointArray)
		FileGet(iFileNum, lTmp)
		ReDim SD.CurveArray(lTmp)
		For I = 1 To UBound(SD.CurveArray)
			FileGet(iFileNum, lTmp)
			ReDim SD.CurveArray(I).InplPt(lTmp)
			FileGet(iFileNum, SD.CurveArray(I).InplPt)
			FileGet(iFileNum, SD.CurveArray(I).NextTanContCurve)
			FileGet(iFileNum, SD.CurveArray(I).PrevTanContCurve)
		Next I
		FileGet(iFileNum, lTmp)
		ReDim SD.ShapeArray(lTmp)
		For I = 1 To UBound(SD.ShapeArray)
			FileGet(iFileNum, lTmp)
			ReDim SD.ShapeArray(I).Seg(lTmp)
			FileGet(iFileNum, SD.ShapeArray(I).Seg)
			FileGet(iFileNum, SD.ShapeArray(I).Color)
			FileGet(iFileNum, SD.ShapeArray(I).CurveThickness)
			FileGet(iFileNum, SD.ShapeArray(I).LineColor)
			FileGet(iFileNum, SD.ShapeArray(I).Closed)
			FileGet(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
End Module