 |
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 |
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1237
Wohnort: Ruhrpott
|
 Verfasst am: 21.12.2020, 17:20 Titel: |
 |
|
Tolles Programm, ganz großes Kino! 
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 |
|
 |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 21.12.2020, 18:18 Titel: |
|
|
| grindstone hat Folgendes geschrieben: | Tolles Programm, ganz großes Kino!
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 |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4650
Wohnort: ~/
|
| Verfasst am: 21.12.2020, 18:40 Titel: |
|
|
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. 
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 21.12.2020, 18:57 Titel: |
|
|
| 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. |
Freut mich, dass es dir gefällt. 
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 |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4650
Wohnort: ~/
|
| Verfasst am: 21.12.2020, 19:34 Titel: |
|
|
Genau die meine ich - Zeile 92, 93 usw. Dass PI ja auch als Konstante vorkommt, ist mir gar nicht aufgefallen. 
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1875
Wohnort: D59192
|
| Verfasst am: 22.12.2020, 11:50 Titel: |
|
|
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 |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4650
Wohnort: ~/
|
| Verfasst am: 22.12.2020, 15:51 Titel: |
|
|
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.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 20.01.2021, 17:55 Titel: Ray Tracer |
|
|
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ß.
_________________
Gruß,
UEZ |
|
| Nach oben |
|
|
Sebastian
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland
|
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1237
Wohnort: Ruhrpott
|
| Verfasst am: 21.01.2021, 15:14 Titel: |
|
|
Spitze!
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 |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1875
Wohnort: D59192
|
| Verfasst am: 23.01.2021, 11:07 Titel: |
|
|
Klasse 
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 23.01.2021, 15:07 Titel: |
|
|
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.
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 02.03.2021, 20:45 Titel: Dwitter.net Portierungen |
|
|
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. 
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, 19:16, insgesamt 9-mal bearbeitet |
|
| Nach oben |
|
|
Eukalyptus
Anmeldungsdatum: 17.05.2013
Beiträge: 11
|
| Verfasst am: 14.08.2021, 15:10 Titel: Re: Dwitter.net Portierungen |
|
|
| 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.
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 |
|
|
ALWIM
Anmeldungsdatum: 08.08.2006
Beiträge: 1047
Wohnort: Niederbayern
|
| Verfasst am: 18.08.2021, 20:48 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 19.08.2021, 13:29 Titel: |
|
|
| Eukalyptus hat Folgendes geschrieben: | Wie geil ist das denn!!!
Also das hat definitiv viel mehr Aufmerksamkeit verdient! |
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 130
Wohnort: Opel Stadt
|
| Verfasst am: 10.07.2024, 09:23 Titel: Lunar Phase |
|
|
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 |
|
|
|
|
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
