Other Software > Developer's Corner

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

(1/2) > >>

Gerome:
Hello,

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

Water _Effect_Demo.fbs
--- ---'###########################################################################
'
'  Original Name: Tears.fbs
'             Author: Mike Lobko-Lobanovsky ([email protected])
' 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
--- End quote ---
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
--- End quote ---
FBSL is pretty damn fast, it'll render openGL seamlessly.
I think Mike was just showing off a little.  :-\
-Cpilot (April 19, 2006, 06:41 AM)
--- End quote ---
OpenGL depends on your video card and almost not on your CPU speed, so... :)

Navigation

[0] Message Index

[#] Next page