Windows graphics tutorial

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

Re: Windows graphics tutorial

Post by dafhi »

mr. doe your "wulines" look very good. i might have to use them

42 fps on my lines

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)


'#include "inc/aaline.bas"
' ---- aaline.bas

'#include once "gmath.bas"
/' ------- gmath.bas 2017 Dec 7 - by dafhi -------- '/

#Ifndef flr '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#Define flr(x) (((x)*2.0-0.5)shr 1)
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
  #EndIf

#ifndef pi
const   TwoPi = 8*atn(1)
const   Pi = 4*atn(1)
const   piBy2 = 2*atn(1)
const   iPi = 1/Pi
const   piBy4 = atn(1)
#EndIf


'#include once "imagevars.bas"
/' ------- imagevars 2018 Jan 9 - by dafhi -------- '/

Union UnionARGB
  As Ulong col:  Type: As UByte  B,G,R,A:  End Type
End Union

Type sng2D
    As Single                     x,y
End Type

type myint as integer

type imagevars          '' 2018 Jan 9 - by dafhi
  '1. quick reference for ScreenInfo & ImageInfo
  '2. encapsulate standard metrics
  '3. convenient additional vars, subs and functions
  as myint              w,h,bpp,bypp,pitch,rate,  wm, hm, pitchBy, num_pages, flags 'helpers
  as any ptr            im, pixels
  as ulong ptr          p32
  as string             driver_name
  declare sub           get_info(im as any ptr=0)
  as single             wh, hh, diagonal
  declare sub           screen_init(w as myint=0, h as myint=0, bpp as myint=32, npages as myint=1, flags as myint=0)
  declare sub           create(w as myint=0, h as myint=0, col as ulong=&HFF000000)
  declare               destructor
 private:
  declare sub           destroy
end type

Destructor.imagevars:  destroy
End Destructor

Sub imagevars.Destroy():  If ImageInfo(im) = 0 Then ImageDestroy im: im = 0: endif:  End Sub

sub imagevars.get_info(im as any ptr)
  if im=0 then:  pixels=screenptr
    ScreenInfo w,h, bpp,, pitch, rate, driver_name:  bypp=bpp\8 '2018 Jan 9
  elseif Imageinfo(im)=0 then
    ImageInfo im, w, h, bypp, pitch, pixels
    bpp = bypp * 8:  this.im = im
  endif:  pitchBy=pitch\bypp
  wm=w-1: wh=w/2:  diagonal = sqr(w*w+h*h)
  hm=h-1: hh=h/2:  p32=pixels
end sub

sub imagevars.create(w as myint, h as myint, col as ulong)
  destroy:  get_info imagecreate(w,h,col)
End Sub

Sub imagevars.screen_init(w As myint, h As myint, _bpp as myint, _pages as myint, _flags as myint)
  Destroy:  ScreenRes w,h,_bpp,_pages,_flags: get_info
  num_pages=_pages: flags=_flags:  if num_pages > 1 then screenset 0,1
End sub


#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

'
' -------- imagevars


/' -- Anti-aliased lines - 2018 Jan 10 - by dafhi

  ' - usage -----------------------
  dim as imagevars      buf
  buf.screen_init 800,600

  aaline.render_target @buf
  screenlock
    line buf.im, (0,0)-(buf.wm, buf.hm), rgb(180,175,160), bf
    aaline.wid = 50
    aaline.draw 100,100,400,300, rgb(255,255,255)
  screenunlock:  sleep
  ' --------------------------------
 
  I will update this project as time permits.
  http://www.freebasic.net/forum/viewtopic.php?f=8&t=20719
'/

