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, 5, 6
 
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
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1228
Wohnort: Ruhrpott

BeitragVerfasst am: 21.12.2020, 18:20    Titel: Antworten mit Zitat

Tolles Programm, ganz großes Kino! Daumen rauf! Daumen rauf! Daumen rauf!

Trotzdem zwei Verbesserungsvorschläge:

1) GFX_ALWAYS_ON_TOP solltest du entfernen. Ein Fenster, das sich so penetrant in den Vordergrund drängt, ist doch ziemlich störend.

2) Eine Lautstärkeregelung wäre nett.

Und eine Frage:

Lassen sich auch andere Musikformate abspielen (.wav oder .mp3)?

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



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

BeitragVerfasst am: 21.12.2020, 19:18    Titel: Antworten mit Zitat

grindstone hat Folgendes geschrieben:
Tolles Programm, ganz großes Kino! Daumen rauf! Daumen rauf! Daumen rauf!

Trotzdem zwei Verbesserungsvorschläge:

1) GFX_ALWAYS_ON_TOP solltest du entfernen. Ein Fenster, das sich so penetrant in den Vordergrund drängt, ist doch ziemlich störend.

2) Eine Lautstärkeregelung wäre nett.

Und eine Frage:

Lassen sich auch andere Musikformate abspielen (.wav oder .mp3)?

Gruß
grindstone


Viele Dank für dein Feedback.

Zu 1) GFX_ALWAYS_ON_TOP habe ich mir angewöhnt, weil, je nach x64 Compiler, nach dem Starten das Fenster in den Hintergrund verschoben und ich immer wieder in den Vordergrund holen muss. Das nervt, ist jetzt aber deaktiviert.

Zu 2) ist jetzt eingebaut. Die Lauststärke habe ich auf 33% gestellt.

Mit FMOD kannst du .MOD, .S3M, .XM, .IT, .MID, .WAV, .MP2, .MP3, .OGG oder .RAW Dateien abspielen. Ich habe die FMOD Hilfe Datei mit ins Zip Archiv gepackt.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
nemored



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

BeitragVerfasst am: 21.12.2020, 19:40    Titel: Antworten mit Zitat

Ich würde auch den Wert von PI einmal als Konstante speichern statt an mehreren Stellen des Programms.
Das Programm gefällt mir - zeigt mal wieder, wie man mit wenigen Zeilen einiges auf die Beine stellen kann. lächeln
_________________
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: 130
Wohnort: Opel Stadt

BeitragVerfasst am: 21.12.2020, 19:57    Titel: Antworten mit Zitat

nemored hat Folgendes geschrieben:
Ich würde auch den Wert von PI einmal als Konstante speichern statt an mehreren Stellen des Programms.
Das Programm gefällt mir - zeigt mal wieder, wie man mit wenigen Zeilen einiges auf die Beine stellen kann. lächeln


Freut mich, dass es dir gefällt. happy

Ich denke, du meinst die trigonometrischen Funktionen, wo der PI Wert direkt als Zahl eingetragen ist und nicht als Konstanze, die in Zeile 62 definiert ist. Copy / Paste Resultat.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
nemored



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

BeitragVerfasst am: 21.12.2020, 20:34    Titel: Antworten mit Zitat

Genau die meine ich - Zeile 92, 93 usw. Dass PI ja auch als Konstante vorkommt, ist mir gar nicht aufgefallen. grinsen
_________________
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
volta



Anmeldungsdatum: 04.05.2005
Beiträge: 1875
Wohnort: D59192

BeitragVerfasst am: 22.12.2020, 12:50    Titel: Antworten mit Zitat

Hi,
ob als Konstante oder als Zahl, in älteren FB-Versionen setzte der Compiler
immer nur einmal einen Zeiger auf den Wert im Datenbereich. Vermutlich
auch noch in den neueren Versionen.
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
nemored



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

BeitragVerfasst am: 22.12.2020, 16:51    Titel: Antworten mit Zitat

Mir geht es da mehr um die Gefahr eines Tippfehlers. Speicher- und geschwindigkeitstechnisch ist es sicher egal. Wenn der Wert da natürlich wegen C&P steht, ist das Tippfehler-Argument natürlich auch hinfällig. happy
_________________
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: 130
Wohnort: Opel Stadt

BeitragVerfasst am: 20.01.2021, 18:55    Titel: Ray Tracer Antworten mit Zitat

Ich war mal so frei und habe den coolen JavaScript Code von hier "pure js ray tracer" nach FB portiert.

Hier das Resultat:
Code:

