FBSL - Special visual effects : how to render raindrops onto a JPG

[Gerome]

Hello,

This script reveals multithreading capabilities of FBSL v3 inspired by Tom Kenny's Water Effect Demo...

Water _Effect_Demo.fbs

Code

'###########################################################################
'
'  Original Name: Tears.fbs
'             Author: Mike Lobko-Lobanovsky (mike.lobanovsky@fbsl.net)
' Creation Date: April 13, 2006
'      Description: This script reveals multithreading capabilities of FBSL v3 inspired by Tom Kenny's Water Effect Demo
'
'###########################################################################
#Option Explicit

#DllDeclare User32("GetClientRect")
#DllDeclare Gdi32("CreateDIBSection")
#DllDeclare Kernel32("RtlMoveMemory", "GetModuleHandle", "GetProcessHeap", "HeapAlloc")

Begin Const
	Running = 0 'Thread running flag
	DropSize = 4 'Strength (weight) of a drop
	XOffset = 8 'X-offset from the left margin of the window
	YOffset = 12 'Y-offset from the top of the window
	SourceBitmap = 16 'Handle to the original 100x100 pixel tile
	DropBitmap = 20 'Handle to the watered 100x100 pixel tile
	SourceBits = 24 'Pointer to the original tile's RGB data
	DropBits = 28 'Pointer to the watered tile's RGB data
	FirstMap = 32 'The initial height map
	LastMap = 36 'The last computed height map
	WaterProc = 40 'Compute the new height map based on the initial and last height maps
	FrameProc = 44 'Set drop bitmap bits according to the currently computed height map
	TileProc = 48 'Blit the drop bitmap to the window device context
	AnimateProc = 52 'Loop the preceding 3 procs for 60 frames
	AnimateArgs = 56 'Pointer to the args for the animation proc
End Const 'len=60 bytes 

Begin Const
	SRCCOPY = &HCC0020
	DIB_RGB_COLORS = 0
	HORZRES = 8
	VERTRES = 10
End Const

Dim $BmpInfo: FillString(BmpInfo, 40, 0) 'BITMAPINFOHEADER
Dim $TileStruct: FillString(TileStruct, 600, 0) 'Array of 10 tile structures
Dim $TileParams: Alloc(TileParams, 28) 'Parameter array for Tile()
Dim $AnimateParams: Alloc(AnimateParams, 8) 'Parameter array for Animate()


'=======================================================================
' This machine code function processes two height maps to compute the new height map for one
' of the 60 animation frames. It  processes 10,000 pixels with a dozen Peeks and Pokes involved.
' Clearly enough, none of the known interpreters can do it in real time fast enough for the animation
' to look natural. This is the reason why it is written in Assembler.
'=======================================================================
Dim $Water = Data( _
	&H55, &H8B, &HEC, &H83, &HEC, &H0C, &H53, &H51, &H52, &H56, &H57, &H6A, &H62, &H8F, &H45, &HF8, _
	&H6A, &H06, &H8F, &H45, &HF4, &HDB, &H45, &HF4, &H8B, &H75, &H08, &H8B, &H7D, &H08, &H8B, &H76, _
	&H20, &H8B, &H7F, &H24, &HB8, &HC8, &H00, &H00, &H00, &H8D, &H3C, &H38, &H6A, &H02, &H8F, &H45, _
	&HFC, &HB9, &H02, &H00, &H00, &H00, &H8D, &H14, &H31, &H0F, &HBE, &H02, &H8D, &H52, &H64, &H0F, _
	&HB6, &H5A, &HFF, &H03, &HC3, &H0F, &HB6, &H1A, &H03, &HC3, &H0F, &HB6, &H5A, &H01, &H03, &HC3, _
	&H8D, &H52, &H64, &H0F, &HBE, &H5A, &HFE, &H03, &HC3, &H0F, &HBE, &H5A, &HFF, &H03, &HC3, &H0F, _
	&HBE, &H5A, &H01, &H03, &HC3, &H0F, &HBE, &H5A, &H02, &H03, &HC3, &H8D, &H52, &H64, &H0F, &HBE, _
	&H5A, &HFF, &H03, &HC3, &H0F, &HBE, &H1A, &H03, &HC3, &H0F, &HBE, &H5A, &H01, &H03, &HC3, &H8D, _
	&H52, &H64, &H0F, &HBE, &H1A, &H03, &HC3, &H48, &H89, &H45, &HF4, &HDB, &H45, &HF4, &HD8, &HF1, _
	&HDB, &H5D, &HF4, &H8B, &H45, &HF4, &H0F, &HBE, &H1C, &H39, &H2B, &HC3, &H8B, &HD8, &HC1, &HE8, _
	&H04, &H2B, &HD8, &H83, &HFB, &H02, &H7D, &H02, &H33, &HDB, &H88, &H1C, &H39, &H41, &H3B, &H4D, _
	&HF8, &H72, &H83, &H83, &HC7, &H64, &H83, &HC6, &H64, &HFF, &H45, &HFC, &H8B, &H4D, &HFC, &H3B, _
	&H4D, &HF8, &H0F, &H82, &H69, &HFF, &HFF, &HFF, &HD9, &H5D, &HF4, &H5F, &H5E, &H5A, &H59, &H5B, _
	&H83, &HC4, &H0C, &HC9, &HC2, &H10)
	
