Double buffering in Winapi

Windows specific questions.
Post Reply
myndgrrrrrl
Posts: 11
Joined: Feb 09, 2022 0:03

Double buffering in Winapi

Post by myndgrrrrrl »

Hello, I've been trying to do double buffering with winapi in freebasic but I can't.
Can someone help me?
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Double buffering in Winapi

Post by dodicat »

Simple example using text and rectangle.

Code: Select all

#include "windows.bi"

const xres=800
const yres=600
const backgroundColour=bgr(55,255,255)

Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
      SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style)) 
End Sub

Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
      SetTextColor(h,text) 
      SetBkColor(h,background)
End Sub

Sub text(h As hdc,x As Long,y As Long,s As String)
      Var l=Len(s)
      textouta(h,x,y,s,L)
End Sub

Sub ClearScreen(h As hdc)
      Var colour=BackgroundColour
      SetDCBrushColor(h,colour)
      SetDCPenColor(h,colour)
      rectangle(h,0,0,xres,yres)
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
      Static As Double timervalue,_lastsleeptime,t3,frames
      frames+=1
      If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=Timer
      Return sleeptime
End Function

Dim As hdc Memhdc,WorkingScreen,hdc
Dim As HBITMAP Membitmap
Dim As msg emsg
Dim As Long fps

Dim As hwnd p=CreateWindowEx( WS_EX_TOPMOST Or WS_EX_TOOLWINDOW ,"#32770","Press ESCAPE key to finish . . .",(WS_OVERLAPPEDWINDOW Or WS_SYSMENU) - (WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME) Or WS_VISIBLE,200,200,xres,yres,0,0,0,null)
WorkingScreen=GetDC(p)
Memhdc = CreateCompatibleDC(WorkingScreen)
Membitmap = CreateCompatibleBitmap(WorkingScreen, xres, yres)

SelectObject(Memhdc, Membitmap)
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))

setfontsize(Memhdc,20,"courier new")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)

While true
      
      While(PeekMessage(@eMsg,0, 0, 0, PM_REMOVE)) > 0 
            TranslateMessage (@eMsg)
            DispatchMessage (@eMsg)
            If GetAsyncKeyState(&h1B) Then ' escape key
                  DeleteObject(Membitmap)
                  DeleteDC    (Memhdc)
                  End
            End If
      Wend
      'graphics loop
      clearscreen(Memhdc)
      text(Memhdc,10,10,"Hello")
      text(Memhdc,10,30,"Draw all graphics (and SelectObject e.t.c.) into Memhdc")
      text(Memhdc,10,50,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
      text(Memhdc,10,70,"Note I use PeekMessage only to get graphics in a loop" )
      text(Memhdc,10,90,"My main window is a non resizable toolwindow (optional)")
      text(Memhdc,10,110,"framerate = "&fps)
      
      BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
      Sleep regulate(60,fps)
Wend


 
myndgrrrrrl
Posts: 11
Joined: Feb 09, 2022 0:03

Re: Double buffering in Winapi

Post by myndgrrrrrl »

Thank you
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Double buffering in Winapi

Post by UEZ »

Here two more examples:

GDI:

Code: Select all

'coded by UEZ
#Include "fbgfx.bi"
#Include "windows.bi"

Using FB

Const As UInteger iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180

ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 24, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI Double Buffering"
WindowTitle sTitle

Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Ulong Ptr aBitmap
Dim As BITMAPINFO tBITMAP
With tBITMAP.bmiheader
			.biSize = Sizeof(BITMAPINFOHEADER)
			.biWidth = iW
			.biHeight = -iH
			.biPlanes = 1
			.biBitCount = 32
			.biCompression = BI_RGB
End With
Dim As Any Ptr hDC = GetDC(hHWND), _
					hDC_backbuffer = CreateCompatibleDC(hDC), _
					hHBitmap = CreateDIBSection(hDC_backbuffer, @tBITMAP, DIB_RGB_COLORS, @aBitmap, NULL, NULL), _
					hCanvas, hPen
	
Var hObjOld = SelectObject(hDC_backbuffer, hHBitmap) 
'SetGraphicsMode(hDC, 2)
'SetStretchBltMode(hDC_backbuffer, 4) 'high quality mode

hPen = SelectObject(hDC_backbuffer, GetStockObject(DC_Pen))

Dim As Single r = 200, t = 0
Dim evt As EVENT

Do
	BitBlt(hDC_backbuffer, 0, 0, iW, iH, hDC_backbuffer, 0, 0, WHITENESS)
	
	MoveToEx(hDC_backbuffer, iWh + r * Cos(t), 				iHh + r * Sin(t), NULL)
	LineTo(hDC_backbuffer,   iWh + r * Cos(t + fRad * 90), 	iHh + r * Sin(t + fRad * 90))
	
	t += 0.01666666
	
	BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)

	Sleep(10)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))

SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
SelectObject(hDC_backbuffer, hPen)
DeleteObject(hPen)
GDIPlus:

Code: Select all

'coded by UEZ
#Include "fbgfx.bi"
#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include Once "win/gdiplus-c.bi"
#Else
    #Include Once "win/gdiplus.bi"
    Using gdiplus
#Endif

Using FB

Const As UShort iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180

Dim Shared gdipToken As ULONG_PTR
Dim GDIp As GdiplusStartupInput 
GDIp.GdiplusVersion = 1
GdiplusStartup(@gdipToken, @GDIp, NULL)

ScreenControl SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI+ Double Buffering"
WindowTitle sTitle

Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Any Ptr hDC = GetDC(hHWND), _
					hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
					hDC_backbuffer = CreateCompatibleDC(hDC), _
					hCanvas, hPen
					
Var hObjOld = SelectObject(hDC_backbuffer, hHBitmap) 

GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, 5)
GdipSetPixelOffsetMode(hCanvas, 2)
GdipCreatePen1(&hFF000000, 1, 2, @hPen)
GdipSetPenLineJoin(hPen, 2)

Dim As Single r = 200, t = 0
Dim evt As EVENT

Do
	BitBlt(hDC_backbuffer, 0, 0, iW, iH, hDC_backbuffer, 0, 0, WHITENESS)
	
	GdipDrawLine(hCanvas, hPen, iWh + r * Cos(t), iHh + r * Sin(t), iWh + r * Cos(t + fRad * 90), iHh + r * Sin(t + fRad * 90))
	t += 0.01666666
	
	BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)

	Sleep(10, 1)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))

SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdipDeletePen(hPen)
GdiplusShutdown(gdipToken)
You can search for GDI or GDI+ to find more examples, if it weren't for the limit of at least 4 letters... :(
marcov
Posts: 3455
Joined: Jun 16, 2005 9:45
Location: Netherlands
Contact:

Re: Double buffering in Winapi

Post by marcov »

Afaik newer commctrls allow to set a double buffer attribute. I quickly looked and it is called WS_EX_COMPOSITED, maybe searching on that helps.
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: Double buffering in Winapi

Post by aurelVZAB »

That is not real double buffering without using callback WM_PAINT
when you drag window and pull it over screen edge then window become dark
in first dodicat example become white.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Double buffering in Winapi

Post by UEZ »

aurelVZAB wrote: Feb 10, 2022 12:12 That is not real double buffering without using callback WM_PAINT
when you drag window and pull it over screen edge then window become dark
in first dodicat example become white.
It depends on what you mean with db! Without db the gfx animation will flicker. WM_PAINT is only for repainting, not db, imho.
Afaik, WS_EX_COMPOSITED is not working for GDI / GDI+.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Double buffering in Winapi

Post by dodicat »

Give us an example aurelVZAB.
The main purpose of double buffering is to avoid flicker (in any window), even the console:

Code: Select all

#include "windows.bi"

Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)

Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
      SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style)) 
End Sub

Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
      SetTextColor(h,text) 
      SetBkColor(h,background)
End Sub

Sub text(h As hdc,x As Long,y As Long,s As String)
      Var l=Len(s)
      textouta(h,x,y,s,L)
End Sub

Sub ClearScreen(h As hdc)
      Var colour=BackgroundColour
      SetDCBrushColor(h,colour)
      SetDCPenColor(h,colour)
      rectangle(h,0,0,xres,yres)
End Sub

sub hidecursor()

    dim as handle consoleHandle
     dim as CONSOLE_CURSOR_INFO info
     consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
     info.dwSize = 100
     info.bVisible = FALSE 
     SetConsoleCursorInfo(consoleHandle, @info)
     End sub

Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
      angle=angle*Atn(1)/45
      x2=x+lngth*Cos(angle)
      y2=y-lngth*Sin(angle)