'Ported from https://js1k.com/2017-magic/demo/2648 by Igor Sbitnev To FB by UEZ build 2021-01-19

#Include "crt/math.bi"
#Include "fbgfx.bi"
Using FB
Randomize

Type Vector3D
   As Single x, y, z
End Type

Type tSpheresData
   As Vector3D position, color
   As Single radius
End Type

Type tIntersect
   As Integer intersection
   As Vector3D rayEnd, lightDirection, normal, sphereColor
End Type

Function Vector(x As Single, y As Single, z As Single) As Vector3D
   Return Type(x, y, z)
End Function

Const INTERSECTION_NONE = 0, INTERSECTION_SPHERE = 1, INTERSECTION_FLOOR = 2
Dim Shared As Vector3D CENTER_TILE_COLOR, OTHERS_TILE_COLOR, COLOR_SKY, COLOR_LIGHT_SOURCE, COLOR_STARS
CENTER_TILE_COLOR    = Vector(8, 0, 8)
OTHERS_TILE_COLOR    = Vector(8, 5, 8)
COLOR_SKY            = Vector(5, 6, 8)
COLOR_LIGHT_SOURCE    = Vector(8, 8, 8)
COLOR_STARS       = Vector(8, 8, 8)

Dim Shared As tSpheresData spheresData(5)
spheresData(0).position   = Vector(10, 2, 2)
spheresData(0).color    = Vector(4, 0, 4)
spheresData(0).radius    = 1.5
spheresData(1).position = Vector(-3, 0, 2)
spheresData(1).color    = Vector(8, 5, 7)
spheresData(1).radius    = 1.5
spheresData(2).position = Vector(3, 0, 2)
spheresData(2).color    = Vector(0, 0, 4)
spheresData(2).radius    = 1.5
spheresData(3).position = Vector(1.5, 0, 4.5)
spheresData(3).color    = Vector(8, 8, 6)
spheresData(3).radius    = 1.5
spheresData(4).position = Vector(-1, 10, 4)
spheresData(4).color    = Vector(0, 4, 4)
spheresData(4).radius    = 4.0
spheresData(5).position = Vector(0, 0, 7)
spheresData(5).color    = Vector(8, 5, 4)
spheresData(5).radius    = 1.5

Function Sum(first As Vector3D, second As Vector3D) As Vector3D
   Return Type(first.x + second.x, first.y + second.y, first.z + second.z)
End Function

Function Scale(v As Vector3D, factor As Single) As Vector3D
   Return Type(v.x * factor, v.y * factor, v.z * factor)
End Function

Function dotProduct(first As Vector3D, second As Vector3D) As Single
   Return first.x * second.x + first.y * second.y + first.z * second.z
End Function

Function crossProduct(first As Vector3D, second As Vector3D) As Vector3D
   Return Type(first.y * second.z - first.z * second.y, first.z * second.x - first.x * second.z, first.x * second.y - first.y * second.x)
End Function

Function normalize(v As Vector3D) As Vector3D
   Return scale(v, 1 / Sqr(dotProduct(v, v)))
End Function

Function subtract(first As Vector3D, second As Vector3D) As Vector3D
   Return sum(first, scale(second, -1))
End Function

Function trace(rayStart As Vector3D, rayDirection As Vector3D) As tIntersect
   Dim As Vector3D rayEnd, lightDirection, normal, sphereColor, distanceToSphereCenter, lightPosition = Vector(Rnd() * 27, -81 + Rnd() * 27, 81)
   Dim As Integer i, intersection = INTERSECTION_NONE
   Dim As Single distanceToFloor = -rayStart.z / rayDirection.z, a = 1, b, c, d, distanceToSphere
   Dim As Ulongint distanceToNearestSphere = -1
   If distanceToFloor > 0 And rayStart.z > 0 Then
      intersection = INTERSECTION_FLOOR
      rayEnd = sum(rayStart, scale(rayDirection, distanceToFloor))
      lightDirection = normalize(subtract(lightPosition, rayEnd))
      normal = Vector(0, 0, 1)
   End If
   For i = 0 To Ubound(spheresData)
      distanceToSphereCenter = subtract(rayStart, spheresData(i).position)
      'a = 1 'dotProduct(rayDirection, rayDirection)
      b = 2 * dotProduct(rayDirection, distanceToSphereCenter)
      c = dotProduct(distanceToSphereCenter, distanceToSphereCenter) - spheresData(i).radius * spheresData(i).radius
      d = b * b - 4 * a * c
      distanceToSphere = (-b - Sqr(d)) / 2 * a
      If (distanceToSphere < distanceToNearestSphere) And (distanceToSphere > 0) Then
         distanceToNearestSphere = distanceToSphere
         intersection = INTERSECTION_SPHERE
         sphereColor = spheresData(i).color
         rayEnd = sum(rayStart, scale(rayDirection, distanceToSphere))
         lightDirection = normalize(subtract(lightPosition, rayEnd))
         normal = normalize(subtract(rayEnd, spheresData(i).position))
      End If
   Next
   Return Type(intersection, rayEnd, lightDirection, normal, sphereColor)