'=======================================================================
' This machine code function takes the new height map bytes, combines them with the source bitmap
' bits and saves the result to the destination bitmap. If the given byte is zero then the resulting bit
' is the same as that in the source bitmap, otherwise some other source pixel is chosen to produce a
' refraction-like picture. Reasons for choosing Assembler are the same as above.
'=======================================================================
Dim $Frame = Data( _
	&H55, &H8B, &HEC, &H83, &HEE, &H10, &H53, &H51, &H52, &H57, &H56, &H33, &HC0, &H89, &H45, &HF4, _
	&H89, &H45, &HF0, &H8B, &H5D, &H08, &H8B, &H43, &H18, &H89, &H45, &HFC, &H8B, &H43, &H1C, &H89, _
	&H45, &HF8, &H8B, &H45, &H08, &H8B, &H70, &H20, &H8B, &H7B, &H24, &H89, &H78, &H20, &H89, &H70, _
	&H24, &H33, &HC9, &H8B, &HC1, &H8B, &H55, &HF0, &H85, &HC9, &H74, &H13, &H83, &HF9, &H63, &H73, _
	&H0E, &H0F, &HBE, &H7C, &H32, &HFF, &H0F, &HBE, &H5C, &H32, &H01, &H2B, &HDF, &H03, &HC3, &H8B, _
	&H5D, &HF4, &H85, &HDB, &H74, &H11, &H83, &HFB, &H63, &H73, &H0C, &H0F, &HBE, &H54, &H32, &H9C, _
	&H0F, &HBE, &H3E, &H2B, &HFA, &H03, &HDA, &H85, &HC0, &H79, &H02, &H33, &HC0, &H85, &HDB, &H79, _
	&H02, &H33, &HDB, &HBA, &H63, &H00, &H00, &H00, &H3B, &HC2, &H7E, &H02, &H8B, &HC2, &H3B, &HDA, _
	&H7E, &H02, &H8B, &HDA, &H42, &HC1, &HE3, &H02, &H0F, &HAF, &HD3, &H8D, &H04, &H82, &H8B, &H55, _
	&HF0, &H03, &H45, &HFC, &H0F, &HBE, &H14, &H32, &H0F, &HB6, &H18, &H03, &HDA, &H81, &HFB, &HFF, _
	&H00, &H00, &H00, &H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &H8B, &HFB, &H0F, &HB6, &H58, &H01, _
	&H03, &HDA, &H81, &HFB, &HFF, &H00, &H00, &H00, &H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &HC1, _
	&HE3, &H08, &H0B, &HFB, &H0F, &HB6, &H58, &H02, &H03, &HDA, &H81, &HFB, &HFF, &H00, &H00, &H00, _
	&H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &HC1, &HE3, &H10, &H0B, &HFB, &H8B, &H45, &HF0, &H8B, _
	&H55, &HF8, &H89, &H3C, &H82, &HFF, &H45, &HF0, &H41, &H83, &HF9, &H64, &H0F, &H82, &H41, &HFF, _
	&HFF, &HFF, &H8B, &H4D, &HF4, &H41, &H89, &H4D, &HF4, &H83, &HF9, &H64, &H0F, &H82, &H2F, &HFF, _
	&HFF, &HFF, &H5E, &H5F, &H5A, &H59, &H5B, &H83, &HC6, &H10, &HC9, &HC2, &H10)
	
