 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
Roland Chastain
Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
|
 Verfasst am: 18.09.2016, 08:35 Titel: Pythagoras-Baum (Cairo Beispiel) |
 |
|
Hallo!
Hier ist ein Pythagoras-Baum, mit Cairo gezeichnet.
Download Seite |
|
| Nach oben |
|
 |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 01.10.2016, 23:17 Titel: |
|
|
Hier die animierte GDI Version:
| Code: |
'Ported to FreeBasic by UEZ build 2016-10-01
#Include "fbgfx.bi"
#Include "windows.bi"
Using FB
Declare Sub PythagorasTreeRec(hDC As Any Ptr, iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double
Const As UInteger iW = 1000, iH = 600
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))
Dim Shared As Single 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, 450, 600, 550, 600, 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(hDC As Any Ptr, iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, 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.005
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)
SetDCPenColor(hDC, iBGR1)
SetDCBrushColor(hDC, iBGR1 Or &h305090)
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 _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
|
Läuft nur unter Windows.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 02.10.2016, 10:46 Titel: |
|
|
| UEZ hat Folgendes geschrieben: | | Läuft nur unter Windows. |
Ich fühle mich ausgegrenzt. 
| Code: |
'Ported to FreeBasic by UEZ build 2016-10-01
#Include "fbgfx.bi"
Using FB
Declare Sub PythagorasTreeRec(hDC As Any Ptr, iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double
Const As Integer iW = 1000, iH = 600
Dim As String sTitle = "GDI Animated Pythagoras Tree v2.5 / FPS: "
Dim As Image Ptr Image
Dim Shared As Single i = 0
Dim As ULong iFPS = 0
Dim As Double fTime, fTimer
Dim evt As EVENT
ScreenRes iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
WindowTitle sTitle
Image= ImageCreate (iW, iH, 0)
fTimer = Timer
Do
Clear (Image[SizeOf (FB.IMAGE)], &Hff, iW* iH* 4)
PythagorasTreeRec(Image, 450, 600, 550, 600, 11)
Put (0, 0), Image, PSet
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
Exit Do
End Select
EndIf
Sleep(2)
Loop
ImageDestroy (Image)
Sub PythagorasTreeRec(hDC As Any Ptr, iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, 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.005
PSet hDC, (iX1, iY1), 0 ''Line hDC, (iX1, iY1)-(iX1, iY1), 0
Line hDC, -(iX2, iY2), iBGR1
Line hDC, -(iX3, iY3), iBGR1
Line hDC, -(iX4, iY4), iBGR1
Line hDC, -(iX1, iY1), iBGR1
If iRecDepth > 0 Then
PythagorasTreeRec(hDC, iX4, iY4, iX5, iY5, iRecDepth - 1)
PythagorasTreeRec(hDC, iX5, iY5, iX3, iY3, iRecDepth - 1)
EndIf
End Sub
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
|
So kann man sich die Animation auch unter Linux anschauen. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 02.10.2016, 13:35 Titel: |
|
|
Ich muss mir bei Gelegenheit FB unter Linux installieren.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 02.10.2016, 18:51 Titel: |
|
|
@Elor: gibt es keine einfache Füllfunktion?
| Code: |
Sub PythagorasTreeRec(hDC As Any Ptr, iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Dim As ULong iBGR1 = (255 - (iRecDepth + 10) * 10) Shl 8 + (iRecDepth * 20) Shl 0, _
iBGR2 = (iRecDepth * 20) Shl 16 + (255 - (iRecDepth + 10) * 10) Shl 8
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.005
PSet hDC, (iX1, iY1), 0 ''Line hDC, (iX1, iY1)-(iX1, iY1), 0
Line hDC, -(iX2, iY2), iBGR1
Line hDC, -(iX3, iY3), iBGR1
Line hDC, -(iX4, iY4), iBGR1
Line hDC, -(iX1, iY1), iBGR1
Paint hDC, ((iX1 + iX3) / 2, (iY1 + iY3) / 2), iBGR2, iBGR1 'fill
If iRecDepth > 0 Then
PythagorasTreeRec(hDC, iX4, iY4, iX5, iY5, iRecDepth - 1)
PythagorasTreeRec(hDC, iX5, iY5, iX3, iY3, iRecDepth - 1)
EndIf
End Sub
|
Die internen Gfx Funktionen sind schneller als GDI, aber leider mit wenigen Funktionen.
GDI+ hat zwar viele Funktionen, ist aber relativ langsam.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Roland Chastain
Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
|
| Verfasst am: 05.10.2016, 13:12 Titel: |
|
|
@UEZ, Elor
Hübsch!  |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 05.10.2016, 15:39 Titel: |
|
|
| UEZ hat Folgendes geschrieben: |
@Elor: gibt es keine einfache Füllfunktion?
|
Ich persönlich kenne nur zwei Möglichkeiten um ein Polygon zu füllen, das ist zum einen PAINT, wie du das jetzt noch eingebaut hast (sieht so viel besser aus) und DRAW. Ich habe DRAW mit FreeBASIC noch nie benutzt, obwohl die SUB sehr mächtig ist (wie ich finde) weiß ich nicht ob es für Animationen geeignet ist. Das müsste einfach mal testen. |
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4713
Wohnort: ~/
|
| Verfasst am: 05.10.2016, 18:20 Titel: |
|
|
Also irgendwie muss ich bei dem Programm an einen wütenden Riesen denken, der den Benutzer zu packen versucht. 
Sieht gut aus, und läuft auch mit PAINT erstaunlich schnell!
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 06.10.2016, 10:42 Titel: |
|
|
| nemored hat Folgendes geschrieben: | | Also irgendwie muss ich bei dem Programm an einen wütenden Riesen denken, der den Benutzer zu packen versucht. grinsen |
Mir gings ähnlich, sieht aus aus wäre Hulk sauer
| nemored hat Folgendes geschrieben: | | ...und läuft auch mit PAINT erstaunlich schnell! |
Das hat mich auch ziemlich überrascht, hätte ich nicht so erwartet.
@UEZ:
Ich hab mal mit der DRAW-SUB herum gespielt und bin der Überzeugung das man die SUB in Sachen Animation getrost verbrennen kann. Mein Tipp: Nimm die Image mal raus und Zeichne direkt in den Bildspeicher. Beispiel:
| Code: |
ScreenRes iW, iH, 32,, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
WindowTitle sTitle
Color (, &HFFFFFF)
fTimer = Timer
Do
Cls ()
ScreenLock ()
PythagorasTreeRec(450, 600, 550, 600, 11)
ScreenUnLock ()
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
Exit Do
End Select
EndIf
Sleep(9)
Loop
Sub PythagorasTreeRec(iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Dim As ULong iBGR1 = (255 - (iRecDepth + 10) * 10) Shl 8 + (iRecDepth * 20) Shl 0 'r=0
Dim As uLong iBGR2 = (iRecDepth * 20) Shl 16 + (255 - (iRecDepth + 10) * 10) Shl 8
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.005
PSet (iX1, iY1), 0
'Draw ("BM"& Str(Int(iX1))& ","& Str(Int(iY1)))
Line -(iX2, iY2), iBGR1
Line -(iX3, iY3), iBGR1
Line -(iX4, iY4), iBGR1
Line -(iX1, iY1), iBGR1
Paint ((iX1 + iX3) / 2, (iY1 + iY3) / 2), iBGR2, iBGR1 'fill
If iRecDepth > 0 Then
PythagorasTreeRec(iX4, iY4, iX5, iY5, iRecDepth - 1)
PythagorasTreeRec(iX5, iY5, iX3, iY3, iRecDepth - 1)
EndIf
End Sub
|
Die Restlichen Funktionen muss man sich halt noch einbauen. Wie du sehen kannst, verwende ich hier PSET zum Positionieren des Grafik Cursor. Dort wird dann aber ein Punkt in der angegebenen Farbe gezeichnet. Mit DRAW kann man den Grafik Cursor auch verschieben ohne das etwas gezeichnet wird. Alleine diese Aktion hat schon einen deutlichen Geschwindigkeits Verlust zur folge. Außerdem müssen die Koordinaten als Integer vorliegen. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 06.10.2016, 13:06 Titel: |
|
|
Ist wirklich schneller als die Buffering Methode. , aber das Füllen ist an den Rändern nicht vollständig und die Kanten sehen ohne Filterung nicht "schön" aus.
Momentan versuche ich noch eine bilineare Filterung zu implementieren, um das Ganze ein bissl aufzuhübschen, was aber FPS kosten wird.
Apropos Buffering Methode, da ich in der Regel GDI+/GDI für solche Spielereien in AutoIt benutze, muss ich die Buffering Methode anwenden, da sonst die Animationen zu sehr "flimmern und ruckeln". In FB ist manches eben anders.
Die GDI+ Variante ist zwar "hübscher", aber auch wesentlich langsamer und nicht kompatible mit Linux, außer Wine.
| Code: |
'Ported to FreeBasic by UEZ build 2016-10-01
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "win\gdiplus.bi"
Using FB
Using GDIPLUS
Declare Sub PythagorasTreeRec(ByRef hGfx 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
Dim Shared gdipToken As ULONG_PTR
Dim GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
GdiplusStartup(@gdipToken, @GDIp, NULL)
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)
Dim Shared As Any Ptr hPath, hCanvas, hBrush, hPen
Var hObjOld = SelectObject(hGfxDC, hHBitmap)
GdipCreateFromHDC(hGfxDC, @hCanvas)
GdipSetSmoothingMode(hCanvas, 5)
GdipSetPixelOffsetMode(hCanvas, 4)
GdipCreatePath(0, @hPath)
GdipCreateSolidFill(0, @hBrush)
GdipCreatePen1(0, 1, 2, @hPen)
Dim Shared As Single 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(hCanvas, 550, 700, 650, 700, 9)
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)
DeleteDC(hGfxDC)
GdipDeleteGraphics(hCanvas)
GdipDeletePath(hPath)
GdipDeleteBrush(hBrush)
GdipDeletePen(hPen)
GdiplusShutdown(gdipToken)
Exit Do
End Select
EndIf
Sleep(10)
Loop
Sub PythagorasTreeRec(ByRef hGfx 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 = &hFF000000 + (iRecDepth * 20) Shl 16 + (255 - (iRecDepth + 10) * 10) Shl 8
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.015
GdipAddPathLine(hPath, iX1, iY1, iX2, iY2)
'GdipAddPathLine(hPath, iX2, iY2, iX3, iY3)
GdipAddPathLine(hPath, iX3, iY3, iX4, iY4)
'GdipAddPathLine(hPath, iX4, iY4, iX1, iY1)
GdipSetSolidFillColor(hBrush, iBGR1)
GdipFillPath(hGfx, hBrush, hPath)
'GdipSetPenColor(hPen, iBGR1 Or &hFF181818)
'GdipDrawPath(hCanvas, hPen, hPath) 'insane slow!
GdipResetPath(hPath)
If iRecDepth > 0 Then
PythagorasTreeRec(hGfx, iX4, iY4, iX5, iY5, iRecDepth - 1)
PythagorasTreeRec(hGfx, iX5, iY5, iX3, iY3, iRecDepth - 1)
EndIf
End Sub
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
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 06.10.2016, 14:36 Titel: |
|
|
Naja, die GDI Version kommt schon recht schleichend daher und hab mich gefragt, wie das ganze denn als 2D OpenGL Variante aussehen würde. Da mir sowieso langweilig ist hab ich das mal probiert. Hier die OGL2D Variante:
| Code: |
/' Program: Pythagoras_GL2D.bas '/
#lang "FB"
#include "fbgfx.bi"
#include "GL/gl.bi"
Declare Sub InitOpenGL (ByVal W As Integer, ByVal H As Integer)
Declare Sub PythagorasTreeRec(iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double
Dim As String sTitle = "GDI Animated Pythagoras Tree v2.5 / FPS: "
Dim As ULong iFPS = 0
Dim As Double fTime, fTimer
InitOpenGL(800, 600)
fTimer= Timer ()
Do
glClear (GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
PythagorasTreeRec(450, 600, 550, 600, 11)
glFlush ()
Flip ()
If(Timer - fTimer > 0.99) Then
WindowTitle (sTitle & iFPS)
iFPS = 0
fTimer = Timer
Else
iFPS += 1
EndIf
Sleep (2)
Loop Until Len (InKey)
/' --- Impementation --- '/
Sub InitOpenGL (ByVal W As Integer, ByVal H As Integer)
ScreenRes (W, H, 32,, FB.GFX_OPENGL)' Or FB.GFX_NO_SWITCH)
glMatrixMode(GL_PROJECTION)
glLoadIdentity ()
glViewport (0, 0, W, H)
glOrtho (0, W, H, 0, -128, 128)
glMatrixMode (GL_MODELVIEW)
glEnable (GL_CULL_FACE)
glCullFace (GL_BACK)
glLoadIdentity ()
glClearColor (1.0, 1.0, 1.0, 0.5)
glEnable (GL_DEPTH_TEST)
glDepthFunc (GL_LESS)
End Sub
Sub PythagorasTreeRec(iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Static i As Single= 0
Dim As ULong iBGR1 = (255 - (iRecDepth + 10) * 10) Shl 8 + (iRecDepth * 20) Shl 0 'r=0
Dim As uLong iBGR2 = (iRecDepth * 20) Shl 16 + (255 - (iRecDepth + 10) * 10) Shl 8
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.005
glBegin (GL_POLYGON)
glColor3ub (iBGR2 Shr 16, iBGR2 Shr 8 And &HFF, iBGR2 And &HFF)
glVertex2f (iX1, iY1)
glVertex2f (iX2, iY2)
glVertex2f (iX3, iY3)
glVertex2f (iX4, iY4)
glVertex2f (iX1, iY1)
glEnd ()
If(iRecDepth > 0) Then
PythagorasTreeRec(iX4, iY4, iX5, iY5, iRecDepth - 1)
PythagorasTreeRec(iX5, iY5, iX3, iY3, iRecDepth - 1)
End If
End Sub
|
Damit es nicht zu lange wird hab ich hier die Funktionen _Sin6th und _Cos6th weggelassen (bitte selber einfügen).
Das ganze läuft sehr flüssig und FPS mäßig sehr stabil. Ob das jetzt für jemanden der lieber die GDI verwendet etwas ist.... Ich weiß es nicht? |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 06.10.2016, 14:57 Titel: |
|
|
Also, OpenGL rennt ja im Vergleich zu GDI -> Faktor mehr als 10x.
GDI / GDI+ ist für mich persönlich aus der Historie gewachsen mich mit 2D + AutoIt zu beschäftigen. OpenGL / D2D sind sehr wohl die besser Wahl und ich werde auch mich mehr damit beschäftigen, da man viel schneller die Dinge darstellen kann.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 06.10.2016, 15:35 Titel: |
|
|
Ich hab Grad gesehen das ich vergessen habe den Link zu Stormys Seite einzutragen. Die OpenGL Initialisierung in der SUB InitOpenGL stammt im großen und ganzen nämlich von da.  |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 06.10.2016, 15:42 Titel: |
|
|
Nach kurzer Zeit bleibt die Animation stehen! Ist das auch bei euch so?
Getestet auch Win10 x64.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 06.10.2016, 20:36 Titel: |
|
|
Liegt an
| Code: | | Static i As Single= 0 |
Sollte | Code: | | Static i As Double = 0 |
sein.
Danke an Make-Grafik für das Bug Fixing.
Scheint, dass die Bits für i ausgehen.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Elor
Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz
|
| Verfasst am: 07.10.2016, 09:49 Titel: |
|
|
| UEZ hat Folgendes geschrieben: | | Nach kurzer Zeit bleibt die Animation stehen! Ist das auch bei euch so? |
Ja, ist bei mir auch so (Windows 10(32)/Linux(64)).
Edit:
Ob DOUBLE eine gute Lösung ist? Wenn SINGLE anscheinend nicht überläuft sondern hängen bleibt, was passiert dann mit DOUBLE?
Man könnte auch eine zweite Variable einbauen, z.B. so
| Code: |
Static j As Single= 0
|
und dann hinter
das ein bauen.
| Code: |
If(i = j) Then i= 0
j= i
|
Das aber nur weil alle anderen Variablen ebenfalls SINGLE Typen sind.
Edit2:
Diese Zeile kann man übrigens auch weg lassen.
| Code: |
Dim As ULong iBGR1 = (255 - (iRecDepth + 10) * 10) Shl 8 + (iRecDepth * 20) Shl 0 'r=0
|
|
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 147
Wohnort: Opel Stadt
|
| Verfasst am: 08.10.2016, 13:22 Titel: |
|
|
Das hier läuft:
| Code: |
'Ported to FreeBasic by UEZ build 2016-10-08
'OpenGL version by Elor
#lang "FB"
#include "fbgfx.bi"
#include "GL/gl.bi"
#Include "string.bi"
Declare Sub InitOpenGL(ByVal W As Integer, ByVal H As Integer)
Declare Sub PythagorasTreeRec(iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double
Dim As String sTitle = "OpenGL Animated Pythagoras Tree v2.5 , FPS: "
Dim As ULong iFPS = 0
Dim Shared As ULong iRec = 0, iRectangles = 0
Dim As Double fTime, fTimer
Dim As UShort iW = 1200, iH = 700, iWhL = iW \ 2 - 60, iWhR = iW \ 2 + 60
Dim As UByte iRecDepth = 16
InitOpenGL(iW, iH)
fTimer= Timer()
Do
glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
PythagorasTreeRec(iWhL, iH, iWhR, iH, iRecDepth)
Flip()
glFlush()
If (Timer - fTimer > 0.99) Then
WindowTitle(sTitle & iFPS & " ___ #Recursion calls / s: " & Format(iRec, "###,") & " ___ #Rectangles: " & Format(iRectangles, "###,"))
iFPS = 0
iRec = 0
fTimer = Timer
Else
iFPS += 1
EndIf
iRectangles = 0
Sleep(10)
Loop Until InKey = Chr(27)
Sub InitOpenGL(ByVal W As Integer, ByVal H As Integer)
ScreenRes(W, H, 32,, FB.GFX_OPENGL)' Or FB.GFX_NO_SWITCH)
glMatrixMode(GL_PROJECTION)
glLoadIdentity()
glEnable(GL_LINE_SMOOTH)
glEnable(GL_POLYGON_SMOOTH)
glEnable(GL_BLEND)
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
glViewport(0, 0, W, H)
glOrtho(0, W, H, 0, -128, 128)
glMatrixMode(GL_MODELVIEW)
glEnable(GL_CULL_FACE)
glCullFace(GL_BACK)
glLoadIdentity()
glClearColor(&h60 / &hFF, &h60 / &hFF, &h60 / &hFF, 1.00) 'rgba
glDepthFunc(GL_LESS)
glEnable(GL_DEPTH_TEST)
End Sub
Sub PythagorasTreeRec(iX1 As Single, iY1 As Single, iX2 As Single, iY2 As Single, iRecDepth As UByte)
Static iSpeed As Double = -&hFFFF
Dim As UInteger iC1 =(iRecDepth * 17), iC2 =(iRecDepth + 2) * 8
iC1 = IIf(iC1 > &hFF, &hFF, iC1)
iC2 = IIf(iC2 > &hFF, &hFF, iC2)
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 + iSpeed) / 400) / 1.5)
Dim As Single iY5 = iY4 -(dx + dy) /(2.25 + _Sin6th((iX5 + iY4 - iSpeed) / 500))
iSpeed += 0.0001
glBegin(GL_POLYGON)
glColor3ub(iC2, (255 - iC1), 0)
glVertex2f(iX1, iY1)
glVertex2f(iX2, iY2)
glVertex2f(iX3, iY3)
glVertex2f(iX4, iY4)
glVertex2f(iX1, iY1)
glEnd()
iRectangles += 1
iRec += 1
If (iRecDepth > 0) Then
PythagorasTreeRec(iX5, iY5, iX3, iY3, iRecDepth - 1)
PythagorasTreeRec(iX4, iY4, iX5, iY5, iRecDepth - 1)
End If
End Sub
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
|
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