End Function

Function getFloorColor(x As Integer, y As Integer) As Vector3D
   If x + y <> 0 Then
      If fmod(x, 3) = 1 And fmod(y, 3) = 1 Then Return CENTER_TILE_COLOR
      Return getFloorColor((x \ 3), (y \ 3))
   End If
   Return OTHERS_TILE_COLOR
End Function

Function sample(rayStart As Vector3D, rayDirection As Vector3D, renderStars As Boolean = False) As Vector3D
   Dim As tIntersect ti = trace(rayStart, rayDirection)
   Dim As Vector3D reflectionRayDirection, color_, diffuse, specular, reflection, floorColor, uVector, vVector, randomizedDirection
   Select Case ti.intersection
      Case INTERSECTION_NONE
         Return Iif(renderStars And Rnd() > 0.9, COLOR_STARS, scale(COLOR_SKY, Pow(1 - rayDirection.z, 4)))
      Case INTERSECTION_SPHERE
         diffuse = scale(ti.sphereColor, 0.7 * dotProduct(ti.normal, ti.lightDirection))
         specular = scale(COLOR_LIGHT_SOURCE, Pow(dotProduct(ti.normal, normalize(subtract(ti.lightDirection, rayDirection))), 64))
         reflectionRayDirection = sum(rayDirection, scale(ti.normal, -2 * dotProduct(ti.normal, rayDirection)))
         reflection = scale(sample(ti.rayEnd, reflectionRayDirection), 0.4)
         color_ = sum(diffuse, sum(specular, reflection))
      Case INTERSECTION_FLOOR
         reflectionRayDirection = sum(rayDirection, scale(ti.normal, -2 * dotProduct(ti.normal, rayDirection)))
         floorColor = getFloorColor(CInt(fmod((ti.rayEnd.x + 81) * 27, 81)), CInt(fmod((ti.rayEnd.y + 81) * 27, 81)))
         uVector = crossProduct(rayDirection, reflectionRayDirection)
         vVector = crossProduct(uVector, reflectionRayDirection)
         randomizedDirection = sum(reflectionRayDirection, sum(scale(uVector, (Rnd() - 0.5) / 3), scale(vVector, (Rnd() - 0.5) / 3)))
         color_ = sum(floorColor, sample(ti.rayEnd, randomizedDirection))
         color_ = scale(color_, 0.5)
   End Select
   Dim As Integer isShadowed = trace(ti.rayEnd, ti.lightDirection).intersection
   Return scale(color_, Iif(isShadowed, 0.5, 1))
End Function

Randomize
Dim Shared As Integer iW, iW2, iH, iH2, i, j, pixel = 0, CANVAS_WIDTH, CANVAS_HEIGHT
iW = 512 : iH = 512
CANVAS_WIDTH = iW : CANVAS_HEIGHT = iH

#Define PutPixel(_x, _y, colour)   *Cptr(Ulong Ptr, pScrn + (_y) * pitch + (_x) Shl 2) = (colour)
#Define GetPixel(_x, _y)           *Cptr(Ulong Ptr, pScrn + (_y) * pitch + (_x) Shl 2)

Dim Shared As Any Ptr pScrn
Dim Shared As Integer pitch

#Define Min(a, b)   (Iif(a < b, a, b))
#Define Max(a, b)   (Iif(a > b, a, b))
#Define Map(Val, source_start, source_stop, dest_start, dest_stop)   ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)

Screenres iW, iH, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
Screenset 1, 0

pScrn = Screenptr()
Screeninfo ,,,, pitch

Const RAYS_PER_PIXEL = 32, DISTANCE_TO_VIEWPORT = 10, VIEWPORT_WIDTH = 12, VIEWPORT_HEIGHT = 12, ALPHA_CHANNEL_COLOR = 255
Dim As Vector3D UP_DIRECTION = Vector(0, 0, 1), camera = Vector(-7, -10, 8), target = Vector(0, 0, 4), normalToViewport = normalize(subtract(camera, target)), _
      uVector = normalize(crossProduct(UP_DIRECTION, normalToViewport)), vVector = crossProduct(uVector, normalToViewport), viewportCenter = sum(camera, scale(normalToViewport, -DISTANCE_TO_VIEWPORT)), _
      leftDown = sum(viewportCenter, sum(scale(uVector, -VIEWPORT_WIDTH / 2), scale(vVector, -VIEWPORT_HEIGHT / 2))), colorSum, rayStart, viewportPixel, direction, color_