namespace AaLine
 
  dim As single               x0,y0,x1,y1,wid=1,endcap
  dim As ulong                col = -1
 
  dim As imagevars ptr        im
 
  '' private
  Type ScanIntercepts
    as double                 ab,cd,bc,da
  End Type

  dim As single               sx0,sy0,sx1,sy1,ax,bx,cx,dx,ay,by,cy,dy
  dim As single               ayi,byi,cyi,dyi
  dim As single               dxL,bxR,axL,axR,cxL,cxR
  dim As ulong ptr            cBL,cBR,cTL,cTR  'window pixels: bottom-left, ..
  dim As integer              w,wm,hm,pitchx,pitchy,wmprev,hmprev
  dim As single               abslope_small, abslope_large
  dim As single               slen,swid, sdx,sdy, angle, scosa,ssina, cenx,ceny
  dim As Single               lenBy2, smallBy2,largeBy2
  dim As single               da0,da1,ab0,ab1,bc0,bc1,cd0,cd1
  dim As single               cenabx, cenaby, cencdx, cencdy
  dim As integer              yflipped, xyflipped
  dim As ScanIntercepts       sc0x, sc1x, sc0y, sc1y
  dim As single               a(Any), _alpha
 
  Sub render_target(byref p as imagevars ptr): im = p '2017 Sep 10
  end sub
 
  sub init
    wm=im->wm:  hm=im->hm
    if wm<>wmprev or hm<>hmprev then
      dim as integer ubmax = wm:  if hm > ubmax then ubmax = hm
      if ubmax > ubound(a) then ReDim a(ubmax)
      wmprev=wm: hmprev=hm
    end If
    pitchx=1: pitchy=im->pitchBy
    cBL=im->pixels: cTL=cBL+hm*pitchy
    cBR=CBL+wm: cTR=cTL+wm: yflipped=0: xyflipped=0: _alpha=256*(col shr 24)/255
  End sub
 
  Sub yflip
    pitchy=-pitchy: yflipped=-1
    swap cBL,cTL: swap cBR,cTR
    ceny=hm+1-ceny: ssina=-ssina
  end sub
 
  sub xyflip
    swap cTL,cBR: xyflipped = -1
    swap wm,hm: swap pitchx,pitchy
    swap cenx,ceny: swap scosa,ssina
  end sub
 
  sub re_center
    lenBy2=slen/2
    scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
    var dx0=im->wh-x0, dy0=im->hh-y0 ''
    var dx1=im->wh-x1, dy1=im->hh-y1 ''
    const c = .5
    if dx0*dx0+dy0*dy0 < dx1*dx1+dy1*dy1 then 'point 0 closest to center
      cenx=x0+scosa+c ''
      ceny=y0+ssina+c ''
    else
      cenx=x1-scosa+c ''
      ceny=y1-ssina+c ''
    endif
  end sub
 
  sub handle_infinity
    sdx=x1-x0: sdy=y1-y0 ''
    slen=sqr(sdx*sdx+sdy*sdy)
    if slen>1e9 then:  slen=1e9
      const sincos=1e9*sqr(1/2)
      sdx=sincos*sgn(sdx)
      sdy=sincos*sgn(sdy)
    endif
    if sdx=0 then
      if sdy<0 then: angle= -pi/2
      else: angle=pi/2: endif
    else: angle=atn(sdy/sdx):  if sdx<0 then angle+=pi
    endif
    re_center
    swid=wid
    if swid>1e9 then swid=1e9
    slen+=endcap*swid
    if slen < wid then
      angle+=pi/2:  swap swid,slen
    end if: lenBy2=slen/2

    '' fix to make compiler happy
    if angle=0 or abs(angle-pi)<0.00001 then angle += 0.0001
   
    scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
  End sub
 
  Sub octant
    if scosa<0 then scosa=-scosa: ssina=-ssina
    if ssina<0 then yflip
    if ssina>scosa then xyflip
    w=wm+1
    ax=cenx-scosa: bx=cenx+scosa  '2017 June 4
    ay=ceny-ssina: by=ceny+ssina  '2017 June 4
  End sub
 
  sub corners
    abslope_small=ssina/scosa: smallBy2=abslope_small/2
    abslope_large=scosa/ssina: largeBy2=abslope_large/2
    dim as single widByLen = swid/slen
    dim as single hdxwid = ssina*widByLen, hdywid = scosa*widByLen
    cx=bx-hdxwid: dx=ax-hdxwid: ax=ax+hdxwid: bx=bx+hdxwid  '2017 June 4
    cy=by+hdywid: dy=ay+hdywid: ay=ay-hdywid: by=by-hdywid  '2017 June 4
    ayi=flr(ay): byi=flr(by): cyi=flr(cy): dyi=flr(dy)
    dxL=flr(dx): axL=flr(ax): axR=flr(ax)
    bxR=flr(bx): cxL=flr(cx): cxR=flr(cx)
    If dxL<0 Then: dxL=0: EndIf: If bxR>wm then: bxR=wm: endif
    If axL<0 Then: axL=0: EndIf: If axR>wm Then: axR=wm: EndIf
    If cxL<0 Then: cxL=0: EndIf: If cxR>wm Then: cxR=wm: EndIf
  End Sub
 
  Function xbound(x As Single) As Integer
    return x>=0 And x<w
  End Function
 
  Function ybound(yLo As single,yHi As single,y As single) As Integer
    return y>=yLo And y<= yHi
  End Function
 
  Function areasubt(ceptL As Single,ceptR As Single,edgeL As Single) As Single
    Dim As Single len_tri
    If ceptL<edgeL Then                 '  ceptL
      len_tri=ceptR-edgeL               ' -+-----+
      Return len_tri*len_tri*largeBy2   '   \####|
    Else: Dim As Integer  edgep=edgeL+1 '    \###|
      If ceptR<edgep Then               '     \##|
        Return ceptR-edgeL-smallBy2     ' -----+-+
      Else                              '  ceptR
        len_tri=edgep-ceptL           
      Return 1-len_tri*len_tri*largeby2: EndIf
    EndIf
  End Function
 
  Sub subt_ab(x0 As single, x1 As single,y As integer)
      sc1y.ab=cenaby+(x0-cenabx)*abslope_small
      For x As Single=x0 To x1
        sc0y.ab=sc1y.ab
        sc1y.ab+=abslope_small
        a(x)-=areasubt(sc0y.ab,sc1y.ab,y)
      Next
  end Sub
  Sub subt_cd(x0 As single, x1 As single,y As Integer)
      sc1y.cd=cencdy+(x0-cencdx)*abslope_small
      For x As Single=x0 To x1
        sc0y.cd=sc1y.cd
        sc1y.cd+=abslope_small
        a(x)-=1-areasubt(sc0y.cd,sc1y.cd,y)
      Next
  end sub
 
  sub subt_da(x0 As single, x1 As single)
      For x As Integer=x0 To x1
        a(x)-=areasubt(sc1x.da,sc0x.da,x)
      Next
  end sub
  Sub subt_bc(x0 As single, x1 As single)
      For x As single=x0 To x1
        a(x)-=1-areasubt(sc1x.bc,sc0x.bc,x)
      Next
  End Sub
 
  Function area_oversubtracted(vx As Single,vy As Single,ix As integer,iy As Integer) As single
    vx=Abs(vx-ix)
    vy=Abs(vy-iy)
    var ceptYleft=vy-vx*abslope_small
    Dim As Single areaL
    ' area "low and left" of vertex
    If ceptYleft<0 Then      'triangle
      areaL=vy*vy*largeBy2
    Else                      'trapezoid
      areaL=vx*(ceptYleft+vy)/2
    End If
    ' area "low and right" of vertex
    Var ceptXBottom=vx+vy*abslope_small
    Var ixp=ix+1
    If ceptXBottom<=1 Then    'triangle
      Return areaL + vy*vy*smallBy2
    Else                      'trapezoid
      Var vx1=1-vx
      Return areaL+vx1*(vy-vx1*largeBy2)
    EndIf
  End Function
 
  Sub scanwrite(xL0 As integer, xR1 as integer, y As integer)
    dim as ulong ptr  p=@cBL[xL0*pitchx+y*pitchY]
    for x as integer=xL0 to xR1
      dim as ulong a256 = _alpha * a(x)
      *p=((_
      (col And &Hff00ff) * a256 + _
      (*p And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
      (col And &H00ff00) * a256 + _
      (*p And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
      p+=pitchx
    next
  End Sub
 
  Function int_lo(in As Single,clip As Single) As Single
    If in<clip Then: Return flr(clip): Else: Return flr(in): EndIf
  End Function
 
  Function int_hi(in As Single,clip As Single) As Single
    If in>clip Then: Return flr(clip): Else: Return flr(in): EndIf
  End Function
 
  sub scanlines_abcd(y0 as integer, y1 as single)
    if y0<0 then y0=0
    if y1>hm then y1=hm
    sc0x.cd=sc1x.cd:  sc1x.cd=cencdx+(y0-cencdy)*abslope_large
    sc0x.bc=sc1x.bc:  sc1x.bc=bx-(y0-by)*abslope_small
    for y As Integer=y0 to y1
      sc0x=sc1x
      sc1x.ab+=abslope_large
      sc1x.cd+=abslope_large
      sc1x.da-=abslope_small
      sc1x.bc-=abslope_small
      Dim As Integer  inda=ybound(ayi,dyi,y)
      Dim As Integer  inab=ybound(ayi,byi,y)
      Dim As Integer  incd=ybound(dyi,cyi,y)
      Dim As Integer  inbc=ybound(byi,cyi,y)
      Dim As single  xL1=-1,xL0=wm+1
      If inda Then
        da0=int_lo(sc1x.da,dxL): If da0<xL0 Then xL0=da0
        da1=int_hi(sc0x.da,axR): If da1>xL1 Then xL1=da1
      EndIf
      If incd Then
        cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
        cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
      EndIf
      Dim As single  xR1=-1,xR0=wm+1
      If inab Then
        ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
        ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
      EndIf
      If inbc Then
        bc0=int_lo(sc1x.bc,cxL): If bc0<xR0 Then xR0=bc0
        bc1=int_hi(sc0x.bc,bxR): If bc1>xR1 Then xR1=bc1
      EndIf
      For x as integer=xL0 to xR1
        a(x)=1
      Next
      If inda Then subt_da da0,da1
      If inab Then subt_ab ab0,ab1,y
      If inbc Then subt_bc bc0,bc1
      If incd Then subt_cd cd0,cd1,y
      If y=ayi And xbound(ax) Then
        a(axL)+=area_oversubtracted(ax,ay,axL,ayi)
      EndIf
      If y=byi And xbound(bx) Then
        a(bxR)+=area_oversubtracted(by,bx,byi,bxR+1)
      EndIf
      If y=cyi And xbound(cx) Then
        a(cxR)+=area_oversubtracted(cx,cy,cxR+1,cyi+1)
      EndIf
      If y=dyi And xbound(dx) Then
        a(dxL)+=area_oversubtracted(dy,dx,dyi+1,dxL)
      EndIf
      scanwrite xL0,xR1,y
    next
  end sub
 
  sub scanlines_adb(y0 as integer, y1 as single)
    if y0<0 then y0=0
    if y1>hm then y1=hm
    if ax < w-cx then 'bc closest
      cenabx=bx: cenaby=by
      cencdx=cx: cencdy=cy
    else
      cenabx=ax: cenaby=ay
      cencdx=dx: cencdy=dy
    end if
    sc1x.da=ax-(y0-ay)*abslope_small
    sc1x.ab=cenabx+(y0-cenaby)*abslope_large
    for y As Integer=y0 to y1
      sc0x.da=sc1x.da: sc1x.da-=abslope_small
      sc0x.ab=sc1x.ab: sc1x.ab+=abslope_large
      Dim As single   xL1=-1,xL0=wm+1
      da0=int_lo(sc1x.da,dxL): If da0<xL0 Then xL0=da0
      da1=int_hi(sc0x.da,axR): If da1>xL1 Then xL1=da1
      Dim As single   xR1=-1,xR0=wm+1
      ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
      ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
      For x as integer=xL0 to xR1
        a(x)=1
      Next
      subt_da da0,da1
      subt_ab ab0,ab1,y
      If y=ayi And xbound(ax) Then
        a(axL)+=area_oversubtracted(ax,ay,axL,ayi)
      EndIf
      scanwrite xL0,xR1,y
    next
  end sub
 
  sub scanlines_cdb(y0 as integer, y1 as integer)
    if y0<0 then y0=0
    if y1>hm then y1=hm
    for y As Integer=y0 to y1
      sc0x.cd=sc1x.cd:  sc1x.cd+=abslope_large
      sc0x.bc=sc1x.bc:  sc1x.bc-=abslope_small
      Dim As single  xL1=-1,xL0=wm+1
      cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
      cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
      Dim As single  xR1=-1,xR0=wm+1
      bc0=int_lo(sc1x.bc,cxL): If bc0<xR0 Then xR0=bc0
      bc1=int_hi(sc0x.bc,bxR): If bc1>xR1 Then xR1=bc1
      For x as integer=xL0 to xR1
        a(x)=1
      Next
      subt_bc bc0,bc1
      subt_cd cd0,cd1,y
      If y=cyi And xbound(cx) Then
        a(cxR)+=area_oversubtracted(cx,cy,cxR+1,cyi+1)
      EndIf
      scanwrite xL0,xR1,y
    next
  end sub
 
  sub scanlines_db(y0 as integer, y1 as single)
    if y0<0 then y0=0
    if y1>hm then y1=hm
    for y As Integer=y0 to y1
      sc0x.ab=sc1x.ab:  sc1x.ab+=abslope_large
      sc0x.cd=sc1x.cd:  sc1x.cd+=abslope_large
      Dim As single   xL1=-1,xL0=wm+1
      cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
      cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
      Dim As single   xR1=-1,xR0=wm+1
      ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
      ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
      For x as integer=xL0 to xR1
        a(x)=1
      Next
      subt_ab ab0,ab1,y
      subt_cd cd0,cd1,y
      scanwrite xL0,xR1,y
    next
  end sub
 
  Sub calc
    handle_infinity
    if slen <= 0 then exit sub
    if im=0 or im->bpp <> 32 then
      static as integer show_msg=1
      if show_msg then
        if im->im=0 then: ? "AaLine:  invalid render target"
        else: ? "AaLine:  target must be 32bpp"
        end if: sleep 1000: show_msg=0
      endif
    end if
    init
    octant
    corners
    if dyi<=byi then
      scanlines_adb ayi,dyi-1
      if dyi<byi-1 then
        scanlines_abcd dyi, dyi
        scanlines_db dyi+1, byi-1
        scanlines_abcd byi, byi
      else
        scanlines_abcd dyi, byi
      end if
      scanlines_cdb byi+1,cyi
    else
      scanlines_adb ayi,byi-1
      scanlines_abcd byi, dyi
      scanlines_cdb dyi+1,cyi
    end if
  End sub
 
  sub linedraw(_x0 as single,_y0 as single,_x1 as single,_y1 as single,_col as ulong)
    x0=_x0: x1=_x1: y0=_y0: y1=_y1: col=_col: calc
  end sub
 
  sub draw_by_vec(x as single, y as single, slen as single, angle as single,_col as ulong)
    slen /= 2: dim as single sina = slen*sin(angle), cosa = sLen*cos(angle)
    x0=x-cosa: x1=x+cosa: y0=y-sina: y1=y+sina: col=_col: calc
  end sub
 
  sub drawme
    calc
  End Sub
end namespace ' ---- aaline


#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
 
  #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 0
   
    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 x0
  as single y0
  as ulong col
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 )

dim as imagevars buf
buf.get_info

using aaline
render_target @buf

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
   
    .x0 = rnd() * sw
    .y0 = rnd() * sh
    .col = 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
        wid = 1
        lineDraw l( i ).x1, l( i ).y1, l( i ).x0, l( i ).y0, l( i ).col
        'DDAlineD( l( i ).x1, l( i ).y1, l( i ).x0, l( i ).y0, l( i ).col )
        
      else
        line( l( i ).x1, l( i ).y1 ) - ( l( i ).x0, l( i ).y0 ), l( i ).col
      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: 3373
Joined: Sep 25, 2005 21:54

Re: Windows graphics tutorial

Post by srvaldez »

I found that the version of gcc makes a difference in the timing, gcc-5.2 produces faster times, was using gcc-6.4
the times are after letting it run for about 30 second to let the timings stabalize

Code: Select all

32-bit gcc-5.2 -gen gcc -O 3    dafhi's 157 fps | paul doe's 218 fps
32-bit gcc-5.2 -gen gcc -O fast dafhi's 161 fps | paul doe's 192 fps

64-bit gcc-5.2 -gen gcc -O 3    dafhi's 23  fps | paul doe's 204 fps
64-bit gcc-5.2 -gen gcc -O fast dafhi's 153 fps | paul doe's 220 fps
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: Windows graphics tutorial

Post by dafhi »

DJP when no aa i see 1.87 sec

Code: Select all

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 100,1
  var aspectratio=iWidth/iHeight
  
  var l=0.0,xx=0.0,yy=0.5       ''
  
  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()
  
  var num_aa = 5              '' independent
  var iaa = 255.499 / num_aa  '' dependent
  
  for y as integer = 0 to iHeight-1
    xx=xStart
    for x as integer = 0 to iWidth-1
      dim as single pixelRed,pixelGreen,pixelBlue
      for aa as integer = 1 to num_aa
        rayDir = VNorm(VSet(xx + (rnd - .5)*xStep, yy + (rnd - .5)*yStep, -1.0))
        imgColor = SphereTrace(rayOrg, rayDir, spheres, nSpheres, 0)
        pixelred += imgColor.x'iif(imgColor.x
        pixelGreen += imgcolor.y'iif(imgColor.y>1,255UL,culng(imgColor.y*255))
        pixelBlue  += imgcolor.z'iif(imgColor.z>1,255UL,culng(imgColor.z*255))
      next
      #define clamp(c) iaa * iif( c < 0, 0, iif(c > num_aa, num_aa, c) )
      pset (x,y), RGB( clamp(pixelRed), clamp(pixelGreen), clamp(pixelBlue) )
      xx+=xStep       
    next
    yy+=yStep
  next
  dTime = timer()-dTime
  var iAll = int(dTime)
  var title = "result_" & nSpheres & "_spheres_" & iAll & "_seconds.bmp"
  windowtitle str(dTime)'"saved " & title
  'bsave title,0
End Sub
hurtado antialias

Code: Select all

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)
  var i = 0
  
  var num_aa = 5              '' independent
  var iaa = 255.499 / num_aa  '' dependent
 
  var ixx = angle * aspectratio
  var iyy = angle
  
  for y = 0 to cdYSize-1
    'yy = (1.0 - 2.0 * ((CDbl(y) + 0.5) * invHeight)) * iyy'angle
    for x = 0 to cdXSize-1
      var r = 0f, g = 0f, b = 0f
      for aa as integer = 1 to num_aa
        xx = (2.0 * ((x + rnd) * invWidth) - 1.0) * ixx
        yy = (1.0 - 2.0 * ((y + rnd) * invHeight)) * iyy
        '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 += image.x'min(1.0, image.x) * 255
        g += image.y'min(1.0, image.y) * 255
        b += image.z'min(1.0, image.z) * 255
      next 
      #define clamp(c) iaa * iif( c<0,0, iif( c>num_aa,num_aa,c) )
     SetPixel hdc,x,y, BGR( clamp(r), clamp(g), clamp(b) )
             
      'i += 1
    next x
  next y
 
End Sub
thanks for the info, sr_valdez! (quite the cpu you are rockin!)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows graphics tutorial

Post by dodicat »

Here are cairo lines.

Code: Select all

#include once "cairo/cairo.bi" 

#define _rd_ Cast(Ubyte Ptr,@colour)[2]/255
#define _gr_ Cast(Ubyte Ptr,@colour)[1]/255
#define _bl_ Cast(Ubyte Ptr,@colour)[0]/255
#define _al_ Cast(Ubyte Ptr,@colour)[3]/255

Sub Cline(surf As cairo_t Ptr,x1 As Long,y1 As Long,x2 As Long,y2 As Long,thickness As Single,colour As Ulong,CapOption As boolean)
    cairo_set_line_width(surf, (thickness))
    cairo_set_source_rgba surf,_rd_,_gr_,_bl_,_al_
    cairo_move_to(surf, (x1), (y1))
    cairo_line_to(surf,(x2),(y2))
    If Capoption Then 
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_ROUND)
    Else
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_SQUARE)
    End If
    cairo_stroke(surf)