End Sub

Sub pendulum(h As hdc)
      SetDCBrushColor(h,bgr(0,150,255))
      SetDCPenColor(h,bgr(200,0,50))
      Dim As Long x,y
      Const pi=4*Atn(1),r=40
      Static As Single ang
      ang+=.02
      drawline(400,20,15*Sin(ang)-90,500,x,y)
      MoveToEx(h, 400, 20, NULL)
      LineTo(h, x,y)
      ellipse(h,(x-r),(y-r),(x+r),(y+r))
      Circle(x,y),50
End Sub


Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
      Static As Double timervalue,_lastsleeptime,t3,frames
      frames+=1
      If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=Timer
      Return sleeptime
End Function

Dim As hdc Memhdc,WorkingScreen,hdc
Dim As HBITMAP Membitmap
Dim As msg emsg
Dim As Long fps

Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, 810, 630,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
Memhdc = CreateCompatibleDC(WorkingScreen)
Membitmap = CreateCompatibleBitmap(WorkingScreen, xres, yres)

SelectObject(Memhdc, Membitmap)
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))

setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND)    'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND)    'non resizable console
hidecursor()
ShowScrollBar(p, SB_BOTH, FALSE)

While true
    
      'graphics loop
      clearscreen(Memhdc)
      text(Memhdc,10,10,"Hello")
      text(Memhdc,10,35,"Draw all graphics (and SelectObject e.t.c.) into Memhdc")
      text(Memhdc,10,60,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
      text(Memhdc,10,110,"framerate = "&fps)
      text(Memhdc,10,500,"Press <escape> to finish")
      pendulum(Memhdc)
      
      BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
      Sleep regulate(60,fps)
      If GetAsyncKeyState(&h1B) Then ' escape key
            DeleteObject(Membitmap)
            DeleteDC    (Memhdc)
            End
      End If
Wend


 
adeyblue
Posts: 299
Joined: Nov 07, 2019 20:08

Re: Double buffering in Winapi

Post by adeyblue »

Is everybody welcome to this party?

There's also Begin/EndBufferedPaint which you can just put around your existing code without having to rearchitect it. Also lets you do alpha blending, how fancy.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Double buffering in Winapi

Post by UEZ »

adeyblue wrote: Feb 11, 2022 5:24 Is everybody welcome to this party?

There's also Begin/EndBufferedPaint which you can just put around your existing code without having to rearchitect it. Also lets you do alpha blending, how fancy.
Here is my attempt to implement it:

Code: Select all

'coded by UEZ
#Include "fbgfx.bi"
#Include "windows.bi"
'#Include "win/uxtheme.bi"
Using FB

Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type _BP_PAINTPARAMS
	cbSize As DWORD
	dwFlags As DWORD
	prcExclude As Const RECT Ptr
	pBlendFunction As Const BLENDFUNCTION Ptr
End Type
Type _BP_BUFFERFORMAT As Long
Type BP_BUFFERFORMAT As _BP_BUFFERFORMAT
Type BP_PAINTPARAMS As _BP_PAINTPARAMS
Enum
	BPBF_COMPATIBLEBITMAP
	BPBF_DIB
	BPBF_TOPDOWNDIB
	BPBF_TOPDOWNMONODIB
End Enum

Dim As Any Ptr hLibUx = Dylibload("UxTheme.dll")
Dim BufferedPaintInit As Function () As HRESULT
Dim BufferedPaintUnInit As Function () As HRESULT
Dim BeginBufferedPaint As Function (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As BP_BUFFERFORMAT, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Dim EndBufferedPaint As Function (Byval hBufferedPaint as HPAINTBUFFER, Byval fUpdateTarget as WINBOOL) as HRESULT

BufferedPaintInit = Dylibsymbol(hLibUx, "BufferedPaintInit")
BufferedPaintUnInit = Dylibsymbol(hLibUx, "BufferedPaintUnInit")
BeginBufferedPaint = Dylibsymbol(hLibUx, "BeginBufferedPaint")
EndBufferedPaint = Dylibsymbol(hLibUx, "EndBufferedPaint")

Const As UInteger iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180

ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 24, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI Double Buffering"
WindowTitle sTitle

Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Any Ptr hDC = GetDC(hHWND), hCanvas, hPen, hNewDC
hPen = SelectObject(hDC, GetStockObject(DC_Pen))

Dim As RECT tRECT = Type(0, 0, iW, iH)
Dim As BLENDFUNCTION tBLENDFUNCTION
tBLENDFUNCTION.BlendOp = AC_SRC_OVER
tBLENDFUNCTION.BlendFlags = 0
tBLENDFUNCTION.SourceConstantAlpha = 100
tBLENDFUNCTION.AlphaFormat = AC_SRC_ALPHA

Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(_BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION

BufferedPaintInit()
Dim As HPAINTBUFFER hBP = BeginBufferedPaint(hDC, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @hNewDC)

Dim As Double r = 200, t = 0

Do
	BitBlt(hNewDC, 0, 0, iW, iH, hDC, 0, 0, WHITENESS)
	
	MoveToEx(hNewDC, iWh + r * Cos(t), 				iHh + r * Sin(t), NULL)
	LineTo(hNewDC,   iWh + r * Cos(t + fRad * 90), 	iHh + r * Sin(t + fRad * 90))
	
	BitBlt(hDC, 0, 0, iW, iH, hNewDC, 0, 0, MERGECOPY)
	
	t += 0.01666666

	Sleep(10)
Loop Until InKey = Chr(27)

EndBufferedPaint(hBP, 1)
BufferedPaintUnInit()
ReleaseDC(hHWND, hDC)
SelectObject(hDC, hPen)
DeleteObject(hPen)
Dylibfree(hLibUx)
Remark: #Include "win/uxtheme.bi" doesn't work properly.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Double buffering in Winapi

Post by dodicat »

I also had a go at "Is everybody welcome to this party?" by adeyblue.
I had to leave a border around, I had difficulty filling the background (all of it) with rectangle.
But I'll have a closer look later, I am sure it is something simple.
Alas, I had to make the pendulum shorter in this method so it fitted the screen (a symptom of the above rectangle)
There is a slight difference between 32 and 64 bits.
Way back in the mists of time dkl did say that some work was needed to be done with the winapi.bi files to accommodate 64 and 32 bit, so "win/uxtheme.bi" is one of them I reckon.
Probably all this #if _WIN32_WINNT >= bla bla needs looked at.
Anyway:

Code: Select all

#define winincludeall
#include "windows.bi"
'#Include "win/uxtheme.bi"

Enum
      BPBF_COMPATIBLEBITMAP
      BPBF_DIB
      BPBF_TOPDOWNDIB
      BPBF_TOPDOWNMONODIB
End Enum

Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type BP_PAINTPARAMS
	cbSize As DWORD
	dwFlags As DWORD
	prcExclude As Const RECT Ptr
	pBlendFunction As Const BLENDFUNCTION Ptr
End Type

Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long 
Declare Function BufferedPaintInit Lib "UxTheme.dll" Alias "BufferedPaintInit" As HRESULT
Declare Function BufferedPaintUnInit Lib "UxTheme.dll" Alias "BufferedPaintUnInit" As HRESULT
Declare Function BeginBufferedPaint Lib "UxTheme.dll" Alias "BeginBufferedPaint" (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As Long, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Declare Function EndBufferedPaint Lib "UxTheme.dll" Alias "EndBufferedPaint" (Byval hBufferedPaint As HPAINTBUFFER, Byval fUpdateTarget As WINBOOL) As HRESULT

Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)

Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
      SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style)) 
End Sub

Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
      SetTextColor(h,text) 
      SetBkColor(h,background)
End Sub

Sub text(h As hdc,x As Long,y As Long,s As String)
      Var l=Len(s)
      textouta(h,x,y,s,L)
End Sub

Sub ClearScreen(h As hdc)
      Var colour=BackgroundColour
      SetDCBrushColor(h,colour)
      SetDCPenColor(h,colour)
      rectangle(h,15,15,xres,yres)
End Sub

Sub hidecursor()
      Dim As handle consoleHandle
      Dim As CONSOLE_CURSOR_INFO info
      consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
      info.dwSize = 100
      info.bVisible = FALSE 
      SetConsoleCursorInfo(consoleHandle, @info)
End Sub

Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
      angle=angle*Atn(1)/45
      x2=x+lngth*Cos(angle)
      y2=y-lngth*Sin(angle)
End Sub

Sub pendulum(h As hdc)
      SetDCBrushColor(h,bgr(0,150,255))
      SetDCPenColor(h,bgr(200,0,50))
      Dim As Long x,y
      Const pi=4*Atn(1),r=40
      Static As Single ang
      ang+=.02
      drawline(400,20,15*Sin(ang)-90,450,x,y)
      MoveToEx(h, 400, 20, NULL)
      LineTo(h, x,y)
      ellipse(h,(x-r),(y-r),(x+r),(y+r))
End Sub


Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
      Static As Double timervalue,_lastsleeptime,t3,frames
      frames+=1
      If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=Timer
      Return sleeptime
End Function

Dim As hdc Memhdc,WorkingScreen
Dim As msg emsg
Dim As Long fps

Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, xres, yres,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
SetWindowTheme(p,"","")

'==================================================
Dim As RECT tRECT = Type(0, 0,xres, yres)
Dim As BLENDFUNCTION tBLENDFUNCTION

BufferedPaintInit()

Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION

Dim As HPAINTBUFFER hBP = BeginBufferedPaint(WorkingScreen, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @Memhdc)
If hBP=null Then Print "unable to do this":Sleep:End
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))


setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
Var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND)    'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND)    'non resizable console
hidecursor()
ShowScrollBar(p, SB_BOTH, FALSE)

While true
      'graphics loop
      clearscreen(Memhdc)
      text(Memhdc,20,10+10,"Hello")
      text(Memhdc,20,35+10,"Draw all graphics (and SelectObject e.t.c.) into Memhdc via BeginBufferedPaint")
      text(Memhdc,20,60+10,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
      text(Memhdc,20,110+10,"framerate = "&fps)
      text(Memhdc,20,500,"Press <escape> to finish")
      pendulum(Memhdc)
      
      BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
      Sleep regulate(60,fps)
      If GetAsyncKeyState(&h1B) Then ' escape key
            EndBufferedPaint(hBP, 1)
            BufferedPaintUnInit()
            DeleteDC    (Memhdc)
            DeleteDC    (WorkingScreen)
            End
      End If
Wend


 
Munair
Posts: 1286
Joined: Oct 19, 2017 15:00
Location: Netherlands
Contact:

Re: Double buffering in Winapi

Post by Munair »

Just a minor detail; isn't it simpler to use do..loop rather than while true..wend?
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Double buffering in Winapi

Post by UEZ »

@dodicat: you can use

Code: Select all

Declare Function BufferedPaintClear Lib "UxTheme.dll" Alias "BufferedPaintClear" (Byval hBufferedPaint As HPAINTBUFFER, Byval prcTarget As Const RECT Ptr) As HRESULT
BufferedPaintClear(hBP, Null)
instead of

Code: Select all

clearscreen(Memhdc)
if you want to clear the buffered dc flat (black). I know that you have used a separate function to add bg colors.
This seems to work without the black border at the right or scrollbar:

Code: Select all

'#define winincludeall
#include "windows.bi"
'#Include "win/uxtheme.bi"

Enum
      BPBF_COMPATIBLEBITMAP
      BPBF_DIB
      BPBF_TOPDOWNDIB
      BPBF_TOPDOWNMONODIB
End Enum

Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type BP_PAINTPARAMS
	cbSize As DWORD
	dwFlags As DWORD
	prcExclude As Const RECT Ptr
	pBlendFunction As Const BLENDFUNCTION Ptr
End Type

Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long 
Declare Function BufferedPaintInit Lib "UxTheme.dll" Alias "BufferedPaintInit" As HRESULT
Declare Function BufferedPaintUnInit Lib "UxTheme.dll" Alias "BufferedPaintUnInit" As HRESULT
Declare Function BeginBufferedPaint Lib "UxTheme.dll" Alias "BeginBufferedPaint" (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As Long, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Declare Function EndBufferedPaint Lib "UxTheme.dll" Alias "EndBufferedPaint" (Byval hBufferedPaint As HPAINTBUFFER, Byval fUpdateTarget As WINBOOL) As HRESULT
Declare Function BufferedPaintClear Lib "UxTheme.dll" Alias "BufferedPaintClear" (Byval hBufferedPaint As HPAINTBUFFER, Byval prcTarget As Const RECT Ptr) As HRESULT

Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)

Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
      SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style)) 
