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

[Select]

'###########################################################################
'
'  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

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. 

-Cpilot (April 19, 2006, 06:41 AM)

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.

-Cpilot (April 19, 2006, 07:01 AM)

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.

[Select]

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

[Select]

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

[Select]

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

-f0dder (April 20, 2006, 04:15 AM)

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.