End Sub

Function setscreen(xres As Integer,yres As Integer)  As cairo_t Ptr
    Screenres xres,yres,32,,64
    Var surface = cairo_image_surface_create_for_data(Screenptr(), CAIRO_FORMAT_ARGB32,xres,yres,xres*4)
    Static As cairo_t Ptr res
    res= cairo_create(surface)
    Return res
End Function

type lines
  as single x1
  as single y1
  as single x2
  as single y2
  as ulong c
end type
dim as integer numLines = 1000
dim as lines l( 1 to numLines )

randomize()

for i as integer = 1 to numLines 
  with l( i )
    .x1 = rnd() * 800
    .y1 = rnd() * 600
   
    .x2 = rnd() * 800
    .y2 = rnd() * 600
    .c = rgba( 255 * rnd(), 255 * rnd(), 255 * rnd(), 255 * rnd() )
  end with
next


Dim   As cairo_t Ptr ps
ps= setscreen(800,600)
Color ,Rgb(255,255,255)
Dim As String k
Dim As boolean antiAlias
Dim As Double t, sum
Dim As Uinteger count


#define flr(x)  (((x)*2.0-0.5)shr 1)         '' floor() by Stonemonkey

Do
  '  Randomize 1
    k = Inkey()
    
    If( k = "1" ) Then sum=0:count=0: antiAlias = true
    
    If( k = "2" ) Then sum=0:count=0:antiAlias = false
    t=Timer
    Screenlock
    Cls
    For n As Long=1 To numlines
        If antialias Then 
            cline(ps,l(n).x1,l(n).y1,l(n).x2,l(n).y2,1,l(n).c,0)
        Else 
            line(l(n).x1,l(n).y1)-(l(n).x2,l(n).y2),l(n).c
        end if
    Next
    Screenunlock
    t=Timer-t
    sum += t
    count += 1
    Sleep 1
    Windowtitle( Str( flr( 1 / ( sum / count ) ) ) & Iif( antiAlias = true, " FPS (antialiased)", " FPS" ) )
