thanks dodicat!
@hurtado thanks for sharing! the intersection from scratchapixel looks optimized
Windows graphics tutorial
Re: Windows graphics tutorial
That's nice but I have some comments:
- It's not a good idea to define a background color in wndclass, otherwise the system will automatically want upgrade the window and we don't want this since it may produce flickering.
- As I have said before, it is not a good idea to place the calling to the painting procedure within the WM_PAINT section at the same time that you have defined your window as resizable. Each time you resize your window a WM_PAINT is commited. There are other ways to go painting by line, for example using PintaObjeto with a global variable to know if we are finished the task. Or simply defining your window as not resizable.
- You may use WinAPI functions in our DIB section because we also have an hdc to create it, just need declarete it as global, as can be viewed here (I draw a message over our DIB section while the image is processed in a thread)
http://abreojosensamblador.epizy.com/?T ... Buddhabrot
Drawing over our DIB section is much faster that over the Windows' hdc
- It's not a good idea to define a background color in wndclass, otherwise the system will automatically want upgrade the window and we don't want this since it may produce flickering.
- As I have said before, it is not a good idea to place the calling to the painting procedure within the WM_PAINT section at the same time that you have defined your window as resizable. Each time you resize your window a WM_PAINT is commited. There are other ways to go painting by line, for example using PintaObjeto with a global variable to know if we are finished the task. Or simply defining your window as not resizable.
- You may use WinAPI functions in our DIB section because we also have an hdc to create it, just need declarete it as global, as can be viewed here (I draw a message over our DIB section while the image is processed in a thread)
http://abreojosensamblador.epizy.com/?T ... Buddhabrot
Drawing over our DIB section is much faster that over the Windows' hdc
Re: Windows graphics tutorial
I have edited the fractal GDI setpixel() spheres code.
No blue background, but a blue frame instead.
You cannot resize the main window.
It is quite fast with 64 bit fbc -O3 optimised.
No blue background, but a blue frame instead.
You cannot resize the main window.
It is quite fast with 64 bit fbc -O3 optimised.
Re: Windows graphics tutorial
Wow, is lightning fast in 64 bits with -0 3
Re: Windows graphics tutorial
Here it is another version. Curiously dodicat's version is much faster. I have to see it
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - SWGPTG - FreeBasic -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2020. http://www.abreojosensamblador.net -
- Small Windows Graphics Programming Tutorial With GDI -
---------------------------------------------------------------------------- '/
#include "windows.bi"
#define cdXPos CW_USEDEFAULT
#define cdYPos CW_USEDEFAULT
#define cdXSize 640 '//cdYSize*1.6
#define cdYSize 400
#define cdColFondo 0
#define MAIN_ICON 100 ' // IDI_APPLICATION
#define cdVCursor IDC_ARROW
#define cdVBarTipo 0
#define cdVBtnTipo WS_OVERLAPPEDWINDOW
#define cdIdTimer 1
'#define DIB_RGB_COLORS 0
#define PI 3.1415926535897932384626433832795
#define cdGrad2Rad 0.01745329251994329576923690768489
#define MAX_RAY_DEPTH 5
#define BUFSIZE MAX_PATH
#define INFINITY 10000000000
#define numEsferas 6
#define max_level 4
#define max_esferas 800
type stVector
dim as double x, y, z
end type
type stDir
dim as Ulong x, y, z
end type
type stMatriz
dim as stVector M(0 to 2)
end type
type stSphere
dim as stVector center
dim as double radius, radius2
dim as stVector surfaceColor, emissionColor
dim as double transparency, reflection
end type
' Prototipos de funciones
Declare Function WndProc (As HWND,As UINT,As WPARAM, As LPARAM) As LRESULT
'// Variables globales
Dim Shared As HWND hMainWnd
Dim Shared As Ulong Ptr pMainDIB
Dim Shared As Ulong vdxClient, vdyClient
Dim Shared As BITMAPINFOHEADER bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
Dim Shared As Ulong nEsferas = 0
Dim Shared As stSphere spheres(max_esferas)
Dim Shared As double invWidth, invHeight, fov, aspectratio, angle, yy
Dim Shared AS Integer glbY, ptrDIB
Function fnCreaDir (x as Ulong, y as Ulong, z as Ulong) as stDir
dim t as stDir
t.x = x : t.y = y : t.z = z
return (t)
End Function
Function fnCreaVector (x as double, y as double, z as double) as stVector
dim t as stVector
t.x = x : t.y = y : t.z = z
Return(t)
End Function
Function fnCreaVectorZ () as stVector
dim t as stVector
t.x = 0 : t.y = 0 : t.z = 0
Return(t)
End Function
Function fnVectSuma (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x+n.x : t.y = m.y+n.y : t.z = m.z+n.z
Return(t)
End Function
Function fnVectResta (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x-n.x : t.y = m.y-n.y : t.z = m.z-n.z
Return(t)
End Function
Function fnVectDot (n as stVector, m as stVector) as Double
Return(n.x*m.x + n.y*m.y + n.z*m.z)
End Function
Function fnVectCross (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.y*m.z-n.z*m.y : t.y = n.z*m.x-n.x*m.z : t.z = n.x*m.y-n.y*m.x
Return(t)
End Function
Function fnVectMult (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.x*m.x : t.y = n.y*m.y : t.z = n.z*m.z
Return(t)
End Function
Function fnVectEscala (n as stVector, d as double) as stVector
dim t as stVector
t.x = n.x*d : t.y = n.y*d : t.z = n.z*d
Return(t)
End Function
Function fnVectOpuesto (n as stVector) as stVector
dim t as stVector
t.x = -n.x : t.y = -n.y : t.z = -n.z
Return(t)
End Function
Function fnVectNormaliza (n as stVector) as stVector
dim t as stVector
dim l2 as double
t.x = n.x : t.y = n.y : t.z = n.z
l2 = n.x*n.x + n.y*n.y + n.z*n.z
if l2 > 0 Then t = fnVectEscala (n, 1.0 / sqr(l2))
Return(t)
End Function
Function fnCreaEsfera (c as stVector, r as double, sc as stVector, refl as double, transp as double, ec as stVector) as stSphere
dim E as stSphere
E.center = c
E.radius = r
E.radius2 = r*r
E.surfaceColor = sc
E.emissionColor = ec
E.transparency = transp
E.reflection = refl
Return (E)
End Function
Function mix (a as double, b as double, mx as double) as double
return (b * mx + a * (1.0 - mx))
End Function
Function fnSphereIntersect (Esfera as stSphere, rayorig as stVector, raydir as stVector, ByRef t0 as double, ByRef t1 as double) as ubyte
dim l as stVector
dim d2 as double, thc as double
dim tca as double
l = fnVectResta(Esfera.center, rayorig)
tca = fnVectDot(l, raydir)
if tca < 0 Then Return(0) ' FALSE
d2 = fnVectDot(l, l) - tca * tca
if (d2 > Esfera.radius2) Then return (0) ' FALSE
thc = sqr(Esfera.radius2 - d2)
t0 = tca - thc
t1 = tca + thc
return (-1) ' TRUE
End Function
Function fnTrace (rayorig as stVector, raydir as stVector, spheres() as stSphere, nSpheres as Ulong, depth as Ulong) as stVector
dim i as Ulong, j as Ulong
dim inside as ubyte ' bool
dim t0 as double, t1 as double, bias as double
dim tnear as double
dim facingratio as double, fresneleffect as double, ior as double, cosi as double, k as double, eta as double
dim sphere as stSphere Ptr
dim surfaceColor as stVector, phit as stVector, nhit as stVector, refldir as stVector, reflection as stVector, refraction as stVector, refrdir as stVector
dim transmission as stVector, lightDirection as stVector, tmp as stVector
tnear = INFINITY
sphere = 0
' Find intersection of this ray with the sphere in the scene
for i = 0 to nSpheres-1
t0 = INFINITY : t1 = INFINITY
if fnSphereIntersect(spheres(i), rayorig, raydir, t0, t1) then
if t0 < 0 Then t0 = t1
if t0 < tnear Then
tnear = t0
sphere = @spheres(i)
End If
end if
next i
If sphere = 0 Then Return(fnCreaVector(2,2,2))
surfaceColor = fnCreaVectorZ()
phit = fnVectSuma(rayorig, fnVectEscala(raydir, tnear))
nhit = fnVectNormaliza(fnVectResta(phit, sphere->center))
bias = 1e-4
inside = 0 'FALSE
If fnVectDot(raydir, nhit) > 0 Then
nhit = fnVectOpuesto(nhit)
inside = -1 ' TRUE
End If
If (sphere->transparency > 0 Or sphere->reflection > 0) And depth < MAX_RAY_DEPTH Then
facingratio = -fnVectDot(raydir, nhit)
fresneleffect = mix((1. - facingratio)*(1. - facingratio)*(1. - facingratio), 1., 0.1)
refldir = fnVectNormaliza(fnVectResta(raydir, fnVectEscala(nhit, 2*fnVectDot(raydir, nhit))))
reflection = fnTrace(fnVectSuma(phit, fnVectEscala(nhit, bias)), refldir, spheres(), nSpheres, depth + 1)
refraction = fnCreaVectorZ()
if sphere->transparency Then
ior = 1.1
If inside = -1 Then eta = ior Else eta = 1.0/ior
cosi = -fnVectDot(nhit, raydir)
k = 1. - eta * eta * (1. - cosi * cosi)
refrdir = fnVectNormaliza(fnVectSuma(fnVectEscala(raydir, eta), fnVectEscala(nhit, eta * cosi - sqr(k))))
refraction = fnTrace(fnVectResta(phit, fnVectEscala(nhit, bias)), refrdir, spheres(), nSpheres, depth + 1)
End If
surfaceColor = fnVectMult( _
fnVectSuma(fnVectEscala(reflection, fresneleffect), _
fnVectEscala(refraction, (1 - fresneleffect) * sphere->transparency)), _
sphere->surfaceColor)
Else
for i = 0 To nSpheres-1
if spheres(i).emissionColor.x > .0 Then
transmission = fnCreaVector (1,1,1)
lightDirection = fnVectNormaliza(fnVectResta(spheres(i).center, phit))
for j = 0 to nSpheres-1
if i <> j Then
if fnSphereIntersect(spheres(j), fnVectSuma(phit, fnVectEscala(nhit, bias)), lightDirection, t0, t1) Then
transmission = fnCreaVectorZ()
Exit for
End if
End If
next j
surfaceColor = fnVectSuma( _
surfaceColor, _
fnVectMult(fnVectEscala(fnVectMult(sphere->surfaceColor, transmission), _
max(.0, fnVectDot(nhit,lightDirection))), _
spheres(i).emissionColor))
End If
next i
End If
Return (fnVectSuma(surfaceColor, sphere->emissionColor))
End Function
Sub render (spheres() as stSphere, nEsferas as Ulong)
dim r as ubyte, g as ubyte, b as ubyte, c as ULong
dim raydir as stVector, image as stVector
dim x as integer, y as integer, xx as double
'dim fr as integer
'fr = FreeFile
'Open "SphereFlake.ppm" FOR BINARY ACCESS WRITE as #fr
'PUT #fr,,"P6"+chr(13)+STR(cdXSize)+" "+STR(cdYSize)+chr(13)+"255"+chr(13)
If glbY < cdYSize Then
for x = 0 to cdXSize-1
xx = (2.0 * ((CDbl(x) + 0.5) * invWidth) - 1.0) * angle * aspectratio
raydir = fnVectNormaliza(fnCreaVector(xx, yy, -1.0))
image = fnTrace(fnCreaVectorZ(), raydir, spheres(), nEsferas, 0)
r = min(1.0, image.x) * 255
g = min(1.0, image.y) * 255
b = min(1.0, image.z) * 255
c = b or (g Shl 8) Or (r Shl 16)
if c <> 16777215 Then
*(pMainDIB+ptrDIB) = c
End If
'PUT #fr,,r
'PUT #fr,,g
'PUT #fr,,b
ptrDIB += 1
next x
glbY += 1
yy = (1.0 - 2.0 * ((CDbl(glbY) + 0.5) * invHeight)) * angle
End If
'Close #fr
End Sub
Sub Flake (n as integer, nivel as integer, direc as stDir)
nivel += 1
if nivel >= max_level Then Exit Sub
if direc.x And 1 Then
spheres(nEsferas) = _
fnCreaEsfera(fnCreaVector( _
spheres(n).center.x+spheres(n).radius+spheres(n).radius/2.0, _
spheres(n).center.y,spheres(n).center.z), _
spheres(n).radius/2.0, _
fnCreaVector(1, 0.32, 0.36), 1, .5, _
fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(1,3,3))
End If
If direc.x And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.y,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(.32, 0.62, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(2,3,3))
End If
If direc.y And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y+spheres(n).radius+spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 1, 0.32), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,1,3))
End If
If direc.y And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 0.32, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,2,3))
End If
If direc.z And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z+spheres(n).radius+spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(.32, 1, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,1))
End If
If direc.z And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z-spheres(n).radius-spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(1, .4, 0.36), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,2))
End If
End Sub
SUB PintaFondo ()
Dim x as integer, y as integer, k as integer
Dim c as ULong
k = 0
for y = 0 to cdYSize-1
c = (255./cdYSize)*CDbl(y)
for x = 0 to cdXSize-1
*(pMainDIB+k) = c 'or (255 shl 8) or (255 shl 16)
k += 1
next x
next y
End Sub
Sub PintaObjeto ()
render (spheres(), nEsferas)
End Sub
Sub Inicio ()
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(0, 0,-30),4, fnCreaVector(1, 0.32, 0.36), 1, .5, fnCreaVectorZ())
nEsferas += 1
Flake (0, 0, fnCreaDir(3,3,3))
spheres(nEsferas) = fnCreaEsfera (fnCreaVector( 20, 20, 50), 3, fnCreaVector(0, 0, 0), 0, 0, fnCreaVector(3,3,3))
nEsferas += 1
invWidth = 1.0 / cdXSize : invHeight = 1.0 / cdYSize
fov = 40.: aspectratio = cdXSize * invHeight
angle = tan(0.5 * fov * cdGrad2Rad)
glbY = 0
yy = (1.0 - 2.0 * ((CDbl(glbY) + 0.5) * invHeight)) * angle
ptrDIB = 0
PintaFondo ()
End Sub
Function WndProc(hWnd As HWND, message As UINT, wParam As wPARAM,lParam As LPARAM) As LRESULT
Static As HDC bufDIBDC
Static As HBITMAP hMainDIB
Dim As HDC hdc
Dim As PAINTSTRUCT ps
Static As HGDIOBJ hOldDIB=0, hGDITmp
Dim As Ulong bResult
Select Case message
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
SendMessage hWnd, WM_CLOSE, 0, 0
End If
Return 0
Case WM_CREATE:
hdc = GetDC(hWnd)
'// Crea un búfer dib para PintaObjeto. pMainDIB es un puntero a él
bufDIBDC = CreateCompatibleDC (hdc)
hMainDIB = CreateDIBSection(hdc,Cast(Any Ptr, @bi), DIB_RGB_COLORS, @pMainDIB, NULL, 0)
hOldDIB = SelectObject (bufDIBDC, hMainDIB)
ReleaseDC (hWnd, hdc)' // Libera device context
Inicio ()
SetTimer (hWnd, cdIdTimer, 0, NULL)
Return 0
Case WM_TIMER :
PintaObjeto ()
InvalidateRect (hWnd, NULL, FALSE)
Return 0
Case WM_SIZE :
vdxClient = lParam And &hFFFF
vdyClient = lParam Shr &h10 '>>
Return 0
Case WM_PAINT :
hdc = BeginPaint(hWnd, @ps)
'//bResult = BitBlt(hdc, 0, 0, cdXSize, cdYSize, bufDIBDC, 0, 0, SRCCOPY)
bResult = StretchBlt (hdc, 0, 0, vdxClient, vdyClient, bufDIBDC, 0, 0, cdXSize, cdYSize, SRCCOPY)
EndPaint(hWnd, @ps)
Return 0
Case WM_DESTROY
KillTimer (hWnd, cdIdTimer)
hGDITmp = SelectObject (bufDIBDC, hOldDIB)
bResult = DeleteDC (bufDIBDC)
bResult = DeleteObject (hMainDIB)
PostQuitMessage (0)
Return 0
End Select
Return DefWindowProc (hWnd, message, wParam, lParam)
End Function
Function WinMain ( hInstance As HINSTANCE, hPrevInstance As HINSTANCE, _
szCmdLine As pSTR, iCmdShow As Ulong) As Ulong
Dim As RECT WRect
Static As String szAppName:szAppName = "SWGPTG"
Dim As MSG msg
Dim As WNDCLASS wndclass
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = @WndProc
wndclass.cbClsExtra = 0
wndclass.cbWndExtra = 0
wndclass.hbrBackground = cdColFondo
wndclass.lpszMenuName = NULL
wndclass.lpszClassName = Strptr(szAppname)
wndclass.hInstance = GetModuleHandle (NULL)
wndclass.hIcon = LoadIcon(hInstance, MAKEINTRESOURCE(MAIN_ICON))
wndclass.hCursor = LoadCursor (NULL, IDC_ARROW)
If RegisterClass (@wndclass) =0 Then
MessageBox (NULL, "This program requires Windows NT!", _
"Error", MB_ICONERROR)
Return 0
End If
SetRect (@WRect, 0, 0, cdXSize, cdYSize)
AdjustWindowRectEx (@WRect, cdVBtnTipo, 0, cdVBarTipo)
WRect.bottom -= WRect.top
WRect.right -= WRect.left
WRect.left = (GetSystemMetrics (SM_CXSCREEN) - WRect.right)/2
WRect.top = (GetSystemMetrics (SM_CYSCREEN) - WRect.bottom) / 3
hMainWnd = CreateWindowex(0,szAppname ,"SphereFlake - (c) abreojosensamblador.epizy.com", _
cdVBtnTipo , _
WRect.left,WRect.top,WRect.right,WRect.bottom, _
NULL, NULL, hInstance, NULL)
ShowWindow (hMainWnd, iCmdShow)
UpdateWindow (hMainWnd)
While (GetMessage (@msg, NULL, 0, 0))
TranslateMessage (@msg)
DispatchMessage (@msg)
Wend
Return msg.wParam
End Function
winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)
Last edited by hurtado on Jan 27, 2020 16:48, edited 1 time in total.
Re: Windows graphics tutorial
I've added some pseudo anti aliasing to the output screen.
Btw, I've removed the save code...
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - SWGPTG - FreeBasic -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2020. http://www.abreojosensamblador.net -
- Small Windows Graphics Programming Tutorial With GDI -
---------------------------------------------------------------------------- '/
#include "windows.bi"
#define cdXPos CW_USEDEFAULT
#define cdYPos CW_USEDEFAULT
#define cdXSize 640 '//cdYSize*1.6
#define cdYSize 400
#define cdColFondo 0
#define MAIN_ICON 100 ' // IDI_APPLICATION
#define cdVCursor IDC_ARROW
#define cdVBarTipo 0
#define cdVBtnTipo WS_OVERLAPPEDWINDOW
#define cdIdTimer 1
'#define DIB_RGB_COLORS 0
#define PI 3.1415926535897932384626433832795
#define cdGrad2Rad 0.01745329251994329576923690768489
#define MAX_RAY_DEPTH 5
#define BUFSIZE MAX_PATH
#define INFINITY 10000000000
#define numEsferas 6
#define max_level 4
#define max_esferas 800
Const As Ushort iAAFactor = 2, cdXSize2 = cdXSize * iAAFactor, cdYSize2 = cdYSize * iAAFactor
type stVector
dim as double x, y, z
end type
type stDir
dim as Ulong x, y, z
end type
type stMatriz
dim as stVector M(0 to 2)
end type
type stSphere
dim as stVector center
dim as double radius, radius2
dim as stVector surfaceColor, emissionColor
dim as double transparency, reflection
end type
' Prototipos de funciones
Declare Function WndProc (As HWND,As UINT,As WPARAM, As LPARAM) As LRESULT
'// Variables globales
Dim Shared As Ulong Ptr pMainDIB
Dim Shared As Ulong vdxClient, vdyClient
Dim Shared As BITMAPINFOHEADER bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize2,-cdYSize2,1,32,0,0,0,0,0,0)
Dim Shared As Ulong nEsferas = 0
Dim Shared As stSphere spheres(max_esferas)
Function fnCreaDir (x as Ulong, y as Ulong, z as Ulong) as stDir
dim t as stDir
t.x = x : t.y = y : t.z = z
return (t)
End Function
Function fnCreaVector (x as double, y as double, z as double) as stVector
dim t as stVector
t.x = x : t.y = y : t.z = z
Return(t)
End Function
Function fnCreaVectorZ () as stVector
dim t as stVector
t.x = 0 : t.y = 0 : t.z = 0
Return(t)
End Function
Function fnVectSuma (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x+n.x : t.y = m.y+n.y : t.z = m.z+n.z
Return(t)
End Function
Function fnVectResta (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x-n.x : t.y = m.y-n.y : t.z = m.z-n.z
Return(t)
End Function
Function fnVectDot (n as stVector, m as stVector) as Double
Return(n.x*m.x + n.y*m.y + n.z*m.z)
End Function
Function fnVectCross (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.y*m.z-n.z*m.y : t.y = n.z*m.x-n.x*m.z : t.z = n.x*m.y-n.y*m.x
Return(t)
End Function
Function fnVectMult (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.x*m.x : t.y = n.y*m.y : t.z = n.z*m.z
Return(t)
End Function
Function fnVectEscala (n as stVector, d as double) as stVector
dim t as stVector
t.x = n.x*d : t.y = n.y*d : t.z = n.z*d
Return(t)
End Function
Function fnVectOpuesto (n as stVector) as stVector
dim t as stVector
t.x = -n.x : t.y = -n.y : t.z = -n.z
Return(t)
End Function
Function fnVectNormaliza (n as stVector) as stVector
dim t as stVector
dim l2 as double
t.x = n.x : t.y = n.y : t.z = n.z
l2 = n.x*n.x + n.y*n.y + n.z*n.z
if l2 > 0 Then t = fnVectEscala (n, 1.0 / sqr(l2))
Return(t)
End Function
Function fnCreaEsfera (c as stVector, r as double, sc as stVector, refl as double, transp as double, ec as stVector) as stSphere
dim E as stSphere
E.center = c
E.radius = r
E.radius2 = r*r
E.surfaceColor = sc
E.emissionColor = ec
E.transparency = transp
E.reflection = refl
Return (E)
End Function
Function mix (a as double, b as double, mx as double) as double
return (b * mx + a * (1.0 - mx))
End Function
Function fnSphereIntersect (Esfera as stSphere, rayorig as stVector, raydir as stVector, ByRef t0 as double, ByRef t1 as double) as ubyte
dim l as stVector
dim d2 as double, thc as double
dim tca as double
l = fnVectResta(Esfera.center, rayorig)
tca = fnVectDot(l, raydir)
if tca < 0 Then Return(0) ' FALSE
d2 = fnVectDot(l, l) - tca * tca
if (d2 > Esfera.radius2) Then return (0) ' FALSE
thc = sqr(Esfera.radius2 - d2)
t0 = tca - thc
t1 = tca + thc
return (-1) ' TRUE
End Function
Function fnTrace (rayorig as stVector, raydir as stVector, spheres() as stSphere, nSpheres as Ulong, depth as Ulong) as stVector
dim i as Ulong, j as Ulong
dim inside as ubyte ' bool
dim t0 as double, t1 as double, bias as double
dim tnear as double
dim facingratio as double, fresneleffect as double, ior as double, cosi as double, k as double, eta as double
dim sphere as stSphere Ptr
dim surfaceColor as stVector, phit as stVector, nhit as stVector, refldir as stVector, reflection as stVector, refraction as stVector, refrdir as stVector
dim transmission as stVector, lightDirection as stVector, tmp as stVector
tnear = INFINITY
sphere = 0
' Find intersection of this ray with the sphere in the scene
for i = 0 to nSpheres-1
t0 = INFINITY : t1 = INFINITY
if fnSphereIntersect(spheres(i), rayorig, raydir, t0, t1) then
if t0 < 0 Then t0 = t1
if t0 < tnear Then
tnear = t0
sphere = @spheres(i)
End If
end if
next i
If sphere = 0 Then Return(fnCreaVector(2,2,2))
surfaceColor = fnCreaVectorZ()
phit = fnVectSuma(rayorig, fnVectEscala(raydir, tnear))
nhit = fnVectNormaliza(fnVectResta(phit, sphere->center))
bias = 1e-4
inside = 0 'FALSE
If fnVectDot(raydir, nhit) > 0 Then
nhit = fnVectOpuesto(nhit)
inside = -1 ' TRUE
End If
If (sphere->transparency > 0 Or sphere->reflection > 0) And depth < MAX_RAY_DEPTH Then
facingratio = -fnVectDot(raydir, nhit)
fresneleffect = mix((1. - facingratio)*(1. - facingratio)*(1. - facingratio), 1., 0.1)
refldir = fnVectNormaliza(fnVectResta(raydir, fnVectEscala(nhit, 2*fnVectDot(raydir, nhit))))
reflection = fnTrace(fnVectSuma(phit, fnVectEscala(nhit, bias)), refldir, spheres(), nSpheres, depth + 1)
refraction = fnCreaVectorZ()
if sphere->transparency Then
ior = 1.1
If inside = -1 Then eta = ior Else eta = 1.0/ior
cosi = -fnVectDot(nhit, raydir)
k = 1. - eta * eta * (1. - cosi * cosi)
refrdir = fnVectNormaliza(fnVectSuma(fnVectEscala(raydir, eta), fnVectEscala(nhit, eta * cosi - sqr(k))))
refraction = fnTrace(fnVectResta(phit, fnVectEscala(nhit, bias)), refrdir, spheres(), nSpheres, depth + 1)
End If
surfaceColor = fnVectMult( _
fnVectSuma(fnVectEscala(reflection, fresneleffect), _
fnVectEscala(refraction, (1 - fresneleffect) * sphere->transparency)), _
sphere->surfaceColor)
Else
for i = 0 To nSpheres-1
if spheres(i).emissionColor.x > .0 Then
transmission = fnCreaVector (1,1,1)
lightDirection = fnVectNormaliza(fnVectResta(spheres(i).center, phit))
for j = 0 to nSpheres-1
if i <> j Then
if fnSphereIntersect(spheres(j), fnVectSuma(phit, fnVectEscala(nhit, bias)), lightDirection, t0, t1) Then
transmission = fnCreaVectorZ()
Exit for
End if
End If
next j
surfaceColor = fnVectSuma( _
surfaceColor, _
fnVectMult(fnVectEscala(fnVectMult(sphere->surfaceColor, transmission), _
max(.0, fnVectDot(nhit,lightDirection))), _
spheres(i).emissionColor))
End If
next i
End If
Return (fnVectSuma(surfaceColor, sphere->emissionColor))
End Function
Sub render (spheres() as stSphere, nEsferas as Ulong)
dim r as ubyte, g as ubyte, b as ubyte, i as integer
dim raydir as stVector, image as stVector
dim invWidth as double, invHeight as double
dim fov as double, aspectratio as double, angle as double
dim x as integer, y as integer, xx as double, yy as double
' dim fr as integer
' fr = FreeFile
' Open "SphereFlake.ppm" FOR BINARY ACCESS WRITE as #fr
' PUT #fr,,"P6"+chr(13)+STR(cdXSize)+" "+STR(cdYSize)+chr(13)+"255"+chr(13)
invWidth = 1.0 / cdXSize2 : invHeight = 1.0 / cdYSize2
fov = 40.: aspectratio = cdXSize2 * invHeight
angle = tan(0.5 * fov * cdGrad2Rad)
i = 0
for y = 0 to cdYSize2-1
yy = (1.0 - 2.0 * ((CDbl(y) + 0.5) * invHeight)) * angle
for x = 0 to cdXSize2-1
xx = (2.0 * ((CDbl(x) + 0.5) * invWidth) - 1.0) * angle * aspectratio
raydir = fnVectNormaliza(fnCreaVector(xx, yy, -1.0))
image = fnTrace(fnCreaVectorZ(), raydir, spheres(), nEsferas, 0)
r = min(1.0, image.x) * 255
g = min(1.0, image.y) * 255
b = min(1.0, image.z) * 255
*(pMainDIB+i) = b or (g Shl 8) Or (r Shl 16)
' PUT #fr,,r
' PUT #fr,,g
' PUT #fr,,b
i += 1
next x
next y
' Close #fr
End Sub
Sub Flake (n as integer, nivel as integer, direc as stDir)
nivel += 1
if nivel >= max_level Then Exit Sub
if direc.x And 1 Then
spheres(nEsferas) = _
fnCreaEsfera(fnCreaVector( _
spheres(n).center.x+spheres(n).radius+spheres(n).radius/2.0, _
spheres(n).center.y,spheres(n).center.z), _
spheres(n).radius/2.0, _
fnCreaVector(1, 0.32, 0.36), 1, .5, _
fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(1,3,3))
End If
If direc.x And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.y,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(.32, 0.62, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(2,3,3))
End If
If direc.y And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y+spheres(n).radius+spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 1, 0.32), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,1,3))
End If
If direc.y And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 0.32, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,2,3))
End If
If direc.z And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z+spheres(n).radius+spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(.32, 1, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,1))
End If
If direc.z And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z-spheres(n).radius-spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(1, .4, 0.36), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,2))
End If
End Sub
Sub PintaObjeto ()
End Sub
Sub Inicio ()
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(0, 0,-30),4, fnCreaVector(1, 0.32, 0.36), 1, .5, fnCreaVectorZ())
nEsferas += 1
Flake (0, 0, fnCreaDir(3,3,3))
spheres(nEsferas) = fnCreaEsfera (fnCreaVector( 20, 20, 50), 3, fnCreaVector(0, 0, 0), 0, 0, fnCreaVector(3,3,3))
nEsferas += 1
render (spheres(), nEsferas)
End Sub
Function WndProc(hWnd As HWND, message As UINT, wParam As wPARAM,lParam As LPARAM) As LRESULT
Static As HDC bufDIBDC
Static As HBITMAP hMainDIB
Dim As HDC hdc
Dim As PAINTSTRUCT ps
Static As HGDIOBJ hOldDIB=0, hGDITmp
Dim As Ulong bResult
Select Case message
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
SendMessage hWnd, WM_CLOSE, 0, 0
End If
Return 0
Case WM_CREATE:
hdc = GetDC(hWnd)
'// Crea un búfer dib para PintaObjeto. pMainDIB es un puntero a él
bufDIBDC = CreateCompatibleDC (hdc)
hMainDIB = CreateDIBSection(hdc,Cast(Any Ptr, @bi), DIB_RGB_COLORS, @pMainDIB, NULL, 0)
hOldDIB = SelectObject (bufDIBDC, hMainDIB)
SetStretchBltMode(hdc, HALFTONE)
SetStretchBltMode(bufDIBDC, HALFTONE)
Inicio ()
ReleaseDC (hWnd, hdc)' // Libera device context
SetTimer (hWnd, cdIdTimer, 20, NULL)
Return 0
Case WM_TIMER :
PintaObjeto ()
InvalidateRect (hWnd, NULL, FALSE)
Return 0
Case WM_SIZE :
vdxClient = lParam And &hFFFF
vdyClient = lParam Shr &h10 '>>
Return 0
Case WM_PAINT :
hdc = BeginPaint(hWnd, @ps)
'//bResult = BitBlt(hdc, 0, 0, cdXSize, cdYSize, bufDIBDC, 0, 0, SRCCOPY)
bResult = StretchBlt (hdc, 0, 0, vdxClient, vdyClient, bufDIBDC, 0, 0, cdXSize2, cdYSize2, SRCCOPY)
EndPaint(hWnd, @ps)
Return 0
Case WM_DESTROY
KillTimer (hWnd, cdIdTimer)
hGDITmp = SelectObject (bufDIBDC, hOldDIB)
bResult = DeleteDC (bufDIBDC)
bResult = DeleteObject (hMainDIB)
PostQuitMessage (0)
Return 0
End Select
Return DefWindowProc (hWnd, message, wParam, lParam)
End Function
Function WinMain ( hInstance As HINSTANCE, hPrevInstance As HINSTANCE, _
szCmdLine As pSTR, iCmdShow As Ulong) As Ulong
Dim As RECT WRect
Static As String szAppName:szAppName = "SWGPTG"
Dim As HWND hWnd
Dim As MSG msg
Dim As WNDCLASS wndclass
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = @WndProc
wndclass.cbClsExtra = 0
wndclass.cbWndExtra = 0
wndclass.hbrBackground = cdColFondo
wndclass.lpszMenuName = NULL
wndclass.lpszClassName = Strptr(szAppname)
wndclass.hInstance = GetModuleHandle (NULL)
wndclass.hIcon = LoadIcon(hInstance, MAKEINTRESOURCE(MAIN_ICON))
wndclass.hCursor = LoadCursor (NULL, IDC_ARROW)
If RegisterClass (@wndclass) =0 Then
MessageBox (NULL, "This program requires Windows NT!", _
"Error", MB_ICONERROR)
Return 0
End If
SetRect (@WRect, 0, 0, cdXSize, cdYSize)
AdjustWindowRectEx (@WRect, cdVBtnTipo, 0, cdVBarTipo)
WRect.bottom -= WRect.top
WRect.right -= WRect.left
WRect.left = (GetSystemMetrics (SM_CXSCREEN) - WRect.right)/2
WRect.top = (GetSystemMetrics (SM_CYSCREEN) - WRect.bottom) / 3
hWnd = CreateWindowex(0,szAppname ,"SphereFlake Anti Aliased - (c) abreojosensamblador.epizy.com", _
cdVBtnTipo , _
WRect.left,WRect.top,WRect.right,WRect.bottom, _
NULL, NULL, hInstance, NULL)
ShowWindow (hWnd, iCmdShow)
UpdateWindow (hWnd)
While (GetMessage (@msg, NULL, 0, 0))
TranslateMessage (@msg)
DispatchMessage (@msg)
Wend
Return msg.wParam
End Function
winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)
Re: Windows graphics tutorial
@UEZ
Not bad, the difference is better apreciated increasing the window size.
The -O 3 option is really good. My first version takes about 4-5 seconds (I think) even creating the ppm file, I think a bit faster than dodicat's version, which seems to be a bit faster than my line by line version. This latest version has to draw the entire dib each time, that is a waste of time, maybe here is the weakest point.
Not bad, the difference is better apreciated increasing the window size.
The -O 3 option is really good. My first version takes about 4-5 seconds (I think) even creating the ppm file, I think a bit faster than dodicat's version, which seems to be a bit faster than my line by line version. This latest version has to draw the entire dib each time, that is a waste of time, maybe here is the weakest point.
Re: Windows graphics tutorial
This is a great big pseudo anti aliasing cheat.
The final result shows when the fractal is finished and the close button is clicked or <esc> is pressed.
The final result shows when the fractal is finished and the close button is clicked or <esc> is pressed.
Code: Select all
#include "windows.bi"
#define cdXSize 640 '//cdYSize*1.6
#define cdYSize 400
#define cdColFondo 0
#define MAIN_ICON 100 ' // IDI_APPLICATION
#define cdVCursor IDC_ARROW
#define cdVBarTipo 0
#define cdVBtnTipo WS_OVERLAPPEDWINDOW
#define cdIdTimer 1
'#define DIB_RGB_COLORS 0
#define PI 3.1415926535897932384626433832795
#define cdGrad2Rad 0.01745329251994329576923690768489
#define MAX_RAY_DEPTH 5
#define BUFSIZE MAX_PATH
#define INFINITY 10000000000
#define numEsferas 6
#define max_level 4
#define max_esferas 800
Declare Function WndProc(As HWND,As UINT, As WPARAM, As LPARAM) As lresult
Declare Function winMain(As HINSTANCE,As HINSTANCE,As PWSTR,As Integer) As Integer
Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long
declare Function Filter(byref As ulong Pointer,as single,as long=1,as long=0) as ulong ptr
screenres cdxsize, cdysize ,32,,-1
dim shared as any ptr im:im=imagecreate(cdxsize, cdysize)
winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)
sleep
imagedestroy im
type stVector
dim as double x, y, z
end type
type stDir
dim as Ulong x, y, z
end type
type stMatriz
dim as stVector M(0 to 2)
end type
type stSphere
dim as stVector center
dim as double radius, radius2
dim as stVector surfaceColor, emissionColor
dim as double transparency, reflection
end type
' Prototipos de funciones
'// Variables globales
'Dim Shared As Ulong Ptr pMainDIB
'Dim Shared As Ulong vdxClient, vdyClient
'Dim Shared As BITMAPINFOHEADER bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
Dim Shared As Ulong nEsferas = 0
Dim Shared As stSphere spheres(max_esferas)
dim shared as any ptr win
Function fnCreaDir (x as Ulong, y as Ulong, z as Ulong) as stDir
dim t as stDir
t.x = x : t.y = y : t.z = z
return (t)
End Function
Function fnCreaVector (x as double, y as double, z as double) as stVector
dim t as stVector
t.x = x : t.y = y : t.z = z
Return(t)
End Function
Function fnCreaVectorZ () as stVector
dim t as stVector
t.x = 0 : t.y = 0 : t.z = 0
Return(t)
End Function
Function fnVectSuma (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x+n.x : t.y = m.y+n.y : t.z = m.z+n.z
Return(t)
End Function
Function fnVectResta (m as stVector, n as stVector) as stVector
dim t as stVector
t.x = m.x-n.x : t.y = m.y-n.y : t.z = m.z-n.z
Return(t)
End Function
Function fnVectDot (n as stVector, m as stVector) as Double
Return(n.x*m.x + n.y*m.y + n.z*m.z)
End Function
Function fnVectCross (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.y*m.z-n.z*m.y : t.y = n.z*m.x-n.x*m.z : t.z = n.x*m.y-n.y*m.x
Return(t)
End Function
Function fnVectMult (n as stVector, m as stVector) as stVector
dim t as stVector
t.x = n.x*m.x : t.y = n.y*m.y : t.z = n.z*m.z
Return(t)
End Function
Function fnVectEscala (n as stVector, d as double) as stVector
dim t as stVector
t.x = n.x*d : t.y = n.y*d : t.z = n.z*d
Return(t)
End Function
Function fnVectOpuesto (n as stVector) as stVector
dim t as stVector
t.x = -n.x : t.y = -n.y : t.z = -n.z
Return(t)
End Function
Function fnVectNormaliza (n as stVector) as stVector
dim t as stVector
dim l2 as double
t.x = n.x : t.y = n.y : t.z = n.z
l2 = n.x*n.x + n.y*n.y + n.z*n.z
if l2 > 0 Then t = fnVectEscala (n, 1.0 / sqr(l2))
Return(t)
End Function
Function fnCreaEsfera (c as stVector, r as double, sc as stVector, refl as double, transp as double, ec as stVector) as stSphere
dim E as stSphere
E.center = c
E.radius = r
E.radius2 = r*r
E.surfaceColor = sc
E.emissionColor = ec
E.transparency = transp
E.reflection = refl
Return (E)
End Function
Function mix (a as double, b as double, mx as double) as double
return (b * mx + a * (1.0 - mx))
End Function
Function fnSphereIntersect (Esfera as stSphere, rayorig as stVector, raydir as stVector, ByRef t0 as double, ByRef t1 as double) as ubyte
dim l as stVector
dim d2 as double, thc as double
dim tca as double
l = fnVectResta(Esfera.center, rayorig)
tca = fnVectDot(l, raydir)
if tca < 0 Then Return(0) ' FALSE
d2 = fnVectDot(l, l) - tca * tca
if (d2 > Esfera.radius2) Then return (0) ' FALSE
thc = sqr(Esfera.radius2 - d2)
t0 = tca - thc
t1 = tca + thc
return (-1) ' TRUE
End Function
Function fnTrace (rayorig as stVector, raydir as stVector, spheres() as stSphere, nSpheres as Ulong, depth as Ulong) as stVector
dim i as Ulong, j as Ulong
dim inside as ubyte ' bool
dim t0 as double, t1 as double, bias as double
dim tnear as double
dim facingratio as double, fresneleffect as double, ior as double, cosi as double, k as double, eta as double
dim sphere as stSphere Ptr
dim surfaceColor as stVector, phit as stVector, nhit as stVector, refldir as stVector, reflection as stVector, refraction as stVector, refrdir as stVector
dim transmission as stVector, lightDirection as stVector, tmp as stVector
tnear = INFINITY
sphere = 0
' Find intersection of this ray with the sphere in the scene
for i = 0 to nSpheres-1
t0 = INFINITY : t1 = INFINITY
if fnSphereIntersect(spheres(i), rayorig, raydir, t0, t1) then
if t0 < 0 Then t0 = t1
if t0 < tnear Then
tnear = t0
sphere = @spheres(i)
End If
end if
next i
If sphere = 0 Then Return(fnCreaVector(2,2,2))
surfaceColor = fnCreaVectorZ()
phit = fnVectSuma(rayorig, fnVectEscala(raydir, tnear))
nhit = fnVectNormaliza(fnVectResta(phit, sphere->center))
bias = 1e-4
inside = 0 'FALSE
If fnVectDot(raydir, nhit) > 0 Then
nhit = fnVectOpuesto(nhit)
inside = -1 ' TRUE
End If
If (sphere->transparency > 0 Or sphere->reflection > 0) And depth < MAX_RAY_DEPTH Then
facingratio = -fnVectDot(raydir, nhit)
fresneleffect = mix((1. - facingratio)*(1. - facingratio)*(1. - facingratio), 1., 0.1)
refldir = fnVectNormaliza(fnVectResta(raydir, fnVectEscala(nhit, 2*fnVectDot(raydir, nhit))))
reflection = fnTrace(fnVectSuma(phit, fnVectEscala(nhit, bias)), refldir, spheres(), nSpheres, depth + 1)
refraction = fnCreaVectorZ()
if sphere->transparency Then
ior = 1.1
If inside = -1 Then eta = ior Else eta = 1.0/ior
cosi = -fnVectDot(nhit, raydir)
k = 1. - eta * eta * (1. - cosi * cosi)
refrdir = fnVectNormaliza(fnVectSuma(fnVectEscala(raydir, eta), fnVectEscala(nhit, eta * cosi - sqr(k))))
refraction = fnTrace(fnVectResta(phit, fnVectEscala(nhit, bias)), refrdir, spheres(), nSpheres, depth + 1)
End If
surfaceColor = fnVectMult( _
fnVectSuma(fnVectEscala(reflection, fresneleffect), _
fnVectEscala(refraction, (1 - fresneleffect) * sphere->transparency)), _
sphere->surfaceColor)
Else
for i = 0 To nSpheres-1
if spheres(i).emissionColor.x > .0 Then
transmission = fnCreaVector (1,1,1)
lightDirection = fnVectNormaliza(fnVectResta(spheres(i).center, phit))
for j = 0 to nSpheres-1
if i <> j Then
if fnSphereIntersect(spheres(j), fnVectSuma(phit, fnVectEscala(nhit, bias)), lightDirection, t0, t1) Then
transmission = fnCreaVectorZ()
Exit for
End if
End If
next j
surfaceColor = fnVectSuma( _
surfaceColor, _
fnVectMult(fnVectEscala(fnVectMult(sphere->surfaceColor, transmission), _
max(.0, fnVectDot(nhit,lightDirection))), _
spheres(i).emissionColor))
End If
next i
End If
Return (fnVectSuma(surfaceColor, sphere->emissionColor))
End Function
Sub render (spheres() as stSphere, nEsferas as Ulong,hdc as any ptr)
dim r as ubyte, g as ubyte, b as ubyte, i as integer
dim raydir as stVector, image as stVector
dim invWidth as double, invHeight as double
dim fov as double, aspectratio as double, angle as double
dim x as integer, y as integer, xx as double, yy as double
invWidth = 1.0 / cdXSize : invHeight = 1.0 / cdYSize
fov = 40.: aspectratio = cdXSize * invHeight
angle = tan(0.5 * fov * cdGrad2Rad)
i = 0
for y = 0 to cdYSize-1
yy = (1.0 - 2.0 * ((CDbl(y) + 0.5) * invHeight)) * angle
for x = 0 to cdXSize-1
xx = (2.0 * ((CDbl(x) + 0.5) * invWidth) - 1.0) * angle * aspectratio
raydir = fnVectNormaliza(fnCreaVector(xx, yy, -1.0))
image = fnTrace(fnCreaVectorZ(), raydir, spheres(), nEsferas, 0)
r = min(1.0, image.x) * 255
g = min(1.0, image.y) * 255
b = min(1.0, image.z) * 255
SetPixel(hdc,x,y,BGR(r,g,b))
pset im,(x,y),rgb(r,g,b)
'i += 1
next x
next y
End Sub
Sub Flake (n as integer, nivel as integer, direc as stDir)
nivel += 1
if nivel >= max_level Then Exit Sub
if direc.x And 1 Then
spheres(nEsferas) = _
fnCreaEsfera(fnCreaVector( _
spheres(n).center.x+spheres(n).radius+spheres(n).radius/2.0, _
spheres(n).center.y,spheres(n).center.z), _
spheres(n).radius/2.0, _
fnCreaVector(1, 0.32, 0.36), 1, .5, _
fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(1,3,3))
End If
If direc.x And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.y,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(.32, 0.62, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(2,3,3))
End If
If direc.y And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y+spheres(n).radius+spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 1, 0.32), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,1,3))
End If
If direc.y And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y-spheres(n).radius-spheres(n).radius/2.0,spheres(n).center.z),spheres(n).radius/2.0, fnCreaVector(1, 0.32, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,2,3))
End If
If direc.z And 1 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z+spheres(n).radius+spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(.32, 1, 1), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,1))
End If
If direc.z And 2 Then
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(spheres(n).center.x,spheres(n).center.y,spheres(n).center.z-spheres(n).radius-spheres(n).radius/2.0),spheres(n).radius/2.0, fnCreaVector(1, .4, 0.36), 1.0, .5, fnCreaVectorZ())
nEsferas += 1
Flake (nEsferas-1, nivel, fnCreaDir(3,3,2))
End If
End Sub
Sub Inicio (hdc as any ptr)
spheres(nEsferas) = fnCreaEsfera(fnCreaVector(0, 0,-30),4, fnCreaVector(1, 0.32, 0.36), 1, .5, fnCreaVectorZ())
nEsferas += 1
Flake (0, 0, fnCreaDir(3,3,3))
spheres(nEsferas) = fnCreaEsfera (fnCreaVector( 20, 20, 50), 3, fnCreaVector(0, 0, 0), 0, 0, fnCreaVector(3,3,3))
nEsferas += 1
render (spheres(), nEsferas,hdc)
End Sub
Function WinMain(hInstance As HINSTANCE ,hPrevInstance As HINSTANCE ,_
lpCmdLine As PWSTR ,nCmdShow As Integer )As Integer
Dim As MSG msg
Dim As WNDCLASS wc
Static As String appname:appname="Lines"
wc.style = CS_HREDRAW Or CS_VREDRAW
wc.lpszClassName = Strptr(appname)
wc.hInstance = hInstance
wc.hbrBackground = GetSysColorBrush(COLOR_3DFACE)
wc.lpfnWndProc = @WndProc
wc.hCursor = LoadCursor(0, IDC_ARROW)
If RegisterClass (@wc) =0 Then
MessageBox (NULL, "This program requires Windows NT!", _
"Error", MB_ICONERROR)
Return 0
End If
win=CreateWindowex(WS_EX_TOPMOST Or WS_EX_TOOLWINDOW,appname, "", _
(WS_OVERLAPPEDWINDOW Or WS_SYSMENU) - (WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME) Or WS_VISIBLE , _
100, 100, cdxsize, cdysize, NULL, NULL, hInstance, NULL)
SetWindowTheme(win," "," ")
While (GetMessage(@msg, NULL, 0, 0))
TranslateMessage(@msg)
DispatchMessage(@msg)
Wend
Return 0
End Function
Function WndProc(hwnd As HWND,msg As UINT,_
wparam As WPARAM, lparam As LPARAM) As lresult
Dim As HDC hdc
Dim As PAINTSTRUCT ps
Select Case msg
Case WM_PAINT:
hdc = BeginPaint(hwnd, @ps)
' FillRect(ps.hdc, @ps.rcPaint, CreateSolidBrush(BGR(100,100,255)))
inicio(hdc)
EndPaint(hwnd, @ps)
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
screenres cdxsize, cdysize,32
screencontrol 100,100,100
Dim W As Any Ptr
var Ip = Cptr(Integer Ptr,@W )
Screencontrol 2, *Ip
SetWindowTheme(w," "," ")
windowtitle ""
SendMessage hWnd, WM_CLOSE, 0, 0
im=filter(im,1)
put (0,0),im,pset
End If
Case WM_DESTROY
destroy:
screenres cdxsize, cdysize,32
screencontrol 100,100,100
Dim W As Any Ptr
var Ip = Cptr(Integer Ptr,@W )
Screencontrol 2, *Ip
SetWindowTheme(w," "," ")
windowtitle ""
PostQuitMessage(0)
im=filter(im,1)
put (0,0),im,pset
end select
Return DefWindowProcW(hwnd, msg, wParam, lParam)
End Function
Function Filter(Byref tim As ulong Pointer,_
rad As Single,_
destroy As long=1,_
fade As long=0) As ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Integer x,y
As ulong col
End Type
#macro putpixel(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As long=-ymin To ymax
For x1 As long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=map(0,100,fade,1,0)
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As ulong Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As ulong Pointer pixel
Dim As ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As long=0 To (_y)-1
For x As long=0 To (_x)-1
putpixel(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As ulong averagecolour
Dim As long ar,ag,ab
Dim As long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As long=0 To _y-1
For x As long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
If destroy Then ImageDestroy tim: tim = 0
Function= im
End Function
Re: Windows graphics tutorial
Here's some antialiasing code from waaaay back, fbc 0.24 era (modified enough so that it compiles with the current version):
It uses wupixels for the antialiasing, but a modified version that modulates the opacity of the pixels instead of their 'brightness' as in the original. The speed of the antialiased rendering is almost exactly half of the non-antialiased one, if not for the fact that wupixels have to render four pixels instead of just one (here, the two on the same scanline are blitted at the same time), so it might not be so bad after all.
@dafhi: if you're reading this, I knew I had seen the 'double blending' trick somewhere before. This was sitting on my HD for quite some time now, and only recently stumbled upon it again XD
Code: Select all
#include once "fbgfx.bi"
#define pixel_r( c ) ( culng( c ) shr 16 and 255 )
#define pixel_g( c ) ( culng( c ) shr 8 and 255 )
#define pixel_b( c ) ( culng( c ) and 255 )
#define pixel_a( c ) ( culng( c ) shr 24 )
dim shared as integer sw = 800, sh = 600
function pixelAlphaD( byval src as ulongint, byval dst as ulongint, byval opacity2 as ubyte = 255, byval opacity1 as ubyte = 255 ) as ulongint
opacity1 = ( ( culng( src shr 32 ) shr 24 ) * opacity1 ) shr 8
opacity2 = ( ( culng( src ) shr 24 ) * opacity2 ) shr 8
return( _
( ( ( ( src shr 32 and &hff00ff ) * opacity1 + _
( dst shr 32 and &hff00ff ) * ( 255 - opacity1 ) ) and &hff00ff00 ) shr 8 or ( _
( ( ( src shr 32 ) shr 8 ) and &hff00ff ) * opacity1 + _
( ( ( dst shr 32 ) shr 8 ) and &hff00ff ) * ( 255 - opacity1 ) ) and &hff00ff00 ) shl 32 or _
( ( ( ( src and &hff00ff ) * opacity2 + _
( dst and &hff00ff ) * ( 255 - opacity2 ) ) and &hff00ff00 ) shr 8 or ( _
( ( src shr 8 ) and &hff00ff ) * opacity2 + _
( ( dst shr 8 ) and &hff00ff ) * ( 255 - opacity2 ) ) and &hff00ff00 ) )
end function
sub wuPixelD( _
byval wx as single, _
byval wy as single, _
byval wc as ulong, _
byval buffer as ulong ptr = screenPtr() )
if( wx >= 0 andAlso wx + 1 <= sw - 1 andAlso wy >= 0 andAlso wy + 1 <= sh - 1 ) then
dim as integer x, y
dim as ubyte fx, fy
x = int( wx )
y = int( wy )
fx = ( wx - x ) * 255
fy = ( wy - y ) * 255
dim as ulongint ptr pxlt = cptr( ulongint ptr, buffer + ( sw * y + x ) )
dim as ulongint ptr pxlb = cptr( ulongint ptr, buffer + ( sw * ( y + 1 ) + x ) )
*pxlt = pixelAlphaD( ( culngint( wc ) shl 32 ) or wc, *pxlt, _
( ( 255 - fx ) * ( 255 - fy ) ) shr 8, ( fx * ( 255 - fy ) ) shr 8 )
*pxlb = pixelAlphaD( ( culngint( wc ) shl 32 ) or wc, *pxlb, _
( ( 255 - fx ) * fy ) shr 8, ( fx * fy ) shr 8 )
end if
end sub
sub DDALineD( _
byval x1 as single, _
byval y1 as single, _
byval x2 as single, _
byval y2 as single, _
byval c as ulong, _
byval buffer as ulong ptr = screenPtr() )
dim as single dx, dy
dim as single x_inc, y_inc, x, y
dim as integer steps
dx = x2 - x1
dy = y2 - y1
if( dx = 0 ) then
x1 += 0.25
x2 += 0.25
end if
y1 += 0.25
y2 += 0.25
steps = int( iif( abs( dx ) > abs( dy ), _
abs( dx ), abs( dy ) ) )
x_inc = dx / steps
y_inc = dy / steps
x = x1
y = y1
for i as integer = 0 to steps
wuPixelD( x, y, c, buffer )
x += x_inc
y += y_inc
next
end sub
type lines
as single x1
as single y1
as single x2
as single y2
as ulong c
end type
screenRes( sw, sh, 32, , fb.gfx_alpha_primitives )
dim as string k
dim as integer numLines = 1000
dim as lines l( 0 to numLines - 1 )
randomize()
for i as integer = 0 to numLines - 1
with l( i )
.x1 = rnd() * sw
.y1 = rnd() * sh
.x2 = rnd() * sw
.y2 = rnd() * sh
.c = rgba( 255 * rnd(), 255 * rnd(), 255 * rnd(), 255 * rnd() )
end with
next
color( rgba( 0, 0, 0, 255 ), rgba( 255, 255, 255, 255 ) )
dim as double t, sum
dim as uinteger count
dim as boolean antiAlias = false
do
k = inkey()
if( k = "1" ) then
sum = 0.0
count = 0
antiAlias = true
end if
if( k = "2" ) then
sum = 0.0
count = 0
antiAlias = false
end if
t = timer()
screenLock()
cls()
for i as integer = 0 to numLines - 1
if( antiAlias = true ) then
DDAlineD( l( i ).x1, l( i ).y1, l( i ).x2, l( i ).y2, l( i ).c )
else
line( l( i ).x1, l( i ).y1 ) - ( l( i ).x2, l( i ).y2 ), l( i ).c
end if
next
screenUnLock()
t = timer() - t
sum += t
count += 1
sleep( 1, 1 )
windowTitle( str( int( 1 / ( sum / count ) ) ) & iif( antiAlias = true, " FPS (antialiased)", " FPS" ) )
loop until( k = chr( 27 ) )
@dafhi: if you're reading this, I knew I had seen the 'double blending' trick somewhere before. This was sitting on my HD for quite some time now, and only recently stumbled upon it again XD
-
D.J.Peters
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: Windows graphics tutorial
I played with the sphere flake stuff here is the result.
for a larger screen enable line 272 (with screeninfo)
would be nice if anyone can post the render time for "const MAX_FLAKE_LEVEL = 3" and optimation "-O 3" thank you.
I get 5 seconds and 1 second with "-O 3" !
Joshy
for a larger screen enable line 272 (with screeninfo)
would be nice if anyone can post the render time for "const MAX_FLAKE_LEVEL = 3" and optimation "-O 3" thank you.
I get 5 seconds and 1 second with "-O 3" !
Joshy
Code: Select all
' changes:
' MAX_SPHERES isn't needed any more !
' I replaced the shared fixed size sphere array with a dynamic sphere pointer list.
' The math stuff is faster now.
' I added a second sphere hit function where t the ray length isn't needed at all.
const MAX_RAY_DEPTH = 5
'const MAX_FLAKE_LEVEL = 1 ' = 6 spheres + the one base/center sphere !
'const MAX_FLAKE_LEVEL = 2 ' = 36 spheres + the one base/center sphere !
const MAX_FLAKE_LEVEL = 3 ' = 186 spheres + the one base/center sphere !
'const MAX_FLAKE_LEVEL = 4 ' = 936 spheres + the one base/center sphere !
'const MAX_FLAKE_LEVEL = 5 ' = 4866 spheres + the one base/center sphere !
'const MAX_FLAKE_LEVEL = 6 ' = 23436 spheres + the one base/center sphere !
type tVector
as double x, y, z
end type
type tDir
as Ulong x, y, z
end type
type tSphere
as tVector center,surfaceColor,emissionColor
as double radius,radius2,transparency, reflection
end type
' some vector and math stuff as inlined code !
#define DSet(a,b,c) type<tDir>(culng(a),culng(b),culng(c))
#define VSet(a,b,c) type<tVector>((a),(b),(c))
#define VZero type<tVector>(0,0,0)
#define VAdd(a,b) type<tVector>(a.x+b.x,a.y+b.y,a.z+b.z)
#define VSub(a,b) type<tVector>(a.x-b.x,a.y-b.y,a.z-b.z)
#define VCross(a,b) type<tVector>(a.y*b.z - a.z*b.y, a.z*b.x - a.x*b.z, a.x*b.y - a.y*b.x)
#define VMul(a,b) type<tVector>(a.x*b.x,a.y*b.y,a.z*b.z)
#define VScale(a,b) type<tVector>(a.x*(b),a.y*(b),a.z*(b))
#define VNeg(a) type<tVector>(-a.x,-a.y,-a.z)
#define VAddRay(a,b,c) type<tVector>(a.x+b.x*c,a.y+b.y*c,a.z+b.z*c)
#define VSubRay(a,b,c) type<tVector>(a.x-b.x*c,a.y-b.y*c,a.z-b.z*c)
#define VDot(a,b) (a.x*b.x + a.y*b.y + a.z*b.z)
#define VLen(a) sqr(VDot(a,a))
#define VDistance(a,b) VLen(VSub(a,b))
#define min(a,b) iif((a)<(b),(a),(b))
#define max(a,b) iif((a)>(b),(a),(b))
#define mix(a,b,c) ((b)*(c) + (a)*(1.0-(c)))
Function VNorm (n as tVector) as tVector
var l2 = VDot(n,n)
if l2 > 0 Then l2=1/sqr(l2):return VScale(n,l2)
Return n
End Function
Function CreateSphere (center as tVector, _
radius as double, _
surfaceColor as tVector, _
reflection as double, _
transparency as double, _
emissionColor as tVector) as tSphere ptr
static as integer nSpheres=0
dim as tSphere ptr newSphere = callocate(sizeof(tSphere))
with *newSphere
.center = center
.radius = radius
.radius2 = radius*radius
.surfaceColor = surfaceColor
.emissionColor = emissionColor
.transparency = transparency
.reflection = reflection
end with
nSpheres+=1
print "sphere " & nSpheres & " added !"
Return newSphere
End Function
' sphere hit test only
Function SphereHit(ByRef sphere as const tSphere ptr, _
ByRef rayOrg as const tVector, _
ByRef rayDir as const tVector) as boolean
dim as double d1=any,d2=any
var diff = VSub(sphere->center,rayOrg)
d1 = VDot(diff,rayDir)
if d1 < 0 Then Return false
d2 = VDot(diff,diff) - d1*d1
return (d2<=sphere->radius2)
End Function
' sphere intersection test and calculate t (near)
Function SphereIntersect(ByRef sphere as const tSphere ptr, _
ByRef rayOrg as const tVector, _
ByRef rayDir as const tVector, _
ByRef t as double) as boolean
dim as double d1=any,d2=any,s=any,t0=any,t1=any
var diff = VSub(sphere->center,rayOrg)
d1 = VDot(diff,rayDir)
if d1 < 0 Then Return false
d2 = VDot(diff,diff) - d1*d1
if d2 > sphere->radius2 Then return false
s = sqr(sphere->radius2 - d2)
t0 = d1 - s
t1 = d1 + s
if t0<0 then
t=t1
elseif t1<t0 then
t=t1
else
t=t0
end if
return true
End Function
Function SphereTrace(byref rayOrg as const tVector, _
byref rayDir as const tVector, _
spheres as tSphere ptr ptr, _
nSpheres as integer, _
depth as integer) as tVector
const BIAS = 0.001
dim as tSphere ptr pSphere
var tMin = 2.0^31
for i as integer = 0 to nSpheres-1
var t=0.0
if SphereIntersect(spheres[i], rayOrg, rayDir, t) then
if t < tMin Then tMin = t : pSphere = spheres[i]
end if
next i
' return background color
If pSphere = 0 Then return VSet(2,2,2)
var surfaceColor = VZero
var phit = VAddRay(rayOrg,rayDir,tMin)
var nhit = VNorm(VSub(phit, pSphere->center))
var bInside = false
If VDot(rayDir, nhit) > 0 Then nhit = VNeg(nhit) : bInside = true
If (pSphere->transparency > 0 OrElse pSphere->reflection > 0) Andalso (depth < MAX_RAY_DEPTH) Then
var facingratio = -VDot(raydir, nhit)
var faci = (1. - facingratio):faci*=faci:faci*=faci
var fresneleffect = mix(faci, 1.0, 0.1)
var reflDir = VNorm(VSub(rayDir, VScale(nhit, 2*VDot(raydir, nhit))))
var reflOrg = VAddRay(phit,nhit, BIAS)
var reflection = SphereTrace(reflOrg, reflDir, spheres, nSpheres, depth + 1)
var refraction = VZero
if pSphere->transparency Then
const IndexOfRefraction = 1.1
var eta = IndexOfRefraction
If not bInside then eta = 1.0/IndexOfRefraction
var cosi = -VDot(nhit, raydir)
var k = 1. - eta*eta * (1. - cosi*cosi)
var refrDir = VNorm(VAdd(VScale(raydir, eta), VScale(nhit, eta* cosi - sqr(k))))
var refrOrg = VSub(phit, VScale(nhit, BIAS))
refraction = SphereTrace(refrOrg, refrDir, spheres, nSpheres, depth + 1)
End If
surfaceColor = VMul(VAdd(VScale(reflection, fresneleffect), _
VScale(refraction, (1 - fresneleffect) * pSphere->transparency)), _
pSphere->surfaceColor)
Else
' move ray origine a tiny bit away from hit point in hit normal direction !
var lightOrg = VAddRay(phit, nhit, BIAS)
for i as integer = 0 To nSpheres-2
if spheres[i]->emissionColor.x > .0 Then
var transmission = VSet (1,1,1)
var lightDir = VNorm(VSub(spheres[i]->center, phit))
for j as integer = i+1 to nSpheres-1
if SphereHit(spheres[j],lightOrg,lightDir) Then transmission = VZero : Exit for
next
surfaceColor = VAdd(surfaceColor, _
VMul(VScale(VMul(pSphere->surfaceColor, transmission), max(.0, VDot(nhit,lightDir))), _
spheres[i]->emissionColor))
End If
next
End If
Return VAdd(surfaceColor,pSphere->emissionColor)
End Function
'dim shared as integer nSpheres
Sub Flake(byref spheres as tSphere ptr ptr, _
byref nSpheres as integer, _
nLevel as integer, _
direc as const tDir)
dim as integer lastSphere=nSpheres-1
if nLevel = MAX_FLAKE_LEVEL Then Exit Sub
if direc.x And 1 Then ' right
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x+.radius*1.5, _
.center.y, _
.center.z), _
.radius*.5,VSet(1,.2,.2), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(1,3,3))
End If
If direc.x And 2 Then ' left
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x-.radius*1.5, _
.center.y, _
.center.z), _
.radius*.5, VSet(.2,1,.2), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(2,3,3))
End If
If direc.y And 1 Then ' up
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x, _
.center.y+.radius*1.5, _
.center.z), _
.radius*.5, VSet(.2,.2,1), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(3,1,3))
End If
If direc.y And 2 Then ' down
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x, _
.center.y-.radius*1.5, _
.center.z), _
.radius*.5, VSet(1,1,.2), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(3,2,3))
End If
If direc.z And 1 Then ' near
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x, _
.center.y, _
.center.z+.radius*1.5), _
.radius*.5, VSet(1,.2,1), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(3,3,1))
End If
If direc.z And 2 Then ' far
nSpheres+=1
spheres=reallocate(spheres,nSpheres*sizeof(tSphere ptr))
with *spheres[lastSphere]
spheres[nSpheres-1] = CreateSphere(VSet(.center.x, _
.center.y, _
.center.z-.radius*1.5), _
.radius*.5, VSet(1,1,.2), 1.0, .5, VZero)
end with
Flake (spheres,nSpheres, nLevel+1, DSet(3,3,2))
End If
End Sub
Sub InitSpheres(byref spheres as tSphere ptr ptr, _
byref nSpheres as integer)
nSpheres+=1
spheres = reallocate(spheres,nSpheres*sizeof(tSphere ptr))
spheres[nSpheres-1] = CreateSphere(VSet(0, 0,-30),4, VSet(rnd,rnd,rnd), 1, .5, VZero)
Flake(spheres,nSpheres, 0, DSet(3,3,3))
End Sub
Sub RenderSpheres(byval spheres as tSphere ptr ptr, byval nSpheres as integer)
dim as ulong pixelRed,pixelGreen,pixelBlue
dim as integer iWidth=640,iHeight=400
'screeninfo iWidth,iHeight:iWidth*=0.8:iHeight*=0.8
screenres iWidth,iHeight,32
windowtitle "render " & nSpheres & " spheres"
sleep 1000,1
var aspectratio=iWidth/iHeight
var l=0.0,yy=0.5,xx=0.0
var xStart =-0.5*aspectratio
var xStep = 1.0/iHeight
var yStep =-1.0/iHeight
var rayOrg = VZero
var rayDir = VZero
var imgColor = VZero
var dTime = timer()
for y as integer = 0 to iHeight-1
xx=xStart
for x as integer = 0 to iWidth-1
rayDir = VNorm(VSet(xx, yy, -1.0))
imgColor = SphereTrace(rayOrg, rayDir, spheres, nSpheres, 0)
pixelRed = iif(imgColor.x>1,255UL,culng(imgColor.x*255))
pixelGreen = iif(imgColor.y>1,255UL,culng(imgColor.y*255))
pixelBlue = iif(imgColor.z>1,255UL,culng(imgColor.z*255))
pset (x,y),RGB(pixelRed,pixelGreen,pixelBlue)
xx+=xStep
next
yy+=yStep
next
dTime = timer()-dTime
var iAll = int(dTime)
var title = "result_" & nSpheres & "_spheres_" & iAll & "_seconds.bmp"
windowtitle "saved " & title
bsave title,0
End Sub
'
' main
'
Dim As tSphere ptr ptr spheres
dim as integer nSpheres
InitSpheres(spheres,nSpheres)
RenderSpheres(spheres,nSpheres)
sleep
Re: Windows graphics tutorial
yow!
paul doe - the trickiest pixel quad project for me was winamp "melt" visualizer.
D.J.Peters - thanks for that! another to add to the ol' collection
[update]
paul doe - I'll see if i can compare your aa lines speed using my Alpha256 macro. It usually takes me a long time ;)
[update]
i replaced int() with flr() .. 26fps to 45
paul doe - the trickiest pixel quad project for me was winamp "melt" visualizer.
D.J.Peters - thanks for that! another to add to the ol' collection
[update]
paul doe - I'll see if i can compare your aa lines speed using my Alpha256 macro. It usually takes me a long time ;)
[update]
i replaced int() with flr() .. 26fps to 45
Code: Select all
#include once "fbgfx.bi"
def flr(x) _ '' floor() by Stonemonkey
(((x)*2.0-0.5)shr 1)
Re: Windows graphics tutorial
Wow, that's pretty nice. Doesn't compile on 64-bit, though.dafhi wrote:...
paul doe - the trickiest pixel quad project for me was winamp "melt" visualizer.
Yes, please do =Ddafhi wrote:...
paul doe - I'll see if i can compare your aa lines speed using my Alpha256 macro. It usually takes me a long time ;)
...
I seem to recall the post, but alas, I can't find it. Oh well.
I assume you're talking about your melt visualizer. Changing int() to flr() only yields a marginal speed gain for the wupixels (~2 FPS) ='(dafhi wrote: ...
i replaced int() with flr() .. 26fps to 45
...
Re: Windows graphics tutorial
your demo.
71 fpsFreeBASIC-1.07.1-gcc640-win32 wrote: -gen gcc -O 3
Code: Select all
#include once "fbgfx.bi"
#define def #define
#undef int
def int as Integer
def sng as single
def flr(x) _ '' floor() by Stonemonkey
(((x)*2.0-0.5)shr 1)
#define pixel_r( c ) ( culng( c ) shr 16 and 255 )
#define pixel_g( c ) ( culng( c ) shr 8 and 255 )
#define pixel_b( c ) ( culng( c ) and 255 )
#define pixel_a( c ) ( culng( c ) shr 24 )
dim shared as integer sw = 800, sh = 600
#Macro Alpha256(ret, back, fore, a256) '2020 Jan 27
scope
dim int aaa = (a256)
ret=((_
(fore And &Hff00ff) * aaa + _
(back And &Hff00ff) * ( 256 - aaa ) + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * aaa + _
(back And &H00ff00) * ( 256 - aaa ) + &H008000) And &H00ff0000) Shr 8
end scope
#EndMacro
function pixelAlphaD( byval src as ulongint, byval dst as ulongint, byval opacity2 as ubyte = 255, byval opacity1 as ubyte = 255 ) as ulongint
#if 1
opacity1 = ( ( culng( src shr 32 ) shr 24 ) * opacity1 ) shr 8
opacity2 = ( ( culng( src ) shr 24 ) * opacity2 ) shr 8
#else
opacity1 = ( ( src shr 56 ) * opacity1 ) shr 8
opacity2 = ( ( ( src shr 24 ) and 255 ) * opacity2 ) shr 8
#endif
#if 1
dim as ulong ptr ps = @src
dim as ulong ptr pd = @dst
alpha256( *pd, *pd, *ps, opacity2 )
ps += 1
pd += 1
alpha256( *pd, *pd, *ps, opacity1 )
return dst
#else
return _
( ( ( ( src shr 32 and &hff00ff ) * opacity1 + _
( dst shr 32 and &hff00ff ) * ( 255 - opacity1 ) ) and &hff00ff00 ) shr 8 or ( _
( ( ( src shr 32 ) shr 8 ) and &hff00ff ) * opacity1 + _
( ( ( dst shr 32 ) shr 8 ) and &hff00ff ) * ( 255 - opacity1 ) ) and &hff00ff00 ) shl 32 or _
( ( ( src and &hff00ff ) * opacity2 + _
( dst and &hff00ff ) * ( 255 - opacity2 ) ) and &hff00ff00 ) shr 8 or ( _
( ( src shr 8 ) and &hff00ff ) * opacity2 + _
( ( dst shr 8 ) and &hff00ff ) * ( 255 - opacity2 ) ) and &hff00ff00
#EndIf
end function
const as ulongint c32x2 = 1 + culngint(1) shl 32
const as single i256 = 256 / 255
sub wuPixelD( _
byval wx as single, _
byval wy as single, _
byval wc as ulong, _
byval buffer as ulong ptr = screenPtr() )
if( wx >= 0 andAlso wx + 1 <= sw - 1 andAlso wy >= 0 andAlso wy + 1 <= sh - 1 ) then
dim as integer x = flr( wx )
dim as integer y = flr( wy )
#if 1
dim as ulong ptr pxlt = buffer + sw * y + x
dim as ulong ptr pxlb = buffer + sw * ( y + 1 ) + x
var fx = wx - x
var fy = wy - y
var a = (wc shr 24) * i256
alpha256( *pxlb, *pxlb, wc, a * (1-fx) * fy )
alpha256( pxlb[1], pxlb[1], wc, a * fx * fy )
fy = 1 - fy
alpha256( *pxlt, *pxlt, wc, a * (1-fx) * fy )
alpha256( pxlt[1], pxlt[1], wc, a * fx * fy )
#else
var fx = ( wx - x ) * 255
var fy = ( wy - y ) * 255
dim as ulongint ptr pxlt = cptr( ulongint ptr, buffer + ( sw * y + x ) )
dim as ulongint ptr pxlb = cptr( ulongint ptr, buffer + ( sw * ( y + 1 ) + x ) )
#if 1
*pxlt = pixelAlphaD( wc * c32x2, *pxlt, _
( ( 255 - fx ) * ( 255 - fy ) ) shr 8, ( fx * ( 255 - fy ) ) shr 8 )
*pxlb = pixelAlphaD( wc * c32x2, *pxlb, _
( ( 255 - fx ) * fy ) shr 8, ( fx * fy ) shr 8 )
#else
*pxlt = pixelAlphaD( ( culngint( wc ) shl 32 ) or wc, *pxlt, _
( ( 255 - fx ) * ( 255 - fy ) ) shr 8, ( fx * ( 255 - fy ) ) shr 8 )
*pxlb = pixelAlphaD( ( culngint( wc ) shl 32 ) or wc, *pxlb, _
( ( 255 - fx ) * fy ) shr 8, ( fx * fy ) shr 8 )
#endif
#endif
end if
end sub
sub DDALineD( _
byval x1 as single, _
byval y1 as single, _
byval x2 as single, _
byval y2 as single, _
byval c as ulong, _
byval buffer as ulong ptr = screenPtr() )
dim as single dx, dy
dim as single x_inc, y_inc, x, y
dim as integer steps
dx = x2 - x1
dy = y2 - y1
if( dx = 0 ) then
x1 += 0.25
x2 += 0.25
end if
y1 += 0.25
y2 += 0.25
steps = flr( iif( abs( dx ) > abs( dy ), _
abs( dx ), abs( dy ) ) )
x_inc = dx / steps
y_inc = dy / steps
x = x1
y = y1
for i as integer = 0 to steps
wuPixelD( x, y, c, buffer )
x += x_inc
y += y_inc
next
end sub
type lines
as single x1
as single y1
as single x2
as single y2
as ulong c
end type
screenRes( sw, sh, 32, , fb.gfx_alpha_primitives )
dim as string k
dim as integer numLines = 1000
dim as lines l( 0 to numLines - 1 )
'randomize()
for i as integer = 0 to numLines - 1
with l( i )
.x1 = rnd() * sw
.y1 = rnd() * sh
.x2 = rnd() * sw
.y2 = rnd() * sh
.c = rgba( 255 * rnd(), 255 * rnd(), 255 * rnd(), 255 * rnd() )
end with
next
color( rgba( 0, 0, 0, 255 ), rgba( 255, 255, 255, 255 ) )
dim as double t, sum
dim as uinteger count
dim as boolean antiAlias = true'false
do
k = inkey()
if( k = "1" ) then
sum = 0.0
count = 0
antiAlias = true
end if
if( k = "2" ) then
sum = 0.0
count = 0
antiAlias = false
end if
t = timer()
screenLock()
cls()
for i as integer = 0 to numLines - 1
if( antiAlias = true ) then
DDAlineD( l( i ).x1, l( i ).y1, l( i ).x2, l( i ).y2, l( i ).c )
else
line( l( i ).x1, l( i ).y1 ) - ( l( i ).x2, l( i ).y2 ), l( i ).c
end if
next
screenUnLock()
t = timer() - t
sum += t
count += 1
sleep( 1, 1 )
windowTitle( str( flr( 1 / ( sum / count ) ) ) & iif( antiAlias = true, " FPS (antialiased)", " FPS" ) )
loop until( k = chr( 27 ) )
Re: Windows graphics tutorial
@dafhi
your version gives
32-bit -gen gcc -O 3 165 fps
64-bit -gen gcc -O 3 22 fps
fbc64_gas64.exe 95 fps viewtopic.php?f=8&t=27478
your version gives
32-bit -gen gcc -O 3 165 fps
64-bit -gen gcc -O 3 22 fps
fbc64_gas64.exe 95 fps viewtopic.php?f=8&t=27478
Re: Windows graphics tutorial
Here my results on my new notebook with AMD Ryzen 5 PRO Mobile 3500U CPU.
Code: Select all
-gen gcc -O 3
x86 -> AA = 59 FPS, nonAA = 187 FPS
x64 -> AA = 7 FPS, nonAA = 242 FPS
gcc -Wc -O2
x86 -> AA = 53 FPS, nonAA = 174 FPS
x64 -> AA = 7 FPS, nonAA = 221 FPS
-gen gcc -Wc -Ofast
x86 -> AA = 66 FPS, nonAA = 177 FPS
x64 -> AA = 77 FPS, nonAA = 242 FPS