End Sub

Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
      SetTextColor(h,text) 
      SetBkColor(h,background)
End Sub

Sub text(h As hdc,x As Long,y As Long,s As String)
      Var l=Len(s)
      textouta(h,x,y,s,L)
End Sub

Sub ClearScreen(h As hdc)
      Var colour=BackgroundColour
      SetDCBrushColor(h,colour)
      SetDCPenColor(h,colour)
      rectangle(h,0,0,xres,yres)
End Sub

Sub hidecursor()
      Dim As handle consoleHandle
      Dim As CONSOLE_CURSOR_INFO info
      consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
      info.dwSize = 100
      info.bVisible = FALSE 
      SetConsoleCursorInfo(consoleHandle, @info)
End Sub

Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
      angle=angle*Atn(1)/45
      x2=x+lngth*Cos(angle)
      y2=y-lngth*Sin(angle)
End Sub

Sub pendulum(h As hdc)
      SetDCBrushColor(h,bgr(0,150,255))
      SetDCPenColor(h,bgr(200,0,50))
      Dim As Long x,y
      Const pi=4*Atn(1),r=40
      Static As Single ang
      ang+=.02
      drawline(400,20,15*Sin(ang)-90,450,x,y)
      MoveToEx(h, 400, 20, NULL)
      LineTo(h, x,y)
      ellipse(h,(x-r),(y-r),(x+r),(y+r))