Loop Until k=Chr(27)

Sleep 
Same setup as previously, framerate e.t.c.
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Windows graphics tutorial

Post by srvaldez »

thanks dodicat, over 300 fps here
in case somebody is missing the cairo dll for Windows, here's an all-in-one dll https://github.com/preshing/cairo-windows/releases
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Post by hurtado »

Hello. If we want painting this kind of Sphere flake, I have given a new twist. You can call me a cheater if you want. Here three versions:

- The first one, the original. According to my proofs, around 20 seconds to execute. Executable of 38 kb.
- The second one, with traps, although it can be sharpened even more. 1 second to execute. Executable of 38 kb.
- The third one, as the second with macros. 0.51 seconds. Executable of 45 kb.

All of them resizables. One question: why is always a command window oppened when a fb is executed?

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         400 '//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, c as ULong
  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 fymy as integer, yxsz as integer, fymyxsz as integer, xyt as integer, xxsz as integer

  xyt = cdXSize*cdYSize
  invWidth = 1.0 / cdXSize : invHeight = 1.0 / cdYSize
  fov = 40.: aspectratio = cdXSize * invHeight
  angle = tan(0.5 * fov * cdGrad2Rad)
  for y = 0 to cdYSize/2
    yy = (1.0 - 2.0 * ((CDbl(y) + 0.5) * invHeight)) * angle
    fymy = cdYSize-y : yxsz = y*cdXSize : fymyxsz = fymy * cdXSize
    for x = cdYSize-1-y to cdXSize-1
      xxsz = x*cdXSize
      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)
      *(pMainDIB+yxsz+x) = c
      *(pMainDIB+fymyxsz+x) = c
      *(pMainDIB+yxsz+cdXSize-x) = c
      *(pMainDIB+fymyxsz+cdXSize-x) = c
      *(pMainDIB+xxsz+y) = c
      *(pMainDIB+xyt-xxsz+y) = c
      *(pMainDIB+xxsz+cdXSize-y) = c
      *(pMainDIB+xyt-xxsz+cdXSize-y) = c
    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