Dim As Ulong line_ = 0, b = 0

Dim As Double t = Timer
Do
   If line_ < iH Then
      For i = iW - 1 To 0 Step -1
         colorSum = Vector(0, 0, 0)
         For j = 0 To RAYS_PER_PIXEL - 1
            rayStart = sum(camera, sum(scale(uVector, (Rnd() - 0.5) / 3), scale(vVector, (Rnd() - 0.5) / 3)))
            viewportPixel = sum(leftDown, sum(scale(uVector, i * VIEWPORT_WIDTH / CANVAS_WIDTH), scale(vVector, line_ * VIEWPORT_HEIGHT / CANVAS_HEIGHT)))
            direction = normalize(subtract(viewportPixel, rayStart))
            color_ = sample(rayStart, direction, True)
            colorSum = sum(colorSum, color_)
         Next     
         PutPixel(i, line_, Rgba(Max(0, Min(255, colorSum.x)), Max(0, Min(255, colorSum.y)), Max(0, Min(255, colorSum.z)), ALPHA_CHANNEL_COLOR))
      Next
      line_ += 1
   Else
      If b = 0 Then Windowtitle("Ray Tracer / Rendered in " & Timer - t & " seconds") : b = 1
   Endif
   Flip
   Sleep(1)
Loop Until Len(Inkey())


So sollte es aussehen:


Mehr Details zum Code kann hier eingesehen werden: https://js1k.com/2017-magic/details/2648

Viel Spaß. happy
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland

BeitragVerfasst am: 21.01.2021, 00:13    Titel: Antworten mit Zitat

Wow! durchgeknallt

Ich habe erfolglos den Aufruf einer magischen externen 3D-Bibliothek gesucht, der das mit dem bisschen Code möglich macht... lachen
_________________

Die gefährlichsten Familienclans | Opas Leistung muss sich wieder lohnen - für 6 bis 10 Generationen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1228
Wohnort: Ruhrpott

BeitragVerfasst am: 21.01.2021, 16:14    Titel: Antworten mit Zitat

Spitze! Daumen rauf!

Mein betagter Rechenknecht (Core 2 Quad 2,4GHz / WinXP 32) hat dafür zwar knapp 128 Sekunden gebraucht, aber das Ergebnis ist absolut überzeugend. Und das alles mit FB - Bordmitteln. Echt beeindruckend!

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
volta



Anmeldungsdatum: 04.05.2005
Beiträge: 1875
Wohnort: D59192

BeitragVerfasst am: 23.01.2021, 12:07    Titel: Antworten mit Zitat

Klasse vor Freude klatschen

der Quellcode ist mir zwar en Rätsel aber tolles Program.
46 Sec. auf Celeron 2,16, Win10-64

Bleibt gesund!
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
UEZ



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

BeitragVerfasst am: 23.01.2021, 16:07    Titel: Antworten mit Zitat

Danke für euer Feedback.

Den JavaScript Code zu verstehen und zu übersetzen ist das eine. Das andere ist der Code selbst, also wie Ray Tracing funktioniert. happy
Ganz offen und ehrlich, ist Ray Tracing mir auch ein Rätsel...

Aber der Code lässt sich als Benchmark gut verwenden.
Hier die Resulate mit verschiedenen Compile Parametern auf meinem Notebook (AMD Ryzen 5 PRO Mobile 3500U):

FreeBASIC Compiler - Version 1.07.2 (2020-12-25)
-s gui:
32-bit: 25,21 Sekunden
64-bit: 29,72 Sekunden

-s gui -gen gcc -Wc -O3:
32-bit: 16,36 Sekunden
64-bit: 14,49 Sekunden

gen gcc -Wc -Ofast -s gui
32-bit: 14,42 Sekunden
64-bit: 13,79 Sekunden

-gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse -s gui
32-bit: 12,52 Sekunden
64-bit: 13,98 Sekunden

FreeBASIC Compiler - Version 1.08.0 (2020-05-19), built for win64 (64bit)
-gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse -s gui
32-bit: 11,29 Sekunden
64-bit: 8,51 Sekunden