'=======================================================================
' This machine code function blits the destination bitmap to the screen. This function is part of the
' animation loop written in Assembler therefore it has been written in Assembler too.
'=======================================================================
Dim $Tile = Data( _
	&H55, &H8B, &HEC, &H83, &HEE, &H0C, &H57, &H56, &H8B, &H7D, &H08, &H8B, &H75, &H0C, &H6A, &H00, _
	&HFF, &H16, &H89, &H45, &HFC, &HFF, &H77, &H14, &HFF, &H75, &HFC, &HFF, &H56, &H08, &H89, &H45, _
	&HF8, &HFF, &H76, &H18, &HFF, &H56, &H10, &H89, &H45, &HF4, &H68, &H20, &H00, &HCC, &H00, &H6A, _
	&H00, &H6A, &H00, &HFF, &H75, &HFC, &H6A, &H64, &H6A, &H64, &HFF, &H77, &H0C, &HFF, &H77, &H08, _
	&H50, &HFF, &H56, &H0C, &HFF, &H75, &HF4, &HFF, &H76, &H18, &HFF, &H56, &H14, &HFF, &H75, &HF8, _
	&HFF, &H75, &HFC, &HFF, &H56, &H08, &HFF, &H75, &HFC, &HFF, &H56, &H04, &H5E, &H5F, &HC9, &HC2, _
	&H10)
	
'=======================================================================
' This machine code function animates the refraction. It runs 60 loops each of which comprises a call
' to Water() to produce a new height map, a call to Frame() to combine the height map and the
' source bitmap into a current frame of animation, and a call to Tile() to blit the frame to the screen.
' Then the function calls Sleep() to yield control to other running threads for 10 milliseconds and
' resumes control to run another loop. The function incorporates a loop counter, so Assembler was
' chosen to isolate it from the other threads' counters to make looping persistent after the current
' thread resumes control. The function also clears the 'Busy' flag when thread execution is over.
'=======================================================================
Dim $Animate = Data( _
	&H55, &H8B, &HEC, &H83, &HEC, &H04, &H57, &H56, &H6A, &H00, &H8F, &H45, &HFC, &H6A, &H00, &H6A, _
	&H00, &H6A, &H00, &H8B, &H7D, &H08, &H57, &HFF, &H57, &H28, &H6A, &H00, &H6A, &H00, &H6A, &H00, _
	&H8B, &H7D, &H08, &H57, &HFF, &H57, &H2C, &H6A, &H00, &H6A, &H00, &H8B, &H7D, &H08, &H8B, &H7F, _
	&H38, &HFF, &H77, &H04, &H8B, &H7D, &H08, &H57, &HFF, &H57, &H30, &H6A, &H0A, &H8B, &H7D, &H08, _
	&H8B, &H7F, &H38, &HFF, &H17, &HFF, &H45, &HFC, &H83, &H7D, &HFC, &H3C, &H72, &HBF, &H33, &HC0, _
	&H8B, &H7D, &H08, &H89, &H07, &H5E, &H5F, &HC9, &HC2, &H04)
	
