Windows graphics tutorial

[hurtado]

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.

[coderJeff]

Moved to windows forum.

[paul doe]

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)


[hurtado]

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

[UEZ]

I've converted the "Buddhagirl" to FB.

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...

[jj2007]

I've converted the "Buddhagirl" to FB.

Works like a charm (but takes a bit longer on my trusty old i5: 9.6 seconds)

[hurtado]

Great! I will attach it to my site if you don't mind. BTW you may obtain different images changing the initial values properly.

[UEZ]

Great! I will attach it to my site if you don't mind.

No problem, I only ported it to FB - nothing more . ;-)

[hurtado]

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.

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.

[UEZ]

@hurtado: looks very nice. The only thing which is missing is anti aliasing...^^

Thanks for sharing...

[dodicat]

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]

> 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.

[dodicat]

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

[hurtado]

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.

[dodicat]

I tried your spheres in GDI.
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.