'Ported to FreeBasic by UEZ build 2016-10-01

#Include "fbgfx.bi"
#Include "windows.bi"

Using FB

Declare Sub PythagorasTreeRec(ByRef hDC As Any Ptr, ByRef iX1 As Single, ByRef iY1 As Single, ByRef iX2 As Single, ByRef iY2 As Single, ByRef iRecDepth As UByte)
Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double
Declare Function cubicInterpolate(p As Single Ptr, x As Single) As Single
Declare Function bicubicInterpolate(p As Single Ptr, x As Single, y As Single) As Single

Const As UInteger iW = 1200, iH = 700

ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 24, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI Animated Pythagoras Tree v2.5 / FPS: "
WindowTitle sTitle

Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As BITMAPV5HEADER tBIV5HDR
tBIV5HDR.bV5Size = SizeOf(BITMAPV5HEADER)
tBIV5HDR.bV5Width = iW
tBIV5HDR.bV5Height = -iH
tBIV5HDR.bV5Planes = 1
tBIV5HDR.bV5BitCount = 32
tBIV5HDR.bV5Compression = 0 'BI_BITFIELDS
tBIV5HDR.bV5AlphaMask = &hFF000000
tBIV5HDR.bV5RedMask = 	&h00FF0000
tBIV5HDR.bV5GreenMask = &h0000FF00
tBIV5HDR.bV5BlueMask = 	&h000000FF
tBIV5HDR.bV5CSType = 2
tBIV5HDR.bV5Intent = 4


Dim As Any Ptr hDC = GetDC(hHWND), _
					hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
					hGfxDC = CreateCompatibleDC(hDC), _
					hCanvas, hBrush, hPen, hPath
					
Var hObjOld = SelectObject(hGfxDC, hHBitmap) 
hBrush = SelectObject(hGfxDC, GetStockObject(DC_BRUSH))
hPen = SelectObject(hGfxDC, GetStockObject(DC_Pen))
BitBlt(hGfxDC, 0, 0, iW, iH, hGfxDC, 0, 0, WHITENESS)

Dim Shared As Double i = 0
Dim As ULong iFPS = 0
Dim As Double fTime, fTimer

Dim evt As EVENT

fTimer = Timer

Do
	BitBlt(hGfxDC, 0, 0, iW, iH, hGfxDC, 0, 0, WHITENESS)

	PythagorasTreeRec(hGfxDC, 550, 700, 650, 700, 11)
	
	BitBlt(hDC, 0, 0, iW, iH, hGfxDC, 0, 0, SRCCOPY)
	
	If Timer - fTimer > 0.99 Then
		WindowTitle sTitle & iFPS
		iFPS = 0
		fTimer = Timer
	Else
		iFPS += 1
	EndIf
	
	If (ScreenEvent(@evt)) Then
		Select Case evt.Type 
			Case SC_ESCAPE, EVENT_WINDOW_CLOSE
				SelectObject(hGfxDC, hObjOld)
				ReleaseDC(hHWND, hDC)
				DeleteObject(hHBitmap)
				SelectObject(hGfxDC, hBrush)
				DeleteObject(hBrush)
				SelectObject(hGfxDC, hPen)
				DeleteObject(hPen)
				DeleteDC(hGfxDC)
				Exit Do
		End Select
	EndIf
	Sleep(10)
Loop

