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:

Gfx Spielereien
Gehe zu Seite Zurück  1, 2, 3, 4
 
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
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5900
Wohnort: Deutschland

BeitragVerfasst am: 04.03.2018, 19:25    Titel: Antworten mit Zitat

Cool! lächeln
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
nemored



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

BeitragVerfasst am: 04.03.2018, 21:34    Titel: Antworten mit Zitat

Dem kann ich mich nur anschießen. Sehr hübsch!
_________________
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
UEZ



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

BeitragVerfasst am: 27.04.2018, 13:53    Titel: Antworten mit Zitat

Rekursive Baum Generierung (prozedurale Grafik)



Code:

'coded by UEZ build 2018-04-27
'thanks to dodicat for the DrawThickLine function
'use 64-bit compilation for faster progress

#include "string.bi"
#include "fbgfx.bi"
#if __FB_LANG__ = "fb"
   Using FB '' Scan code constants are stored in the FB namespace in lang FB
#endif

#Define Min(a, b)   Iif(a < b, a, b)

Declare Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
Declare Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger)


Const As Ushort iW = 1200, iH = 800, iCenterX = iW \ 2, iCenterY = iH \ 2
Const As Single fD2R = Acos(-1) / 180, thresholdBloom = 0.03, treeSize = 0.275
Const As Ubyte maxLevel = 14, bloomLevel = Cubyte(maxLevel * 0.75), lineThickness = 10, maxBloomSize = 8
Const As Ulong bloomColor = &h910F66, colorTree = &h800

Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH
Color 0, &hA0A0A0
Cls

'======================= maybe needed later
Dim Shared As Integer w, h, depth, bpp, bpsl
ScreenInfo w, h, depth, bpp, bpsl
Dim Shared As Any Ptr pScreen
pScreen = Screenptr()
'=======================

Windowtitle("Simple Recursive Tree Generator v0.90 / " & Format((3^maxLevel) Shr 1, "#,##") & " function calls")
Randomize

Dim Shared As Ulong level
level = 0

DrawRecTree(iCenterX, iH, 90, -90, colorTree)
Draw String(10, 10), "Press space / lmb to regenerate tree", &hFFFFFF

Dim As Single fTimer
Dim As Integer x, y, buttons

Do   
   Getmouse(x, y, , buttons)
   If Multikey(SC_SPACE) Or buttons = 1 Then
      fTimer = Timer()
      Cls
      Screenlock
      DrawRecTree(iCenterX, iH, 90, -90, colorTree)
      Screenunlock
      Draw String(10, iH - 10), Format((Timer() - fTimer) * 1000, "0.0000") & " ms", &hFFFFFF
   End If
    Sleep 50, 1
Loop Until Multikey(SC_ESCAPE)


Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
   level += 1
   Dim As Single destX, destY, col2
   destX = x + length * Cos(angle * fD2R)
   destY = y + length * Sin(angle * fD2R)
   
   col += 256 * level

   If level > bloomLevel And Rnd() < thresholdBloom Then
      col = bloomColor 'this will overwrite the green color and will change the color of the branches, too.
      Circle (x, y), Min(maxBloomSize, (destX - x)), col, , , 1.25 + Rnd() / 4, F
   Else   
      DrawThickLine(x, y, destX, destY, 1 + lineThickness / level, col)
      'Line (x, y)-(destX, destY), col
   End If
   
   If level < maxLevel Then
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
   End If
   
   level -= 1
End Sub

Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger) 'by dodicat
   If x1 = x2 And y1 = y2 Then
      Circle (x1, y1), size, c, , , , f
   Elseif Abs(x2 - x1) >= Abs(y2 - y1) Then
      Dim K As Single = (y2 - y1) / (x2 - x1)
      For I As Integer = x1 To x2 Step Sgn(x2 - x1)
        Circle (I, K * (I - x1) + y1), size, c, , , , f
      Next I
   Else
      Dim L As Single = (x2 - x1) / (y2 - y1)
      For J As Integer = y1 To y2 Step Sgn(y2 - y1)
        Circle (L * (J - y1) + x1, J), size, c, , , , f
      Next J
   End If
End Sub

_________________
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
Gehe zu Seite Zurück  1, 2, 3, 4
Seite 4 von 4

 
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