Windows graphics tutorial

Windows specific questions.
dafhi
Posts: 1367
Joined: Jun 04, 2005 9:51

Re: Windows graphics tutorial

Postby dafhi » Jan 27, 2020 1:52

thanks dodicat!

@hurtado thanks for sharing! the intersection from scratchapixel looks optimized
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Postby hurtado » Jan 27, 2020 10:48

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
dodicat
Posts: 6761
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows graphics tutorial

Postby dodicat » Jan 27, 2020 11:13

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.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Postby hurtado » Jan 27, 2020 11:34

Wow, is lightning fast in 64 bits with -0 3
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Postby hurtado » Jan 27, 2020 13:43

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.
UEZ
Posts: 665
Joined: May 05, 2017 19:59
Location: Germany

Re: Windows graphics tutorial

Postby UEZ » Jan 27, 2020 15:19

I've added some pseudo anti aliasing to the output screen.

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)


Btw, I've removed the save code...
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Postby hurtado » Jan 27, 2020 15:40

@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.
dodicat
Posts: 6761
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows graphics tutorial

Postby dodicat » Jan 27, 2020 19:08

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.

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

 
paul doe
Posts: 1349
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Windows graphics tutorial

Postby paul doe » Jan 27, 2020 20:46

Here's some antialiasing code from waaaay back, fbc 0.24 era (modified enough so that it compiles with the current version):

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

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
D.J.Peters
Posts: 8203
Joined: May 28, 2005 3:28
Contact:

Re: Windows graphics tutorial

Postby D.J.Peters » Jan 28, 2020 0:37

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

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
dafhi
Posts: 1367
Joined: Jun 04, 2005 9:51

Re: Windows graphics tutorial

Postby dafhi » Jan 28, 2020 1:40

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

Code: Select all

#include once "fbgfx.bi"

def flr(x)  _         '' floor() by Stonemonkey
  (((x)*2.0-0.5)shr 1)
paul doe
Posts: 1349
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Windows graphics tutorial

Postby paul doe » Jan 28, 2020 2:32

dafhi wrote:...
paul doe - the trickiest pixel quad project for me was winamp "melt" visualizer.

Wow, that's pretty nice. Doesn't compile on 64-bit, though.

dafhi 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 ;)
...

Yes, please do =D
I seem to recall the post, but alas, I can't find it. Oh well.

dafhi wrote:...
i replaced int() with flr() .. 26fps to 45
...

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
Posts: 1367
Joined: Jun 04, 2005 9:51

Re: Windows graphics tutorial

Postby dafhi » Jan 28, 2020 3:31

your demo.
FreeBASIC-1.07.1-gcc640-win32 wrote: -gen gcc -O 3

71 fps

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 ) )
srvaldez
Posts: 2578
Joined: Sep 25, 2005 21:54

Re: Windows graphics tutorial

Postby srvaldez » Jan 28, 2020 10:34

@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
UEZ
Posts: 665
Joined: May 05, 2017 19:59
Location: Germany

Re: Windows graphics tutorial

Postby UEZ » Jan 28, 2020 12:07

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

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 1 guest