DefWindowProcA:
Calls the default window procedure to provide default processing for any window messages that an application does not process. This function ensures that every message is processed. DefWindowProc is called with the same parameters received by the window procedure.
Windows graphics tutorial
Re: Windows graphics tutorial
Charles Petzold's Programming Windows uses "Return (0)" en every case, at least the copy I have.
Re: Windows graphics tutorial
Moved to windows forum.
Re: Windows graphics tutorial
hurtado wrote:Charles Petzold's Programming Windows uses "Return (0)" en every case, at least the copy I have.DefWindowProcA:
Calls the default window procedure to provide default processing for any window messages that an application does not process. This function ensures that every message is processed. DefWindowProc is called with the same parameters received by the window procedure.
Perhaps, but as jj2007 points out, there may be times where Win will come to bite you in the a**, generally when you least expect it XD. Not to mention that the return(0) is just plain superfluous (FreeBasic's select case works differently than C's switch(), as other members pointed out before):
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - SWGPTG - FreeBasic -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2020. http://www.abreojosensamblador.epizy.com -
- 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
' 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 Integer vdxClient, vdyClient
Dim Shared As BITMAPINFOHEADER bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
Dim Shared As Long vdMotion
Sub PintaObjeto ()
Dim As Long x, y, k, cx, cy
For y = 1 To cdYSize
cy = y + vdMotion
For x = 1 To cdXSize
cx = x - vdMotion
cx = (cx xor cy) and 255
cx = (cx or (cx SHL 8)) or 4194304
*(pMainDIB + k) = cx
k+=1
Next
Next
vdMotion += 1
End Sub
Sub Inicio ()
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 Integer bResult
Select Case message
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
SendMessage hWnd, WM_CLOSE, 0, 0
End If
Case WM_CREATE:
hdc = GetDC(hWnd)
'' Creates a dib buffer for PintaObjeto. pMainDIB is a pointer to it
bufDIBDC = CreateCompatibleDC (hdc)
hMainDIB = CreateDIBSection(hdc,Cast(Any Ptr, @bi), DIB_RGB_COLORS, @pMainDIB, NULL, 0)
hOldDIB = SelectObject (bufDIBDC, hMainDIB)
'' Free device context
ReleaseDC (hWnd, hdc)
Inicio ()
SetTimer (hWnd, cdIdTimer, 20, NULL)
Case WM_TIMER :
InvalidateRect (hWnd, NULL, FALSE)
Case WM_SIZE :
vdxClient = lParam And &hFFFF
vdyClient = lParam Shr &h10
Case WM_PAINT :
hdc = BeginPaint(hWnd, @ps)
PintaObjeto ()
bResult = StretchBlt (hdc, 0, 0, vdxClient, vdyClient, bufDIBDC, 0, 0, cdXSize, cdYSize, SRCCOPY)
EndPaint(hWnd, @ps)
Case WM_DESTROY
KillTimer (hWnd, cdIdTimer)
hGDITmp = SelectObject (bufDIBDC, hOldDIB)
bResult = DeleteDC (bufDIBDC)
bResult = DeleteObject (hMainDIB)
PostQuitMessage (0)
End Select
Return DefWindowProc (hWnd, message, wParam, lParam)
End Function
Function WinMain ( hInstance As HINSTANCE, hPrevInstance As HINSTANCE, _
szCmdLine As pSTR, iCmdShow As Integer) As Integer
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 ,"Floor with GetMessage - (c) abreojosensamblador.net", _
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
Ok, I have proposed an structure, anyone could do as they please. Default Window Proc is for those messages that have not been processed in the "message" select case. So, if you call everytime DefWindowProc you could make unnecessary processes. I imagine that in none case could be overlap with what you have done before. Many times I have done a break instead a "return (0)" and didn't get any trouble. Nevertheless it may be possible that in any case (don't know what) be necessary do, besides, this call.
Cheers
Cheers
Re: Windows graphics tutorial
I've converted the "Buddhagirl" to FB.
Takes on my old notebook (i5 4300U) as x64 approx. 4 seconds to generate the image (-gen gcc -Wc -Ofast -s gui).
Very impressiv what math can generate, especially the brain who had the idea...
Code: Select all
'Ported to FB by UEZ build 2020-01-16
'Original C code by Alfonso Víctor Caballero Hurtado
#Include "fbgfx.bi"
Using FB
Type stPaleta
As Ubyte Azul, Verde, Rojo, Alfa
End Type
Dim Shared As stPaleta miPaleta(255)
Dim Shared As UInteger cdNVueltas, nIter, cdXSize, cdYSize, cdXSize2, cdYSize2
cdNVueltas = 510000 : nIter = 10000 : cdXSize = 640 : cdYSize = 400 : cdXSize2 = cdXSize \ 2 : cdYSize2 = cdYSize \ 2
Dim Shared As Single real(nIter), imag(nIter)
Dim Shared As UByte mBuffer(cdXSize * cdYSize)
Dim Shared As Integer Ptr pScr
Function fRand() As Single
Return (Rnd() * 3000 - 2000) / 1000
End Function
Sub CreaFigura()
Dim As Single x, y, im, re, im2, re2
Dim As Integer diverts, iter, xs, ys, pp, it, Off, o, p
x = fRand() : y = fRand()
diverts = 0 : re = 0 : re2 = 0 : im = 0 : im2 = 0
For iter = 0 To nIter
im = 2 * re * im + x
re = re2 - im2 + y
real(iter) = re : imag(iter) = im
im2 = im * im : re2 = re * re
If (re2 + im2 > 4) Then
diverts = 1
Exit For
End If
Next
If diverts <> 0 Then
For it = 0 To iter
xs = Abs(imag(it) * 150) + cdXSize2
ys = (real(it) * 150 + cdYSize2 + 40)
If xs >= 0 And xs < cdXSize And ys >= 0 And ys <= cdYSize Then
o = (ys Shl 9) + (ys Shl 7)
Off = o + xs
pp = mBuffer(Off)
If pp < 255 And pp > -1 Then
p = pp + 1
mBuffer(Off) = p
mBuffer(o - xs) = p
End If
End If
Next
End If
End Sub
Sub VuelcaBuf()
Dim As Ubyte p
Dim As Ulong c
Dim As Integer i
Screenlock
For i = 0 To cdXSize * cdYSize
p = mBuffer(i)
c = miPaleta(p).Azul Or miPaleta(p).Verde Shl 8 Or miPaleta(p).Rojo Shl 16
pScr = Screenptr + i * 4
*pScr = c
Next
Screenunlock
End Sub
Screenres(cdXSize, cdYSize, 32, 1, GFX_ALPHA_PRIMITIVES or GFX_HIGH_PRIORITY or GFX_NO_SWITCH)
? "Please wait a few seconds to generate the image..."
Randomize , 2
Dim As Single fTimer = Timer
For i As Ushort = 0 To 255
miPaleta(i).Rojo = 0
miPaleta(i).Verde = i
miPaleta(i).Azul = i
miPaleta(i).Alfa = 0
Next
For j As Integer = 0 To cdNVueltas - 1
CreaFigura()
Next
VuelcaBuf()
Windowtitle(Timer - fTimer & " seconds")
Sleep
Takes on my old notebook (i5 4300U) as x64 approx. 4 seconds to generate the image (-gen gcc -Wc -Ofast -s gui).
Very impressiv what math can generate, especially the brain who had the idea...
Last edited by UEZ on Jan 15, 2020 23:15, edited 3 times in total.
Re: Windows graphics tutorial
Works like a charm (but takes a bit longer on my trusty old i5: 9.6 seconds)UEZ wrote:I've converted the "Buddhagirl" to FB.
Re: Windows graphics tutorial
Great! I will attach it to my site if you don't mind. BTW you may obtain different images changing the initial values properly.
Re: Windows graphics tutorial
hurtado wrote:Great! I will attach it to my site if you don't mind.
No problem, I only ported it to FB - nothing more . ;-)
Re: Windows graphics tutorial
Hello, my basic stayed in the quick basic 4.5, so I wanted to practice some freebasic and I made a sphere flake on my way, without using OOP (in a hurry, sorry). The program takes a little while to get up, but fortunately you can see its development in a ppm image file that it generates in the same folder. 45 kb in size when compiled.
Since it is not good to program without music, there goes one.

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 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)
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 / 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
*(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)
ReleaseDC (hWnd, hdc)' // Libera device context
Inicio ()
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, 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 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 - (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)
Since it is not good to program without music, there goes one.