Sub PythagorasTreeRec(ByRef hDC As Any Ptr, ByRef iX1 As Single, ByRef iY1 As Single, ByRef iX2 As Single, ByRef iY2 As Single, ByRef iRecDepth As UByte)
	Dim As ULong iBGR1 = (255 - (iRecDepth + 10) * 10) Shl 8 + (iRecDepth * 20) Shl 0 'r=0
	Dim As Single dx = iX2 - iX1, dy = iY1 - iY2
	Dim As Single iX3 = iX2 - dy, iY3 = iY2 - dx
	Dim As Single iX4 = iX1 - dy, iY4 = iY1 - dx
	Dim As Single iX5 = iX4 + (dx - dy) / (2.5 - _Cos6th((iX4 + i) / 400) / 1.5)
	Dim As Single iY5 = iY4 - (dx + dy) / (2.25 + _Sin6th((iX5 + iY4 - i) / 500))
	i += 0.0025
	
	BeginPath(hDC)
	MoveToEx(hDC, iX1, iY1, NULL)
	LineTo(hDC, iX2, iY2)
	LineTo(hDC, iX3, iY3)
	LineTo(hDC, iX4, iY4)
	LineTo(hDC, iX1, iY1)
	EndPath(hDC)

	SetDCBrushColor(hDC, iBGR1)
	FillPath(hDC)
	'SetDCBrushColor(hDC, iBGR1 Or &h181818)
	'SetDCPenColor(hDC, iBGR1)
	'StrokeAndFillPath(hDC)
	
	If iRecDepth > 0 Then
		PythagorasTreeRec(hDC, iX4, iY4, iX5, iY5, iRecDepth - 1)
		PythagorasTreeRec(hDC, iX5, iY5, iX3, iY3, iRecDepth - 1)
	EndIf
End Sub

Function cubicInterpolate(p As Single Ptr, x As Single) As Single
   Return p[1] + _
      0.5 * x * ( p[2] - p[0] + _
         	x * ( 2.0 * p[0] - 5.0*p[1] + 4.0*p[2] - p[3] + _
            x * ( 3.0 * (p[1] - p[2]) + p[3] - p[0]) ) )
End Function

Function bicubicInterpolate(p As Single Ptr, x As Single, y As Single) As Single
   Dim As Single arr(3)
   arr(0) = cubicInterpolate(p +  0, y)
   arr(1) = cubicInterpolate(p +  4, y)
   arr(2) = cubicInterpolate(p +  8, y)
   arr(3) = cubicInterpolate(p + 12, y)
   Return cubicInterpolate(@arr(0), x)
End Function

Function _Sin6th(fX As Double) As Double 
   Asm 
      jmp _Sin6th_Start 
         _Sin6th_Mul: .double 683565275.57643158 
         _Sin6th_Div: .double -0.0000000061763971109087229 
         _Sin6th_Rnd: .double 6755399441055744.0 
       
      _Sin6th_Start: 
         movq xmm0, [fX] 
         mulsd xmm0, [_Sin6th_Mul] 
         addsd xmm0, [_Sin6th_Rnd] 
         movd ebx, xmm0 
    
         lea  eax, [ebx*2+0x80000000] 
         sar  eax, 2 
         imul eax 
         sar  ebx, 31 
         lea  eax, [edx*2-0x70000000] 
         lea  ecx, [edx*8+edx-0x24000000] 
         imul edx 
         xor  ecx, ebx 
         lea  eax, [edx*8+edx+0x44A00000] 
         imul ecx 
          
         cvtsi2sd xmm0, edx 
         mulsd xmm0, [_Sin6th_Div] 
         movq [Function], xmm0 
   End Asm 
End Function 

Function _Cos6th(fX As Double) As Double 
   Asm 
      jmp _Cos6th_Start 
         _Cos6th_Mul: .double 683565275.57643158 
         _Cos6th_Div: .double -0.0000000061763971109087229 
         _Cos6th_Rnd: .double 6755399441055744.0 
       
      _Cos6th_Start: 
         movq xmm0, [fX] 
         mulsd xmm0, [_Cos6th_Mul] 
         addsd xmm0, [_Cos6th_Rnd] 
         movd ebx, xmm0 
          
         add ebx, 0x40000000 'SinToCos 
    
         lea  eax, [ebx*2+0x80000000] 
         sar  eax, 2 
         imul eax 
         sar  ebx, 31 
         lea  eax, [edx*2-0x70000000] 
         lea  ecx, [edx*8+edx-0x24000000] 
         imul edx 
         xor  ecx, ebx 
         lea  eax, [edx*8+edx+0x44A00000] 
         imul ecx 
          
         cvtsi2sd xmm0, edx 
         mulsd xmm0, [_Cos6th_Div] 
         movq [Function], xmm0 
   End Asm 
End Function 