End Sub

Sub PintaObjeto ()
End Sub

Sub Inicio ()
  dim t as double = timer()
  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)
  print STR(timer()-t) + " seconds"
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)

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         400 '//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 () 
  dim t as double = timer()
  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)
  print STR(timer()-t) + " seconds"
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)

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         400 '//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

#define fnCreaDir(a,b,c)    type<stDir>(culng(a),culng(b),culng(c))
#define fnCreaVector(a,b,c) type<stVector>((a),(b),(c))
#define fnCreaVectorZ       type<stVector>(0,0,0)
#define fnVectSuma(a,b)     type<stVector>(a.x+b.x,a.y+b.y,a.z+b.z)
#define fnVectResta(a,b)    type<stVector>(a.x-b.x,a.y-b.y,a.z-b.z)
#define fnVectDot(a,b)      (a.x*b.x + a.y*b.y + a.z*b.z)
#define fnVectCross(a,b)    type<stVector>(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 fnVectMult(a,b)     type<stVector>(a.x*b.x,a.y*b.y,a.z*b.z)
#define fnVectEscala(a,b)   type<stVector>(a.x*(b),a.y*(b),a.z*(b))
#define fnVectOpuesto(a)    type<stVector>(-a.x,-a.y,-a.z)

' 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 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 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 fymy as integer, yxsz as integer, fymyxsz as integer, xyt as integer, xxsz as integer

  xyt = cdXSize*cdYSize
  invWidth = 1.0 / cdXSize : invHeight = 1.0 / cdYSize
  fov = 40.: aspectratio = cdXSize * invHeight
  angle = tan(0.5 * fov * cdGrad2Rad)
  for y = 0 to cdYSize/2
    yy = (1.0 - 2.0 * ((CDbl(y) + 0.5) * invHeight)) * angle
    fymy = cdYSize-y : yxsz = y*cdXSize : fymyxsz = fymy * cdXSize
    for x = cdYSize-1-y to cdXSize-1
      xxsz = x*cdXSize
      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)
      *(pMainDIB+yxsz+x) = c
      *(pMainDIB+fymyxsz+x) = c
      *(pMainDIB+yxsz+cdXSize-x) = c
      *(pMainDIB+fymyxsz+cdXSize-x) = c
      *(pMainDIB+xxsz+y) = c
      *(pMainDIB+xyt-xxsz+y) = c
      *(pMainDIB+xxsz+cdXSize-y) = c
      *(pMainDIB+xyt-xxsz+cdXSize-y) = c
    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
