Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Pythagoras-Baum (Cairo Beispiel)

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 183
Wohnort: Dakar, Senegal

BeitragVerfasst am: 18.09.2016, 09:35    Titel: Pythagoras-Baum (Cairo Beispiel) Antworten mit Zitat

Hallo!

Hier ist ein Pythagoras-Baum, mit Cairo gezeichnet.



Download Seite
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 02.10.2016, 00:17    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 02.10.2016, 11:46    Titel: Antworten mit Zitat

UEZ hat Folgendes geschrieben:
Läuft nur unter Windows.

Ich fühle mich ausgegrenzt. lächeln
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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 02.10.2016, 14:35    Titel: Antworten mit Zitat

cool

Ich muss mir bei Gelegenheit FB unter Linux installieren.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 02.10.2016, 19:51    Titel: Antworten mit Zitat

@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
Benutzer-Profile anzeigen Private Nachricht senden
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 183
Wohnort: Dakar, Senegal

BeitragVerfasst am: 05.10.2016, 14:12    Titel: Antworten mit Zitat

@UEZ, Elor

Hübsch! Daumen rauf!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 05.10.2016, 16:39    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4214
Wohnort: ~/

BeitragVerfasst am: 05.10.2016, 19:20    Titel: Antworten mit Zitat

Also irgendwie muss ich bei dem Programm an einen wütenden Riesen denken, der den Benutzer zu packen versucht. grinsen

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
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 06.10.2016, 11:42    Titel: Antworten mit Zitat

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 grinsen
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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 06.10.2016, 14:06    Titel: Antworten mit Zitat

Ist wirklich schneller als die Buffering Methode. Daumen rauf! , 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
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 06.10.2016, 15:36    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 06.10.2016, 15:57    Titel: Antworten mit Zitat

Also, OpenGL rennt ja im Vergleich zu GDI -> Faktor mehr als 10x. Daumen rauf!

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.

happy
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 06.10.2016, 16:35    Titel: Antworten mit Zitat

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. peinlich
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 06.10.2016, 16:42    Titel: Antworten mit Zitat

Nach kurzer Zeit bleibt die Animation stehen! Ist das auch bei euch so?

Getestet auch Win10 x64.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 06.10.2016, 21:36    Titel: Antworten mit Zitat

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. Daumen rauf!

Scheint, dass die Bits für i ausgehen.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 07.10.2016, 10:49    Titel: Antworten mit Zitat

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
Code:

  i += 0.005

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
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 76
Wohnort: Opel Stadt

BeitragVerfasst am: 08.10.2016, 14:22    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
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.

 Impressum :: Datenschutz