Zwischen der langsamsten und schnellsten Version (x64) liegt ein Faktor von 3,5!
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 02.03.2021, 21:45    Titel: Dwitter.net Portierungen Antworten mit Zitat

Ich war so frei und habe einige Beispiele von Dwitter.net nach FreeBasic portiert.

Zu vermerken wäre, dass der JS Code auf 140 Bytes limitiert ist. Die JS Grafik Befehle sind um einiges umfangreicher als in FB, somit lassen sich leider manche Beispiele nicht direkt übersetzen. traurig

Download der ca. 802 Beispiele (Source Code + Windows kompilierte Dateien): The beauty - magic of math Vol. 1 - 19 build 2023-05-01.7z (2.78 MiB)

Zum Entpacken wird 7-Zip benötigt oder ein anderer Entpacker, welcher das 7-Zip Archiv unterstützt.

Viel Spaß beim Anschauen.
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 01.05.2023, 20:16, insgesamt 9-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eukalyptus



Anmeldungsdatum: 17.05.2013
Beiträge: 11

BeitragVerfasst am: 14.08.2021, 16:10    Titel: Re: Dwitter.net Portierungen Antworten mit Zitat

UEZ hat Folgendes geschrieben:
Ich war so frei und habe einige Beispiele von Dwitter.net nach FreeBasic portiert.

Zu vermerken wäre, dass der JS Code auf 140 Bytes limitiert ist. Die JS Grafik Befehle sind um einiges umfangreicher als in FB, somit lassen sich leider manche Beispiele nicht direkt übersetzen. traurig

Download der Beispiele (Source Code + Windows kompilierte Dateien): The beauty - magic of math Vol. I - V.7z (858 kB)

Zum Entpacken wird 7-Zip benötigt oder ein anderer Entpacker, welcher das 7-Zip Archiv unterstützt.

Viel Spaß beim Anschauen.


Wie geil ist das denn!!!
Also das hat definitiv viel mehr Aufmerksamkeit verdient!

lgE
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
ALWIM



Anmeldungsdatum: 08.08.2006
Beiträge: 1042
Wohnort: Niederbayern

BeitragVerfasst am: 18.08.2021, 21:48    Titel: Antworten mit Zitat

Ich habe mir das Beispiel mal angesehen und kompiliert. Sieht klasse aus!

Mein Rechner hat 26.471 Sekunden gebraucht.
_________________
SHELL SHUTDOWN -s -t 05
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 19.08.2021, 14:29    Titel: Antworten mit Zitat

Eukalyptus hat Folgendes geschrieben:
Wie geil ist das denn!!!
Also das hat definitiv viel mehr Aufmerksamkeit verdient!

happy
Lange nichts mehr von dir "gehört".

ALWIM hat Folgendes geschrieben:
Ich habe mir das Beispiel mal angesehen und kompiliert. Sieht klasse aus!

Mein Rechner hat 26.471 Sekunden gebraucht.

Ich vermute, dass du den Ray-Tracer meinst.

Du kannst mal probieren, ob du durch Aufruf dieser zusätzlichen Parameter einen Performance Schub bekommst: -gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse, wie 4 Posts weiter oben beschrieben.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 10.07.2024, 10:23    Titel: Lunar Phase Antworten mit Zitat

Nach langer Zeit mal wieder ein Beitrag:)
Code:

'Coded by UEZ build 2024-07-10 beta
'#cmdline "-s gui -gen gcc -Wc -Ofast
#include "fbgfx.bi"

Using FB

#define _pi     3.1415926535897932384626433832795
#define _2pi    6.283185307179586476925286766559
#define _pi2    1.5707963267948966192313216916398
#define _rad    0.01745329251994329576923690768489
#define Map(Val, source_start, source_stop, dest_start, dest_stop)   ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)
#define Min(a, b)                  (IIf(a < b, a, b))
#define Max(a, b)                  (IIf(a > b, a, b))
#define Col(c)                     Max(0, Min(&hFF, c))

Dim Shared As Long pitchS, bppS
Dim Shared As Any Ptr pixelS

Function MapCoordinate(i1 As Double, i2 As Double, w1 As Double, w2 As Double, p As Double) As Double '...'
   Return ((p - i1) / (i2 - i1)) * (w2 - w1) + w1
End Function