End Sub

Sub PintaObjeto ()
End Sub

Sub Inicio ()
  dim t as double = timer()
  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)
  print STR(timer()-t) + " seconds"
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)
Last edited by hurtado on Jan 28, 2020 18:37, edited 1 time in total.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Windows graphics tutorial

Post by badidea »

paul doe wrote:Here's some antialiasing code from waaaay back, fbc 0.24 era (modified enough so that it compiles with the current version):
...
Here, on linux, with the 32-bit fbc 1.07.1, the compilation gives me:
Aborting due to runtime error 12 ("segmentation violation" signal)
Ok with 64-bit fbc 1.07.1
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Post by hurtado »

@dodicat
I've got an error when compiling: ld.exe: cannot find -lcairo
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Windows graphics tutorial

Post by badidea »

srvaldez wrote:thanks dodicat, over 300 fps here
in case somebody is missing the cairo dll for Windows, here's an all-in-one dll https://github.com/preshing/cairo-windows/releases
Did you try to press "1"? Frame rate goes from 245 to 15 here when I press "1" for anti-aliased lines.
paul doe
Moderator
Posts: 1730
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Windows graphics tutorial

Post by paul doe »

badidea wrote:...
Here, on linux, with the 32-bit fbc 1.07.1, the compilation gives me:
Aborting due to runtime error 12 ("segmentation violation" signal)
Ok with 64-bit fbc 1.07.1
Not for me (fbc 1.07.1 32-bit on gcc 5x, Win10). Hmmmm...
hurtado wrote:@dodicat
I've got an error when compiling: ld.exe: cannot find -lcairo
You need the Cairo lib (check the post of srvaldez above)
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Windows graphics tutorial

Post by srvaldez »

@badidea
I get 20 and 28 fps with anti-aliased 32 & 64-bit respectively
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Windows graphics tutorial

Post by badidea »

paul doe wrote:
badidea wrote:...
Here, on linux, with the 32-bit fbc 1.07.1, the compilation gives me:
Aborting due to runtime error 12 ("segmentation violation" signal)
Ok with 64-bit fbc 1.07.1
Not for me (fbc 1.07.1 32-bit on gcc 5x, Win10). Hmmmm...
This function alone is enough to give the compiler trouble. I'll try to isolate the issue further...

Code: Select all

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
Like the compiler, I also have trouble reading this :-)
It is either the ulongint bit-shifting or the number of brackets.

Code: Select all

	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 _
		) _
	)
If I rewrite to this, then compiles and runs fine:

Code: Select all

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

	dim as ulongint A = ( src shr 32 and &hff00ff ) * opacity1
	dim as ulongint B = ( dst shr 32 and &hff00ff ) * ( 255 - opacity1 )
	dim as ulongint C = ( ( ( src shr 32 ) shr 8 ) and &hff00ff ) * opacity1
	dim as ulongint D = ( ( ( dst shr 32 ) shr 8 ) and &hff00ff ) * ( 255 - opacity1 )
	dim as ulongint E = ( src and &hff00ff ) * opacity2
	dim as ulongint F = ( dst and &hff00ff ) * ( 255 - opacity2 )
	dim as ulongint G = ( ( src shr 8 ) and &hff00ff ) * opacity2
	dim as ulongint H = ( ( dst shr 8 ) and &hff00ff ) * ( 255 - opacity2 )

	return _
	( _
		( ( ( A + B ) and &hff00ff00 ) shr 8 or ( C + D ) and &hff00ff00 ) _
		shl 32 or _
		( ( ( E + F ) and &hff00ff00 ) shr 8 or ( G + H ) and &hff00ff00 ) _
	)
end function
Last edited by badidea on Jan 28, 2020 21:15, edited 2 times in total.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows graphics tutorial

Post by dodicat »

hurtado
I tested out your fast fractals.
Indeed hurtado, for these basic 3D vector operations macro's are the way to go.
Operator and function calls are expensive.
FreeBASIC is a procedural language, and a macro (if carefully written) can inline many procedures.