Sub Main()
	'===================================================
	' Main entry point
	'===================================================
	Dim %pTStruct
	Dim %BmpBits
	Dim %BmpDC = CreateCompatibleDC(NULL)
	'===================================================
	' One bitmapinfo header will be sufficient to create all the bmps we need
	'===================================================
	SetMem(BmpInfo, 40, 0) 'size of BITMAPINFOHEADER
	SetMem(BmpInfo, 100, 4) 'bmp width
	SetMem(BmpInfo, 100, 8) 'bmp height
	SetMem(BmpInfo, 1, 12) '# of planes
	SetMem(BmpInfo, 32, 14) '32-bit color
	'===================================================
	' Fill in the Tile() function parameter array
	'===================================================
	Dim %hModule = GetModuleHandle("Gdi32.dll")
	SetMem(TileParams, GetProcAddress(hModule, "CreateCompatibleDC"), 0)
	SetMem(TileParams, GetProcAddress(hModule, "DeleteDC"), 4)
	SetMem(TileParams, GetProcAddress(hModule, "SelectObject"), 8)
	SetMem(TileParams, GetProcAddress(hModule, "BitBlt"), 12)
	hModule = GetModuleHandle("User32.dll")
	SetMem(TileParams, GetProcAddress(hModule, "GetDC"), 16)
	SetMem(TileParams, GetProcAddress(hModule, "ReleaseDC"), 20)
	SetMem(TileParams, ME, 24)
	'===================================================
	' Fill in the Animate() function parameter array
	'===================================================
	hModule = GetModuleHandle("Kernel32.dll")
	SetMem(AnimateParams, GetProcAddress(hModule, "Sleep"), 0)
	SetMem(AnimateParams, @TileParams, 4)
	'===================================================
	' Allocate memory for bitmaps, assembler functions, and assembler
	' functions' parameter arrays. Copy the assembler procedure code
	' to the allocated space to completely isolate each thread from others.
	'===================================================
	For pTStruct = @TileStruct To  @TileStruct + 540 Step 60
		Poke(pTStruct + DropBitmap, CreateDIBSection(BmpDC, @BmpInfo, DIB_RGB_COLORS, @BmpBits, NULL, NULL))
		Poke(pTStruct + DropBits, BmpBits)
		Poke(pTStruct + SourceBitmap, CreateDIBSection(BmpDC, @BmpInfo, DIB_RGB_COLORS, @BmpBits, NULL, NULL))
		Poke(pTStruct + SourceBits, BmpBits)
		Poke(pTStruct + FirstMap, HeapAlloc(GetProcessHeap(), 8, 10000))
		Poke(pTStruct + LastMap, HeapAlloc(GetProcessHeap(), 8, 10000))
		Poke(pTStruct + WaterProc, HeapAlloc(GetProcessHeap(), 8, Len(Water)))
		RtlMoveMemory(Peek(pTStruct + WaterProc, 4), @Water, Len(Water))
		Poke(pTStruct + FrameProc, HeapAlloc(GetProcessHeap(), 8, Len(Frame)))
		RtlMoveMemory(Peek(pTStruct + FrameProc, 4), @Frame, Len(Frame))
		Poke(pTStruct + TileProc, HeapAlloc(GetProcessHeap(), 8, Len(Tile)))
		RtlMoveMemory(Peek(pTStruct + TileProc, 4), @Tile, Len(Tile))
		Poke(pTStruct + AnimateProc, HeapAlloc(GetProcessHeap(), 8, Len(Animate)))
		RtlMoveMemory(Peek(pTStruct + AnimateProc, 4), @Animate, Len(Animate))
		Poke(pTStruct + AnimateArgs, HeapAlloc(GetProcessHeap(), 8, Len(AnimateParams)))
		RtlMoveMemory(Peek(pTStruct + AnimateArgs, 4), @AnimateParams, Len(AnimateParams))
	Next
	DeleteDC(BmpDC)
	'===================================================
	' Set the main window style bits and display the picture
	'===================================================
	SetWindowLong(ME, GWL_STYLE, &H6000000)
	SetWindowLong(ME, GWL_EXSTYLE, &H200)
	Fbsl_SetText(ME, "Uriah Heep")
	Fbsl_Tile(ME, Fbsl_LoadImage(".\Rain.jpg"))
	'===================================================
	' Set the initial delay. Let the watcher catch a glimpse of the picture...
	' The delay will become shorter as the loop progresses.
	'===================================================
	SetTimer(ME, 1001, 2000)
	Resize(ME, 0, 0, 800, 533)
	Center(ME)
	Show(ME)
	'===================================================
	' Make drop positions alter each time the program starts
	'===================================================
	Randomize
	'===================================================
	' Run the thread launching loop
	'===================================================
	Begin Events
		Select Case CBMSG
			Case WM_TIMER
				Storm()
				Return 0
			Case WM_CLOSE, WM_LBUTTONDOWN, WM_RBUTTONDOWN
				CleanUp()
		End Select
	End Events