Function _ASM_Cos6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
   'By Eukalyptus - modified by srvaldez
   Asm
   ' if FB-32-bit, then load fx from stack, else it's already in xmm0
   ' ebx/rbx needs to be preserved, not sure about ecx/rcx
      #ifndef __FB_64BIT__
         lea eax, [esp+4]
         push ebx
         push ecx
         movq xmm0, [eax]
      #else
         push rbx
         push rcx
      #endif
         mulsd xmm0, [1f]
         addsd xmm0, [3f]
         movd ebx, xmm0

         add ebx, 0x40000000 'SinToCos

         lea  eax, [ebx * 2 + &h80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx * 2 - &h70000000]
         lea  ecx, [edx * 8 + edx - &h24000000]
         imul edx
         xor  ecx, ebx
         lea  eax, [edx * 8 + edx + &h44A00000]
         imul ecx

         cvtsi2sd xmm0, edx
         mulsd xmm0, [2f]
      ' if FB-32-bit, then transfer xmm0 into fpu, else we are done
      ' restore saved registers
      #ifndef __FB_64BIT__
         pop ecx
         pop ebx
         movq [esp - 12], xmm0
         fld qword ptr [esp - 12]
      #else
         pop rcx
         pop rbx
      #endif
         ret
      1: .Double 683565275.57643158
      2: .Double -0.0000000061763971109087229
      3: .Double 6755399441055744.0
   End Asm
End Function

Function _ASM_Sin6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
   'By Eukalyptus - modified by srvaldez
   Asm
   ' if FB-32-bit, then load fx from stack, else it's already in xmm0
   ' ebx/rbx needs to be preserved, not sure about ecx/rcx
      #ifndef __FB_64BIT__
         lea eax, [esp + 4]
         push ebx
         push ecx
         movq xmm0, [eax]
      #else
         push rbx
         push rcx
      #endif
         mulsd xmm0, [1f]
         addsd xmm0, [3f]
         movd ebx, xmm0

         lea  eax, [ebx * 2 + &h80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx * 2 - &h70000000]
         lea  ecx, [edx * 8 + edx - &h24000000]
         imul edx
         xor  ecx, ebx
         lea  eax, [edx * 8 + edx + &h44A00000]
         imul ecx

         cvtsi2sd xmm0, edx
         mulsd xmm0, [2f]
      ' if FB-32-bit, then transfer xmm0 into fpu, else we are done
      ' restore saved registers
      #ifndef __FB_64BIT__
         pop ecx
         pop ebx
         movq [esp-12], xmm0
         fld qword ptr [esp-12]
      #else
         pop rcx
         pop rbx
      #endif
         ret
      1: .Double 683565275.57643158
      2: .Double -0.0000000061763971109087229
      3: .Double 6755399441055744.0
   End Asm
End Function

Sub RotX(angle As Double, ByRef y As Double, ByRef z As Double) '...'
   Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), y1 = y * ca - z * sa, z1 = y * sa + z * ca
   y = y1
   z = z1
End Sub

Sub RotY(angle As Double, ByRef x As Double, ByRef z As Double) '...'
   Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), x1 = x * ca - z * sa, z1 = x * sa + z * ca
   x = x1
   z = z1
End Sub

Sub RotZ(angle As Double, ByRef x As Double, ByRef y As Double) '...'
   Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), x1 = x * ca - y * sa, y1 = x * sa + y * ca
   x = x1
   y = y1
End Sub

Sub MapImage2Sphere(px As Short, py As Short, w As UShort, h As UShort, radius As Double, pSourceImage As Any Ptr, xa As Double = 0, ya As Double = 0, za As Double = 0, ByRef pImageDst As Any Ptr = 0, theta0 As Double = 0, theta1 As Double = _2pi, phi0 As Double = 0, phi1 As Double = _pi) '...'
   Dim As UShort i, j
   Dim As ULong c, ibppS
   Dim As Double theta, phi, x, y, z, sp, rsp
   Dim As ULong Ptr pCol
   ImageInfo(pSourceImage, , , bppS, pitchS, pixelS)
   Dim As Any Ptr pPos   
   For i = 0 To w - 1
      theta = MapCoordinate(0, w - 1, theta1, theta0, i)
      ibppS = i * bppS
      pPos = pixelS + ibppS
      For j = 0 To h - 1
         phi = MapCoordinate(0, h - 1, phi0, phi1, j)
         sp = _ASM_Sin6th2(phi)
         rsp = radius * sp
         x = rsp * _ASM_Cos6th2(theta)
         y = rsp * _ASM_Sin6th2(theta)
         z = radius * _ASM_Cos6th2(phi)
         If xa Then RotX(xa, y, z)
         If ya Then RotY(ya, x, z)
         If za Then RotZ(za, x, y)
         If z > 0 Then
            pCol = pPos + j * pitchS
            PSet pImageDst, (px + x, py + y), pCol[0]
         End If
      Next
   Next