srvaldez gave a link to the cairo.dll.
In freebasic the easiest way is to put the dll in the same folder as your code.
Otherwise you have to mess about, making a .dll.a file for the freebasic lib folder and putting the .dll into your system folder.
For fun here are some vectors for Rodrigues axial rotater, and planted on an api window.
(the lines are not anti aliased)

Code: Select all

 


/' ----------------------------------------------------------------------------
-       Plantilla Programación Gráfica - SWGPTG -  Tiny C                  -
-----                                                                  -----
-       AUTOR   : Alfonso Víctor Caballero Hurtado                         -
-----                                                                  -----
-       VERSION : 1.0                                                      -
-----                                                                  -----
-      (c) 2018. http://www.abreojosensamblador.net                        -
-                Small Windows Graphics Programming Tutorial With GDI      -
---------------------------------------------------------------------------- '/
#include "crt.bi"
#include "windows.bi"

#define cdXPos          CW_USEDEFAULT
#define cdYPos          CW_USEDEFAULT
#define cdXSize         800 
#define cdYSize         600
#define cdColFondo      0
#define MAIN_ICON       100   ' //  IDI_APPLICATION
#define cdVCursor       IDC_ARROW
#define cdVBarTipo      0
#define cdVBtnTipo      WS_OVERLAPPEDWINDOW
#define cdIdTimer       1
#define _getpixel(_x,_y)  *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)
Screenres cdXsize,cdYsize,32,,-1  'null window, but still has all the properties of gfx.
Width cdXsize\8,cdYsize\16
Color ,Rgb(0,0,50)
'// Variables globales
Dim Shared wMsg As Long
Dim Shared As Ulong Ptr             pMainDIB
Dim Shared As Integer                vdxClient, vdyClient,pitch
Dim Shared As BITMAPINFOHEADER  bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
Dim Shared As Any Ptr row
row=Screenptr
Dim Shared As Integer w,h
Screeninfo w,h,,,pitch
Const pi=4*Atn(1)

Type AxialAngle
    As Single Sin,Cos
End Type

Type v3
    As Single x,y,z
    As Ulong colour
End Type

Function normalize(v As V3) As V3
    Dim As Single L= Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
    Return Type(v.x/L,v.y/L,v.z/L)
End Function

Function AxialRotate(centre As v3,Pt As V3,Angle As AxialAngle,norm As v3,T As Single=1) Byref  As v3
    #define crossP(v1,v2,N) Type<v3>( N*(v1.y*v2.z-v2.y*v1.z),N*(-(v1.x*v2.z-v2.x*v1.z)),N*(v1.x*v2.y-v2.x*v1.y))
    #define plus(v1,v2) Type<v3>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
    #define dotP(v1,v2) (v1.x*v2.x + v1.y*v2.y + v1.z*v2.z)
    #define mlt(f,v1) Type<v3>(f*v1.x,f*v1.y,f*v1.z) 
    Static As v3 result
    Dim As V3 V=Type(T*(Pt.x-centre.x),T*(Pt.y-centre.y),T*(Pt.z-centre.z))
    Dim As V3 T1=crossP(norm,V,Angle.sin)
    Dim As Single tmpS=dotP(Norm,V)
    Dim As V3 tmpV=mlt(tmpS,norm)
    tmpV=mlt((1-Angle.cos),tmpV)
    T1=plus(T1,tmpV)
    Dim As V3 tt=mlt(Angle.cos,V) 
    result=plus(tt,T1)
    result=plus(result,centre)
    result.colour=Pt.colour
    Return result
End Function

Function perspective(p As V3,eyepoint As V3) As V3
    Dim As Single   w=1+(p.z/eyepoint.z)
    Return Type((p.x-eyepoint.x)/w+eyepoint.x,_
    (p.y-eyepoint.y)/w+eyepoint.y,_
    (p.z-eyepoint.z)/w+eyepoint.z, _
    p.colour)
End Function