End Sub

Sub Storm()
	Dim %x, %y, %i, %j, %k, %Dummy
	'===================================================
	' Set the length of time the program runs
	'===================================================
	Static %Counter = 200
	'===================================================
	' Don't let tiles go off the window canvas
	'===================================================
	Dim $rct: Alloc(rct, 16): GetClientRect(ME, rct)
	Dim %WinX = GetMem(rct, 8, 4) - 100
	Dim %WinY = GetMem(rct, 12, 4) - 100
	Clean rct
	Static %Delay = 600
	For j = 0 To 9
		'==============================================
		' Exit the loop at a first vacant tile structure
		'==============================================
		If Not GetMem(TileStruct, j * 60 + Running, 4) Then Exit For
	Next
	'===================================================
	' A vacant tile structure has been found
	'===================================================
	If j < 10 Then
		'==============================================
		' Randomize the tile position
		'==============================================
		x = RandInt(0, WinX)
		y = RandInt(0, WinY)
		'==============================================
		' Check if this position interferes with any running thread.
		' If yes, tile interference occurs which prevents proper
		' original picture restoration.
		'==============================================
		For k = 0 To 9
			If GetMem(TileStruct, k * 60 + Running, 4) Then
				Dummy = k * 60 + XOffset
				If (x > GetMem(TileStruct, Dummy, 4) - 100) And (x < GetMem + 100) Then
					Dummy = k * 60 + YOffset
					If (y > GetMem(TileStruct, Dummy, 4) - 100) And (y < GetMem + 100) Then
						'========================
						' Interference: skip the rest of sub
						'========================
						Exit Sub
					End If
				End If
			End If
		Next
		'==============================================
		' No interference: start a new thread
		'==============================================
		Dummy = j * 60
		'==============================================
		' Fill in coordinate offsets and drop size
		'==============================================
		SetMetrics(Dummy, x, y)
		Incr(Dummy, @TileStruct)
		'==============================================
		' Blit the picture into the source bitmap
		'==============================================
		BlitSource(Dummy)
		'==============================================
		' Calculate the initial height map for the drop
		'==============================================
		CalcDrop(Dummy)
		'==============================================
		' Launch a new thread
		'==============================================
		Fbsl_ThreadResume(Fbsl_Thread(Peek(Dummy + AnimateProc, 4), Dummy))
	End If
	KillTimer(ME, 1001)
	Decr(Counter)
	If Not Counter Then
		PostMessage(ME, WM_CLOSE, 0, 0)
		Exit Sub
	End If
	'===================================================
	' Shorten the delay to make the drops fall faster
	'===================================================
	Decr(Delay, IIf(Delay > 50, 10, 0))
	SetTimer(ME, 1001, Delay)
End Sub

Sub SetMetrics(%Index, %x, %y)
	'===================================================
	' Set the 'Busy' flag to notify the Storm() loop that the thread is running
	'===================================================
	SetMem(TileStruct, TRUE, Index + Running)
	'===================================================
	' Store positional data
	'===================================================
	SetMem(TileStruct, x, Index + XOffset)
	SetMem(TileStruct, y, Index + YOffset)
	'===================================================
	' Randomize the drop strength
	'===================================================
	SetMem(TileStruct, RandInt(50, 200), Index + DropSize)
End Sub

Sub BlitSource(%pTStruct)
	'===================================================
	' Blit a part of the picture to the tile's original bitmap
	'===================================================
	Dim %BmpDC = CreateCompatibleDC(NULL)
	Dim %pOldBmp = SelectObject(BmpDC, Peek(pTStruct + SourceBitmap, 4))
	Dim %hDC = GetDC(ME)
	BitBlt(BmpDC, 0, 0, 100, 100, hDC, %Peek(pTStruct + XOffset, 4), %Peek(pTStruct + YOffset, 4), SRCCOPY)
	ReleaseDC(ME, hDC)
	SelectObject(BmpDC, pOldBmp)
	DeleteDC(BmpDC)
End Sub