End Sub


Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
      Static As Double timervalue,_lastsleeptime,t3,frames
      frames+=1
      If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=Timer
      Return sleeptime
End Function


Dim As hdc Memhdc,WorkingScreen
Dim As msg emsg
Dim As Long fps

Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, xres, yres,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), Type <COORD>(95, 35))
SetWindowTheme(p,"","")

'==================================================
Dim As RECT tRECT = Type(0, 0,xres, yres)
Dim As BLENDFUNCTION tBLENDFUNCTION

BufferedPaintInit()

Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION

Dim As HPAINTBUFFER hBP = BeginBufferedPaint(WorkingScreen, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @Memhdc)
If hBP=null Then Print "unable to do this":Sleep:End
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))


setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
Var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND)    'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND)    'non resizable console
hidecursor()

While true
      'graphics loop
      clearscreen(Memhdc)
	  'BufferedPaintClear(hBP, NULL)
      text(Memhdc,20,10+10,"Hello")
      text(Memhdc,20,35+10,"Draw all graphics (and SelectObject e.t.c.) into Memhdc via BeginBufferedPaint")
      text(Memhdc,20,60+10,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
      text(Memhdc,20,110+10,"framerate = "&fps)
      text(Memhdc,20,500,"Press <escape> to finish")
      pendulum(Memhdc)
      
      BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
      Sleep regulate(60,fps)
      If GetAsyncKeyState(&h1B) Then ' escape key
            EndBufferedPaint(hBP, 1)
            BufferedPaintUnInit()
            DeleteDC    (Memhdc)
            DeleteDC    (WorkingScreen)
            End
      End If
Wend
I don't see a real advantage using Buffered* functions compared to the classic way. Only useful when mixing bitmaps with alpha blending.

Munair wrote: Feb 12, 2022 10:44 Just a minor detail; isn't it simpler to use do..loop rather than while true..wend?
Why is do/loop simpler than While/Wend? For me it's the same effort.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Double buffering in Winapi

Post by dodicat »

Thanks UEZ.
In fact I only have to move ShowScrollBar(p, SB_BOTH, FALSE) up a bit to just under SetWindowTheme(p,"","")
SetWindowTheme(p,"","")
ShowScrollBar(p, SB_BOTH, FALSE)
And reset my rectangle to the whole screen again.
All I have to do is give the console a title and you wouldn't recognise it as a console any more.
Actually I use this type of console for graphics in pascal.
So we have three methods for double buffering now, or more to the point, three methods to get rid of flickering.
Who is going to fix "win/uxtheme.bi", not me today anyway, I can't be bothered just now.
Post Reply