Re: Windows graphics tutorial
@hurtado: looks very nice. The only thing which is missing is anti aliasing...^^
Thanks for sharing...
Thanks for sharing...
Re: Windows graphics tutorial
Cairo is desperately slow to replace direct pixel drawing with anti aliased lines.
hurtado.
I have no complaints whatsoever about your graphics, in fact they are very nice, but that music must be hard to play, for it is hard to listen to.
hurtado.
I have no complaints whatsoever about your graphics, in fact they are very nice, but that music must be hard to play, for it is hard to listen to.
Re: Windows graphics tutorial
> that music must be hard to play, for it is hard to listen to
Don't understand, do you mean that the code is hard to read? I lost in some expresions in English
I think that D.J.Peters did something similar here:
viewtopic.php?t=12973
D.J.Peters used OOP and I didn't. The original code comes from
https://www.scratchapixel.com/
I referenced this here
The rest is just a recursive procedure to create the spheres, their positions and colors.
Don't understand, do you mean that the code is hard to read? I lost in some expresions in English
I think that D.J.Peters did something similar here:
viewtopic.php?t=12973
D.J.Peters used OOP and I didn't. The original code comes from
https://www.scratchapixel.com/
I referenced this here
The rest is just a recursive procedure to create the spheres, their positions and colors.
Re: Windows graphics tutorial
Not the code of course, I translated your template thing from tiny c to fb. (Not a difficult task I know)
But the music link (YouTube).
Maybe I am too old for that fast music.
Anything you can't whistle is not music to my ear.
I prefer the sixties stuff.
https://www.freebasic.net/forum/viewtopic.php?f=3&t=16207&p=265564&hilit=https#p265564
But the music link (YouTube).
Maybe I am too old for that fast music.
Anything you can't whistle is not music to my ear.
I prefer the sixties stuff.
https://www.freebasic.net/forum/viewtopic.php?f=3&t=16207&p=265564&hilit=https#p265564
Re: Windows graphics tutorial
Ah, that's good music. I like many styles though I'm more on techno. I'm always open to hear new music :) and that link has good ones too.
This link is from a piece of a Milk inc concert. I never heard such a beautiful way to play a trumpet.
This link is from a piece of a Milk inc concert. I never heard such a beautiful way to play a trumpet.
Re: Windows graphics tutorial
I tried your spheres in GDI.
better to use -O3 optimisation.
edit:made the window fixed size with blue frame.
It might have two runs at it, the going gets tough across the row of spheres in the middle.
better to use -O3 optimisation.
edit:made the window fixed size with blue frame.
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
End winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)
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))
'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_DESTROY:
'screen 19,32
' bsave("spheres.bmp",hwnd)
PostQuitMessage(0)
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
SendMessage hWnd, WM_CLOSE, 0, 0
End If
End Select
Return DefWindowProcW(hwnd, msg, wParam, lParam)
End Function
It might have two runs at it, the going gets tough across the row of spheres in the middle.
Last edited by dodicat on Jan 27, 2020 11:09, edited 1 time in total.
Who is online
Users browsing this forum: No registered users and 5 guests