Sub CalcDrop(%pTStruct)
	'===================================================
	' CalcDrop() rolls the peripheral bits into the central "drop" which will
	' further be unrolled into concentric circles by calls to Water()
	'===================================================
	Dim %Depth = Peek(pTStruct + DropSize, 4)
	Dim %Radius = Depth >> 3
	Dim %Distance
	Dim %CalcDepth
	Dim %i = 50, %j = i - Radius, %k = i + Radius, %l = Peek(pTStruct + FirstMap, 4), %m, %n, %o
	For m = j To k
		n = (m - i) ^ 2
		For o = j To k
			Distance = %SqRt((o - i) ^ 2 + n)
			If Distance < Radius Then
				CalcDepth = Depth * (Radius - Distance) \ Radius
				Poke(l + m * 100 + o, Chr(%CalcDepth))
			End If
		Next
	Next
End Sub

Sub CleanUp()
	Dim %pTStruct
	'===================================================
	' No more new threads in case a mouse button has been clicked
	'===================================================
	KillTimer(ME, 1001)
	'===================================================
	' Let the last threads complete drawing
	'===================================================
	Sleep(1500)
	'===================================================
	' Clean up the GDI stuff. Memory is released automatically when the
	' process exits.
	'===================================================
	For pTStruct = @TileStruct To @TileStruct + 540 Step 60
		DeleteObject(Peek(pTStruct + DropBitmap, 4))
		DeleteObject(Peek(pTStruct + SourceBitmap, 4))
	Next
	ExitProgram(0)
End Sub

And it works in combination with this JPG file :


Enjoy multithreading with FBSL!

[Shed]

Looks pretty nice and realistic Gerome....very cool 

[f0dder]

Would be nicer if it could be done without machine code - or even if FBSL just supported assembly instead of turbo pascal-style machine code blocks

[Cpilot]

Would be nicer if it could be done without machine code - or even if FBSL just supported assembly instead of turbo pascal-style machine code blocks

FBSL is pretty damn fast, it'll render openGL seamlessly.
I think Mike was just showing off a little. 

[f0dder]

Would be nicer if it could be done without machine code - or even if FBSL just supported assembly instead of turbo pascal-style machine code blocks

FBSL is pretty damn fast, it'll render openGL seamlessly.
I think Mike was just showing off a little. 

OpenGL depends on your video card and almost not on your CPU speed, so...

[Cpilot]

OpenGL depends on your video card and almost not on your CPU speed, so...

Fine ...it's still faster than you think, without the "asm" code.

[f0dder]

OpenGL depends on your video card and almost not on your CPU speed, so...

Fine ...it's still faster than you think, without the "asm" code.

I think you misunderstood me, btw - I'm not saying it isn't fast, just that the sample would be more interesting *without* the "byte blocks of machine code". If it was at assembly code instead, at least it would be readable. But it would be more interesting to see this with "native" FBSL code, still.

[Gothi[c]]

or even if FBSL just supported assembly instead of turbo pascal-style machine code blocks

FYI Turbo Pascal did have ASM blocks.

Code

PROCEDURE ShowMouse ; ASSEMBLER
ASM
  MOV AX,1
  INT 33
END;

BEGIN

ASM
  MOV AX,13
  INT 10h
END;

ShowMouse;

ASM
  @WAITCLICK:
  MOV AX,3
  INT 33
  CMP BX,0
  JE @WAITCLICK
END;

END.

Maybe you ment QBasic

[f0dder]

Yes, I know - iirc they added asm blocks in v6. Before that, only "inline machine code" was possible, which looked a lot like what FBSL does. Ie, something like...

Code

function getBP:word; inline($8b/$c5);

[Gerome]

Hello,

Yes, I know - iirc they added asm blocks in v6. Before that, only "inline machine code" was possible, which looked a lot like what FBSL does. Ie, something like...

Code

function getBP:word; inline($8b/$c5);

FBSL was not exclusively developped to have a structured ASM layer, that is why i've simply added the tweak to load and play 'pseudo asm code' on the fly.
Sincerely, I don't have planned other kinda ASM support into my language, the demo was aimed to see a pure and nice living sample, aka tears falling down to the water via Fbsl, nothing more...

And don't forget that FBSL is NOT compiled.