/code/ Визуальный эффект огня на форме

[jangle]

Автор Bryan Flick, в аттаче скомпилированная версия:

Код: Выделить всё

'====================================================================
'
' Simple fire
'
'====================================================================
#Compile Exe
#Dim All
#Include "WIN32API.INC"
%IDC_GRAPHIC = 110
Declare Sub InitFire()
Declare Sub DrawFire(ByVal hBMP As Dword, sBMP As String)
Global Palette() As Dword
'
' Program entry point
'
Function PBMain () As Long
Local hDlg, hBMP As Dword, sBMP As String
Local w, h, Count As Long, CT!
' Initialize a dialog with a pixel-based coordinate system
Dialog New Pixels, 0, "Fire",,, 640, 480, _
%WS_CAPTION Or %WS_SYSMENU, _
%WS_EX_TOOLWINDOW Or %WS_EX_TOPMOST To hDlg
' Initialize a Graphic control
Control Add Graphic, hDlg, %IDC_GRAPHIC, "", 0, 0, 640, 480
Graphic Attach hDlg, %IDC_GRAPHIC, ReDraw
Graphic Clear %Black
' Initialize a bitmap
' GRAPHIC BITMAP NEW 128, 128 TO hBMP
Graphic Bitmap New 640, 480 To hBMP
Graphic Attach hBMP, 0, ReDraw
Graphic Clear %Black
Graphic Get Bits To sBMP
' Initialize the palette
InitFire
' Show dialog as a modeless dialog
Dialog Show Modeless hDlg, Call DlgProc
' Main loop
Do
' Render the fire
CT!=Timer
DrawFire hBMP, sBMP
' Blit the bitmap to the window
Graphic Attach hDlg, %IDC_GRAPHIC , ReDraw
' GRAPHIC STRETCH hBMP, 0, (0, 0)-(127, 127) TO (0, 0)-(639, 479)
Graphic Stretch hBMP, 0, (0, 0)-(639, 479) To (0, 0)-(639, 479)
Graphic ReDraw
' Handle the dialog's message pump
'DIALOG SET TEXT hDlg, STR$(INT((TIMER-CT!)*1000)/1000)+" seconds per Frame"
Dialog DoEvents 0 To Count
Loop While Count
Graphic Attach hBMP, 0
Graphic Bitmap End
End Function
'
' Main dialog callback procedure
'
CallBack Function DlgProc () As Long
Select Case CbMsg
Case %WM_INITDIALOG
Case %WM_COMMAND
Select Case CbCtl
Case %IDCANCEL
If CbCtlMsg = %BN_CLICKED Or CbCtlMsg = 1 Then
Dialog End CbHndl, 0
End If
End Select
End Select
End Function
'
' Initialize the fire
'
Sub InitFire()
Local i, nCount As Long, r, g, b As Byte
' Initialize our fire palette
Dim Palette(255)
nCount = 1
For i = 0 To 255
r = Val(Read$(nCount)) * 4: Incr nCount
g = Val(Read$(nCount)) * 4: Incr nCount
b = Val(Read$(nCount)) * 4: Incr nCount
Palette(i) = Bgr(RGB(r, g, b))
Next i
' The fire palette
Data 0, 0, 0, 0, 0, 6, 0, 0, 6, 0, 0, 7, 0, 0, 8, 0, 0, 8, 0, 0, 9, 0, 0,10
Data 2, 0,10, 4, 0, 9, 6, 0, 9, 8, 0, 8,10, 0, 7,12, 0, 7,14, 0, 6,16, 0, 5
Data 18, 0, 5,20, 0, 4,22, 0, 4,24, 0, 3,26, 0, 2,28, 0, 2,30, 0, 1,32, 0, 0
Data 32, 0, 0,33, 0, 0,34, 0, 0,35, 0, 0,36, 0, 0,36, 0, 0,37, 0, 0,38, 0, 0
Data 39, 0, 0,40, 0, 0,40, 0, 0,41, 0, 0,42, 0, 0,43, 0, 0,44, 0, 0,45, 0, 0
Data 46, 1, 0,47, 1, 0,48, 2, 0,49, 2, 0,50, 3, 0,51, 3, 0,52, 4, 0,53, 4, 0
Data 54, 5, 0,55, 5, 0,56, 6, 0,57, 6, 0,58, 7, 0,59, 7, 0,60, 8, 0,61, 8, 0
Data 63, 9, 0,63, 9, 0,63,10, 0,63,10, 0,63,11, 0,63,11, 0,63,12, 0,63,12, 0
Data 63,13, 0,63,13, 0,63,14, 0,63,14, 0,63,15, 0,63,15, 0,63,16, 0,63,16, 0
Data 63,17, 0,63,17, 0,63,18, 0,63,18, 0,63,19, 0,63,19, 0,63,20, 0,63,20, 0
Data 63,21, 0,63,21, 0,63,22, 0,63,22, 0,63,23, 0,63,24, 0,63,24, 0,63,25, 0
Data 63,25, 0,63,26, 0,63,26, 0,63,27, 0,63,27, 0,63,28, 0,63,28, 0,63,29, 0
Data 63,29, 0,63,30, 0,63,30, 0,63,31, 0,63,31, 0,63,32, 0,63,32, 0,63,33, 0
Data 63,33, 0,63,34, 0,63,34, 0,63,35, 0,63,35, 0,63,36, 0,63,36, 0,63,37, 0
Data 63,38, 0,63,38, 0,63,39, 0,63,39, 0,63,40, 0,63,40, 0,63,41, 0,63,41, 0
Data 63,42, 0,63,42, 0,63,43, 0,63,43, 0,63,44, 0,63,44, 0,63,45, 0,63,45, 0
Data 63,46, 0,63,46, 0,63,47, 0,63,47, 0,63,48, 0,63,48, 0,63,49, 0,63,49, 0
Data 63,50, 0,63,50, 0,63,51, 0,63,52, 0,63,52, 0,63,52, 0,63,52, 0,63,52, 0
Data 63,53, 0,63,53, 0,63,53, 0,63,53, 0,63,54, 0,63,54, 0,63,54, 0,63,54, 0
Data 63,54, 0,63,55, 0,63,55, 0,63,55, 0,63,55, 0,63,56, 0,63,56, 0,63,56, 0
Data 63,56, 0,63,57, 0,63,57, 0,63,57, 0,63,57, 0,63,57, 0,63,58, 0,63,58, 0
Data 63,58, 0,63,58, 0,63,59, 0,63,59, 0,63,59, 0,63,59, 0,63,60, 0,63,60, 0
Data 63,60, 0,63,60, 0,63,60, 0,63,61, 0,63,61, 0,63,61, 0,63,61, 0,63,62, 0
Data 63,62, 0,63,62, 0,63,62, 0,63,63, 0,63,63, 1,63,63, 2,63,63, 3,63,63, 4
Data 63,63, 5,63,63, 6,63,63, 7,63,63, 8,63,63, 9,63,63,10,63,63,10,63,63,11
Data 63,63,12,63,63,13,63,63,14,63,63,15,63,63,16,63,63,17,63,63,18,63,63,19
Data 63,63,20,63,63,21,63,63,21,63,63,22,63,63,23,63,63,24,63,63,25,63,63,26
Data 63,63,27,63,63,28,63,63,29,63,63,30,63,63,31,63,63,31,63,63,32,63,63,33
Data 63,63,34,63,63,35,63,63,36,63,63,37,63,63,38,63,63,39,63,63,40,63,63,41
Data 63,63,42,63,63,42,63,63,43,63,63,44,63,63,45,63,63,46,63,63,47,63,63,48
Data 63,63,49,63,63,50,63,63,51,63,63,52,63,63,52,63,63,53,63,63,54,63,63,55
Data 63,63,56,63,63,57,63,63,58,63,63,59,63,63,60,63,63,61,63,63,62,63,63,63
End Sub
'
' Render the fire
'
Sub DrawFire(ByVal hBMP As Dword, sBMP As String)
Static InitYet As Long, RndSeed As Dword, Fire() As Byte
Local i As Long, col As Byte, vAddr As Dword Ptr
If IsFalse InitYet Then
' Seed our random # generator
RndSeed = &H1234
' Create a 640x480 "map", with an extra 640 bytes at the bottom
Dim Fire(307839)
' Only run this section of code once!
InitYet = %TRUE
End If
' Place some "fuel for the fire" at the bottom of the map
vAddr = VarPtr(fire(0)) + 640 * 480
! push ebx
! mov ax, RndSeed
! mov ebx, vaddr
! mov ecx, 640
newline:
! mov dx, &h8405
! mul dx
! inc ax
! mov [ebx], dl
! inc ebx
! loop newline
! mov RndSeed, ax
! pop ebx
' Now soften the values in the map, creating a fire effect
vAddr = VarPtr(fire(0)) + 640
! push ebx
! mov ebx, vaddr
! mov ecx, 307199
fireloop:
! xor ax, ax
! xor dh, dh
! mov al, [ebx]
! mov dl, [ebx + 1]
! add ax, dx
! mov dl, [ebx - 1]
! add ax, dx
! mov dl, [ebx + 640]
! add ax, dx
! shr ax, 2
! jz zero
! dec ax
zero:
! mov [ebx - 640], al
! inc ebx
! dec ecx
! jnz fireloop
! pop ebx
' Use fast buffered draw
Graphic Attach hBMP, 0, ReDraw
' Point to the bitmap
vAddr = StrPtr(sBMP) + 8
' Convert the map into a bitmap
For i = 0 To 307199
col = Fire(i)
@vAddr = Palette(col)
Incr vAddr
Next i
' Save the bitmap
Graphic Set Bits sBMP
End Sub