End Sub

Function ImageScale(s As IMAGE Ptr, w As Integer, h As Integer) As IMAGE Ptr 'by D.J. Peters aka Joshy (https://www.freebasic.net/forum/viewtopic.php?t=10533#p91780) '...'
   If s         = 0 Then Return 0
   If s->width  < 1 Then Return 0
   If s->height < 1 Then Return 0
   If w < 4 Then w = 4
   If h < 4 Then h = 4
   Dim As IMAGE Ptr t = ImageCreate(w, h)
   Dim As Long xs = (s->width  / t->width ) * &h10000 '(1024*64)
   Dim As Long ys = (s->height / t->height) * &h10000 '(1024*64)
   Dim As Long x, y, sy
   Dim As ULong Ptr ps= CPtr(ULong Ptr,s) + 8
   Dim As ULong     sp= (s->pitch Shr 2)
   Dim As ULong Ptr pt= CPtr(ULong Ptr,t) + 8
   Dim As ULong     tp= (t->pitch Shr 2) - t->width
   For ty As Long = 0 To t->height - 1
      Dim As ULong Ptr src = ps + (sy Shr 16) * sp
      For tx As Long = 0 To t->width - 1
         *pt = src[x Shr 16] : pt += 1 : x += xs
      Next
      pt += tp : sy += ys : x = 0
   Next
   Return t
End Function

'https://gist.github.com/mattdesl/4383372
'Copyright (c) 2007, Romain Guy All rights reserved.
Type tImage '...'
    As Long width, height, pitch
    As Long Ptr pixels
End Type

Function BlurPass(img As tImage, iRadius As UByte, iW As ULong, iH As ULong) As Any Ptr '...'
    Dim As ULong iW1 = iW - 1, iH1 = iH - 1
   
   Dim pImage_blurred As Any Ptr = ImageCreate(img.height, img.width, 0, 32)

   Dim As tImage img_b
   If img_b.width = 0 Then ImageInfo(pImage_blurred, img_b.width, img_b.height, , img_b.pitch, img_b.pixels)
   
   Dim As Long previousPixelIndex, sumAlpha, sumRed, sumGreen, sumBlue, i
   
   Dim As ULong windowSize = iRadius * 2 + 1, radiusPlusOne = iRadius + 1, _
                 srcIndex = 0, sumLookupTable(256 * windowSize), indexLookupTable(radiusPlusOne), dstIndex, x, y, nextPixelIndex
               
   Union _Color '...'
      As Ulong argb
      Type '...'
         As Ubyte b, g, r, a
      End Type
   End Union
   Dim As _Color pixel, nextPixel, previousPixel
   
   Dim As Integer pitch_img = img.pitch Shr 2, pitch_b = img_b.pitch Shr 2

   For i = 0 To UBound(sumLookupTable) - 1
      sumLookupTable(i) = i \ windowSize
   Next
   
   If iRadius < iW Then
      For i = 0 To UBound(indexLookupTable) - 1
         indexLookupTable(i) = i
      Next
   Else
      For i = 0 To iW - 1
         indexLookupTable(i) = i
      Next
      For i = iW To UBound(indexLookupTable) - 1
         indexLookupTable(i) = iW1
      Next
   EndIf
   
   For y = 0 To iH1
      sumAlpha = 0: sumRed = 0: sumGreen = 0: sumBlue = 0
      dstIndex = y
      
      pixel.argb = img.pixels[srcIndex]
      sumAlpha += radiusPlusOne * pixel.a
      sumRed   += radiusPlusOne * pixel.r
      sumGreen += radiusPlusOne * pixel.g
      sumBlue  += radiusPlusOne * pixel.b
      
      For i = 1 To iRadius
         pixel.argb = img.pixels[srcIndex + indexLookupTable(i)]
         sumAlpha += pixel.a         
         sumRed   += pixel.r
         sumGreen += pixel.g
         sumBlue  += pixel.b
      Next
      
      For x = 0 To iW1
         img_b.pixels[dstIndex] = sumLookupTable(sumAlpha) Shl 24 Or _
                            sumLookupTable(sumRed)   Shl 16 Or _
                            sumLookupTable(sumGreen) Shl  8 Or _
                            sumLookupTable(sumBlue)
         
         'img_b.pixels[dstIndex] = Rgba(sumLookupTable(sumRed), sumLookupTable(sumGreen), sumLookupTable(sumBlue), sumLookupTable(sumAlpha))
         
         dstIndex += pitch_b
         
         nextPixelIndex = x + radiusPlusOne
         If nextPixelIndex >= iW Then nextPixelIndex = iW1
         
         previousPixelIndex = x - iRadius
         If previousPixelIndex < 0 Then previousPixelIndex = 0
         
         nextPixel.argb =    img.pixels[srcIndex + nextPixelIndex]
         previousPixel.argb = img.pixels[srcIndex + previousPixelIndex]
         
         sumAlpha += nextPixel.a
         sumAlpha -= previousPixel.a
         
         sumRed += nextPixel.r
         sumRed -= previousPixel.r
         
         sumGreen += nextPixel.g
         sumGreen -= previousPixel.g
         
         sumBlue += nextPixel.b
         sumBlue -= previousPixel.b
      Next
   
      srcIndex += pitch_img
   Next
   
   Return pImage_Blurred