Sub QsortZ(array() As V3,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As V3 x =array(((I+J)\2))
    While I <= J
        While array(I).z > X .z:I+=1:Wend
            While array(J).z < X .z:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J >begin Then QsortZ(array(),begin,J)
            If I <Finish Then QsortZ(array(),I,Finish)
        End Sub
        
        Function setAxialangle(angle As Single) As AxialAngle
            Return Type(Sin(angle),Cos(angle))
        End Function
        
        Function keys(a As v3,Byref msg As uint) As Integer
            a=Type(0,0,0)
            Dim As Single jmp=.05
            If Msg=1  Then a.y+=jmp:Msg=0:Return 1 'left
            If Msg=2  Then a.y-=jmp:Msg=0:Return 1 'right
            
            If msg=3  Then a.x+=jmp:Msg=0:Return 2 'up
            If Msg=4  Then a.x-=jmp:Msg=0:Return 2 'down
            
            If Msg=5  Then a.z+=jmp:Msg=0:Return 3  'F2
            If Msg=6  Then a.z-=jmp:Msg=0:Return 3 'F1
        End Function
        
        Function translate(v As v3,sz As Long,np As v3) As v3
            Return Type(sz*v.x+np.x,sz*v.y+np.y,sz*v.z+np.z)
        End Function
        
        Function shortline(fp As v3,p As v3,length As Long) As v3 'to extend either side of the screen centre.
            Dim As Long diffx=p.x-fp.x,diffy=p.y-fp.y,diffz=p.z-fp.z
            Dim As Single L=Sqr(diffx*diffx+diffy*diffy+diffz*diffz)
            Return Type(fp.x+length*diffx/L,fp.y+length*diffy/L,fp.z+length*diffz/L)
        End Function
        
        Sub drawaxis(x As v3,y As v3,z As v3)
            #define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
            Dim As v3 centre=(w/2,h/2,0),eye=Type(w/2,h/2,700)
            Dim As Long l=200
            Var cx=translate(x,l,centre),c2x=shortline(cx,centre,l*2) 'cx --- c2x = cx to centre then centre to c2x
            Var cy=translate(y,l,centre),c2y=shortline(cy,centre,l*2)
            Var cz=translate(z,l,centre),c2z=shortline(cz,centre,l*2)
            cx=perspective(cx,eye):c2x=perspective(c2x,eye)
            cy=perspective(cy,eye):c2y=perspective(c2y,eye)
            cz=perspective(cz,eye):c2z=perspective(c2z,eye)
            Line(cx.x,cx.y)-(c2x.x,c2x.y),Rgb(200,0,0)
            Line(cy.x,cy.y)-(c2y.x,c2y.y),Rgb(0,200,0)
            Line(cz.x,cz.y)-(c2z.x,c2z.y),Rgb(0,0,200)
            
            Dim As v3 t(1 To 6)={cx,c2x,cy,c2y,cz,c2z} 'for circles
            t(1).colour=Rgb(200,0,0):t(2).colour=t(1).colour
            t(3).colour=Rgb(0,200,0):t(4).colour=t(3).colour
            t(5).colour=Rgb(0,0,200):t(6).colour=t(5).colour
            
            qsortz(t(),1,6)
            
            Circle(t(1).x,t(1).y),map(300,-300,t(1).z,5,10),t(1).colour,,,,f
            Circle(t(2).x,t(2).y),map(300,-300,t(2).z,5,10),t(2).colour,,,,f
            
            Circle(t(3).x,t(3).y),map(300,-300,t(3).z,5,10),t(3).colour,,,,f
            Circle(t(4).x,t(4).y),map(300,-300,t(4).z,5,10),t(4).colour,,,,f
            
            Circle(t(5).x,t(5).y),map(300,-300,t(5).z,5,10),t(5).colour,,,,f
            Circle(t(6).x,t(6).y),map(300,-300,t(6).z,5,10),t(6).colour,,,,f  
            
        End Sub
        
        Sub main()
            Static As v3 rx,ry,rz
            Static As v3 xaxis=Type(1,0,0)
            Static As v3 yaxis=Type(0,1,0)
            Static As v3 zaxis=Type(0,0,1)
            Static As axialangle ax,ay,az
            Static As v3 centre,a
            Dim As Long k
            k=keys(a,wmsg)
            
            Select Case k
            Case 1
                If a.y>=2*pi Then a.y=0
                ay=setaxialangle(a.y)
                rx=AxialRotate(centre,xaxis,ay,yaxis)
                rz=AxialRotate(centre,zaxis,ay,yaxis)
                xaxis=rx
                zaxis=rz
            Case 2
                If a.x>=2*pi Then a.x=0
                ax=setaxialangle(a.x)
                ry=AxialRotate(centre,yaxis,ax,xaxis)
                rz=AxialRotate(centre,zaxis,ax,xaxis)
                yaxis=ry
                zaxis=rz
            Case 3
                If a.z>=2*pi Then a.z=0
                az=setaxialangle(a.z)
                rx=AxialRotate(centre,xaxis,az,zaxis)
                ry=AxialRotate(centre,yaxis,az,zaxis)
                xaxis=rx
                yaxis=ry
            End Select
            
            xaxis=normalize(xaxis) 'incase of creep
            yaxis=normalize(yaxis)
            zaxis=normalize(zaxis)
            Cls
            Draw String(20,20),  "Keys F1 and F2 to rotate around the Z   (blue) axis"
            Draw String(20,40),  "Keys right/left to rotate round the Y (green) axis"
            Draw String(20,60),  "Keys up/down to rotate round the X     (red) axis"
            drawaxis(xaxis,yaxis,zaxis)
            Sleep 1
        End Sub
    
        Sub PintaObjeto () 
            main()
            Dim As Integer  k
            For y As Integer= 1 To cdYSize
                For x As Integer = 1 To cdXSize
                    *(pMainDIB + k) =_getpixel(x-1,y-1)
                    k+=1
                Next
            Next
        End Sub
        
        Sub Inicio () 
            'for static stuff 
        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)
            
            '// 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) 
            
            
        Case WM_TIMER 
        InvalidateRect (hWnd, NULL, FALSE) 
        
    Case WM_SIZE :
    vdxClient = lParam And &hFFFF
    vdyClient = lParam Shr &h10 
  
Case WM_KEYDOWN
    Select Case wParam
    Case VK_LEFT 
        wmsg=1
    Case VK_RIGHT 
        wmsg=2
    Case VK_UP
        wmsg=3   
    Case VK_DOWN: 
        wmsg=4
    Case VK_F2
        wmsg=5
    Case VK_F1
         wmsg=6    
End Select


Case WM_PAINT 
   
    hdc = BeginPaint(hWnd, @ps)
    PintaObjeto ()
    '//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)
    
    
Case WM_DESTROY 
    wmDestruimos:
    KillTimer (hWnd, cdIdTimer) 
    hGDITmp = SelectObject (bufDIBDC, hOldDIB)
    bResult = DeleteDC (bufDIBDC)
    bResult = DeleteObject (hMainDIB)
    bResult = DestroyWindow (hWnd)
    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 ,"Drawing Basic Shapes - (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


End winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)


Sleep

 
I suppose I could go on for ever and ever with the template, but I'll probably make this my last example.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Windows graphics tutorial

Post by hurtado »

> I'll probably make this my last example
Thanks for everything. One always learn a lot from you. Many times before now I have looked at this forum and I can say that your examples are always sobering.

As for my latest examples, as a curiosity, I must say, I have not managed to reduce the execution speed so much just by using macros. In a way I cheated, I used the fact that this fractal is reflective, I only had to calculate an octant. In fact, the big majority of the advantage comes from here. And also because I have dispensed with the spheres behind, which are not visible. This way the rays have less work to do. Obviously we can improve this even more if we dispense with all those spheres that will not be used since we will only work in an octant.

Regarding the templates, of course anyone may use them without restriction of any kind, perhaps a small mention, although it is not mandatory.
Post Reply