End Function

Function FastBlur(img As tImage, iRadius As UByte) As Any Ptr '...'
   'iRadius = Iif(iRadius < 0, 0, iRadius)

   Dim pImgPassH As Any Ptr = BlurPass(img, iRadius, img.width, img.height) 'horizontal pass

   Dim As tImage img2
   If img2.Width = 0 Then Imageinfo(pImgPassH, img2.Width, img2.height, , img2.pitch, img2.pixels)

   Dim pImgPassW As Any Ptr = BlurPass(img2, iRadius, img.height, img.Width) 'vertical pass
   ImageDestroy(pImgPassH)

   Return pImgPassW
End Function

Const iW = 1350 \ 2, iH = 675 \ 2, w = 800, h = 600, cW = w \ 2, cH = h \ 2, iWs = iW * 2, iHs = iH * 2

ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFFFFFF, &hFF000000
Cls

Dim As UShort x, y, c, r = iH \ 5, r2 = r \ 2, rr = r * 2
Dim As ULong iFPS, cfps = 0
Dim As Double t, fTimer, tt, f, t1

Dim As Any Ptr pMoon = ImageCreate(iW, iH, 0, 32), pShadow = ImageCreate(iWs, iHs, 0, 32), pImageFinal = ImageCreate(rr, rr, 0, 32), pImage_scaled, pImage_blurred
BLoad("moon_texture.675x337.bmp", pMoon)
'BLoad("moon_texture.1350x675.bmp", pMoon)
ImageInfo(pMoon, , , bppS, pitchS, pixelS)

Dim As tImage img

For y = 0 To iHs - 1
   For x = Int(0.25 * iWs) To iWs \ 2
      c = Col(Map(x, Int(0.25 * iWs), Int(0.75 * iWs), 0, &h4B))
      PSet pShadow, (x, y), RGBA(0, 0, 0, c)
      PSet pShadow, (iWs - x, y), RGBA(0, 0, 0, c)
   Next
Next

Do
   Cls
   tt = t / 10
   Line pImageFinal, (0, 0) - (rr, rr), &hFF000000, BF
   t1 = _ASM_Cos6th2(tt) / 5
   MapImage2Sphere(r, r, iW, iH, r - 1, pMoon, 2.0943 + _ASM_Sin6th2(tt) / 5, -_pi2 + t1, 0.69813 + t1, pImageFinal)
   MapImage2Sphere(r, r, iWs, iHs, r, pShadow, _pi2, tt + _pi2, t1, pImageFinal)
   f = (4 + t1) * rr
   pImage_scaled = ImageScale(pImageFinal, f, f)
   ImageInfo(pImage_scaled, img.width, img.height, , img.pitch, img.pixels)
   pImage_blurred = FastBlur(img, 2)
   Put ((w - f) / 2, (h - f) / 2), pImage_blurred, PSet
   ImageDestroy(pImage_scaled)
   ImageDestroy(pImage_blurred)
   t += 0.25

   Draw String(4, 4), iFPS & " fps", &hFFFFFFFF
   
   Flip

   cfps += 1
   If Timer - fTimer > 0.99 Then
      iFPS = cfps
      cfps = 0
      fTimer = Timer
   End If
   Sleep(1)
Loop Until Len(Inkey())

ImageDestroy(pShadow)
ImageDestroy(pMoon)
ImageDestroy(pImageFinal)


Das Bild + Source Code + kompilierte Exe kann hier heruntergeladen werden: [url=https://1drv.ms/f/s!AiLeZOpaFqSayTFVXPC3ye7KKbbJ?e=qcXOJS]OneDrive[/url]
Die Animation ist an die Animation des nördlichen Himmels von hier https://en.wikipedia.org/wiki/Lunar_phase angelehnt.
_________________
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, 5, 6
Seite 6 von 6

 
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