# PureBasic Forum

 It is currently Tue Sep 29, 2020 8:48 pm

 All times are UTC + 1 hour

 Page 1 of 2 [ 19 posts ] Go to page 1, 2  Next
 Print view Previous topic | Next topic
Author Message
 Post subject: Cheap Flames effectPosted: Tue May 15, 2018 9:23 pm
 Enthusiast

Joined: Thu Apr 30, 2009 5:23 pm
Posts: 328
Location: Côtes d'Azur, France
Inspired from here: https://web.archive.org/web/20160418004 ... m_fire.htm

Code:
;Perlin Noise 1D or 2D return a value between -1 and 1
;Reinit=1 => calcul new initial values
DisableDebugger
Procedure.f Noise(x.f,y.f=0.0,resolution.f=60.0,Reinit.i=0)
#unit = 0.7071067811865475244 ;=1.0/Sqr(2)
Static Dim perm.l(511)
Static.l x0,y0,ii,jj,gi0,gi1,gi2,gi3
Static.f tempX,tempY,s,t,u,v,tmp,Li1,Li2,Cx,Cy
If Reinit
For i=0 To 511
perm(i)=i & 255
Next i
RandomizeArray(perm())
ProcedureReturn
EndIf
x       = x/resolution
y       = y/resolution
x0    = Int(x)
y0    = Int(y)
ii    = x0 & 255
jj    = y0 & 255
gi0   = perm(ii +     perm(jj    )) % 8
gi1   = perm(ii + 1 + perm(jj    )) % 8
gi2   = perm(ii +     perm(jj + 1)) % 8
gi3   = perm(ii + 1 + perm(jj + 1)) % 8
tempX = x-x0
tempY = y-y0
tempX   = x-(x0+1)
tempY   = y-y0
tempX   = x-x0
tempY   = y-(y0+1)
tempX   = x-(x0+1)
tempY   = y-(y0+1)
tmp   = x-x0
Cx    = 3 * tmp * tmp - 2 * tmp * tmp * tmp
Li1   = s + Cx*(t-s)
Li2   = u + Cx*(v-u)
tmp     = y - y0;
Cy    = 3 * tmp * tmp - 2 * tmp * tmp * tmp;
ProcedureReturn Li1 + Cy*(Li2-Li1)
EndProcedure

#X=600:#Y=400:#mouse=0
If InitSprite() = 0 Or InitKeyboard() = 0 Or InitMouse() = 0 Or OpenWindow(0, 0, 0, #X, #Y, "Fire", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)=0 Or OpenWindowedScreen(WindowID(0),0,0,#X,#Y,0,0,0,#PB_Screen_NoSynchronization )=0
MessageRequester("Error", "Can't open the sprite system", 0)
End
EndIf
Dim Buffer.i(#X,#Y*2)
Dim coolingmap(#x,#y)

;create cooling map
noise(0,0,0,1)
For j=0 To #Y-1
For i=0 To #X-1
coolingmap(i,j)=Int(noise(i,j)+1)
Next i
Next j

;create mouse sprite
CreateSprite(#mouse,16,16)
StartDrawing(SpriteOutput(#mouse))
Box(0,0,16,16,\$FFFFFF)
Box(4,4,8,8,\$0)
StopDrawing()

;{ Fire color
Dim color.l(255)
pR.f=90
pG.f=0
pB.f=12
For i=0 To 80
;90;0;12
r.f=i*pR/80
g.f=pG
b.f=i*pB/80
color(i)=RGB(r,g,b)
Next i
#deb=81
#fin=140
For i=#deb To #fin
j=i-#deb
;255;144;0
r.f=pR+j*(255-pR)/(#fin-#deb)
g.f=pG+j*(144-pG)/(#fin-#deb)
b.f=pB+j*(0-pB)/(#fin-#deb)
color(i)=RGB(r,g,b)
Next i
#deb3=141
#fin3=220
pR=255:pG=144:pB=0
For i=#deb3 To #fin3
j=i-#deb3
;255;187;0
r.f=pR+j*(255-pR)/(#fin3-#deb3)
g.f=pG+j*(187-pG)/(#fin3-#deb3)
b.f=pB+j*(0-pB)/(#fin3-#deb3)
color(i)=RGB(r,g,b)
Next i

#deb4=221
#fin4=255
pR=255:pG=187:pB=0
For i=#deb4 To #fin4
j=i-#deb4
;255;255;211
r.f=pR+j*(255-pR)/(#fin4-#deb4)
g.f=pG+j*(255-pG)/(#fin4-#deb4)
b.f=pB+j*(211-pB)/(#fin4-#deb4)
color(i)=RGB(r,g,b)
Next i
;}

Buf1=0
Repeat
While WindowEvent():Wend
FlipBuffers()
ExamineKeyboard()
ExamineMouse()
If MouseButton(#PB_MouseButton_Left)
For i=1 To 14
For j=1 To 14
If MouseX()+i>#X-2 Or MouseY()+j>#Y-2:Continue:EndIf
buffer(MouseX()+i,MouseY()+j+buf1)=255
buffer(MouseX()+i,MouseY()+j+buf1!#Y)=255
Next j
Next i
EndIf
For i=0 To #X-1
For j=1 To 3
Buffer(i,#Y-j+Buf1)=255
Next j
Next i

For j=1 To #Y-2
For i=1 To #X-2
Buffer(i,j+Buf1-1)=(Buffer(i,j+Buf1-1)+Buffer(i-1,j+Buf1)+Buffer(i+1,j+Buf1)+Buffer(i,j+Buf1+1))/4
Buffer(i,j+Buf1-1)-coolingmap(i,(j+scrollY)%#Y)
If buffer(i,j+Buf1-1)<0:buffer(i,j+Buf1-1)=0:EndIf
Next i
Next j

StartDrawing(ScreenOutput())
For j=0 To #Y-1
For i=0 To #X-1
Plot(i,j,color(buffer(i,j+Buf1)))
Next i
Next j
DrawText(0,0,"[Escape] to Quit")
DrawText(0,20,"[Left clic] to start a fire")
StopDrawing()

DisplayTransparentSprite(#mouse,MouseX(),MouseY())

;swap buffers
Buf1!#Y
scrollY+1
Until KeyboardPushed(#PB_Key_Escape)

_________________
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS

Last edited by Fig on Wed May 16, 2018 8:31 pm, edited 10 times in total.

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 6:09 am
 PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3673
Location: Netherlands
Looks nice
The only thing is that the cpu load is very high.

_________________
macOS 10.15 Catalina, Windows 10

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 6:21 am

Joined: Mon Feb 16, 2015 2:49 pm
Posts: 1907
Only does 25% CPU here?

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 6:31 am
 PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3673
Location: Netherlands
Dude wrote:
Only does 25% CPU here?

It only uses one core.
You probably have a quad core system so the total load can't exceed 25%.

_________________
macOS 10.15 Catalina, Windows 10

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 8:54 am
 Enthusiast

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 766
Location: Nottinghamshire UK
Well that`s a first Every time I run this example (win 10 pro x64 build 1803). Only Thing I`ve done recently I can think of is that I have encrypted the drive with BitLocker (full drive new version)
Anyone else with this problem ? very strange indeed!

Zebuddi.

_________________
malleo, caput, bang. Ego, comprehendunt in tempore

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 10:37 am

Joined: Fri Nov 09, 2012 11:04 pm
Posts: 1780
Location: Uttoxeter, UK
@Zebuddi123,
I'm using Windows 10 build 1803 on a nonencrypted drive.
I get the same error on the first line of code, with or without the debugger.

_________________
DE AA EB

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 5:52 pm
 PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3673
Location: Netherlands
davido wrote:
@Zebuddi123,
I'm using Windows 10 build 1803 on a nonencrypted drive.
I get the same error on the first line of code, with or without the debugger.

When I compile with debugger on, I also get this error.
It looks like a bug having to do with the two Static arrays inside the procedure.
If I take one of them out and make it Global, it doesn't crash anymore on my computer.

Code:
DisableDebugger
Procedure.f Noise(x.f,y.f=0.0,resolution.f=70.0,Reinit.i=0)
#unit = 0.7071067811865475244 ;=1.0/Sqr(2)
Static Dim perm.l(511)
Static.l x0,y0,ii,jj,gi0,gi1,gi2,gi3
Static.f tempX,tempY,s,t,u,v,tmp,Li1,Li2,Cx,Cy

or
Code:
DisableDebugger
Global Dim perm.l(511)
Procedure.f Noise(x.f,y.f=0.0,resolution.f=70.0,Reinit.i=0)
#unit = 0.7071067811865475244 ;=1.0/Sqr(2)
Static.l x0,y0,ii,jj,gi0,gi1,gi2,gi3
Static.f tempX,tempY,s,t,u,v,tmp,Li1,Li2,Cx,Cy

Isolated problem (crashes on PB MacOS, x64)
Code:
Procedure Test()
Static Dim A.i(1,1)
Static Dim B.i(1)
EndProcedure

_________________
macOS 10.15 Catalina, Windows 10

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 6:34 pm
 Enthusiast

Joined: Thu Apr 30, 2009 5:23 pm
Posts: 328
Location: Côtes d'Azur, France
Update, I colored the fire.

Is it really a bug, should I report it ?

_________________
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 7:14 pm
 Enthusiast

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 766
Location: Nottinghamshire UK
@Wilbert Hi. just testing your observations and it seems that using a multi-dimensional array as the first array trigger IMA. swap the arrays around and it works so probably a bug. came you confirm ?

Zebuddi.

_________________
malleo, caput, bang. Ego, comprehendunt in tempore

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 7:29 pm
 PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3673
Location: Netherlands
Zebuddi123 wrote:
@Wilbert Hi. just testing your observations and it seems that using a multi-dimensional array as the first array trigger IMA. swap the arrays around and it works so probably a bug. came you confirm ?

Yes, I can confirm that !

So @Fig, there is a bug on x64 both on Windows and Mac which is good to report but as Zebuddi mentioned, you can work around it by swapping the two array declarations in your source code.
Code:
Static Dim perm.l(511)

_________________
macOS 10.15 Catalina, Windows 10

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 7:38 pm

Joined: Fri Nov 09, 2012 11:04 pm
Posts: 1780
Location: Uttoxeter, UK
@wilbert,
Nice find. I'm impressed.

@Fig,
Works fine, now. Looks very nice, thank you.

_________________
DE AA EB

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 8:02 pm
 Enthusiast

Joined: Thu Apr 30, 2009 5:23 pm
Posts: 328
Location: Côtes d'Azur, France
Updated code. Add possibility to write in fire ink...

Thank you all !

_________________
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS

Top

 Post subject: Re: Cheap Flames effectPosted: Wed May 16, 2018 8:51 pm
 Enthusiast

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 766
Location: Nottinghamshire UK
Hi Fig nice I like playing around with these types of code, not pretending i understand it all lol but I like to stick random values & operators in and see what happens. its the child in me.

But on a more serious note, this could be made into a nice text logo based fire filter (ie gimp type filter)

Zebuddi.

_________________
malleo, caput, bang. Ego, comprehendunt in tempore

Top

 Post subject: Re: Cheap Flames effectPosted: Thu May 17, 2018 6:10 am

Joined: Thu Feb 09, 2006 11:27 pm
Posts: 2549
The following pascal code is from a time capsule (MS-DOS time era) - you may be able to see the (smaller) flames using Borland Pascal on DosBox:

Code:
program flames;

const pal : array[0..255,1..3] of byte=
(( 0, 0, 0), ( 0, 0, 6), ( 0, 0, 6), ( 0, 0, 7), ( 0, 0, 8), ( 0, 0, 8), ( 0, 0, 9), ( 0, 0,10),
( 2, 0,10), ( 4, 0, 9), ( 6, 0, 9), ( 8, 0, 8), (10, 0, 7), (12, 0, 7), (14, 0, 6), (16, 0, 5),
(18, 0, 5), (20, 0, 4), (22, 0, 4), (24, 0, 3), (26, 0, 2), (28, 0, 2), (30, 0, 1), (32, 0, 0),
(32, 0, 0), (33, 0, 0), (34, 0, 0), (35, 0, 0), (36, 0, 0), (36, 0, 0), (37, 0, 0), (38, 0, 0),
(39, 0, 0), (40, 0, 0), (40, 0, 0), (41, 0, 0), (42, 0, 0), (43, 0, 0), (44, 0, 0), (45, 0, 0),
(46, 1, 0), (47, 1, 0), (48, 2, 0), (49, 2, 0), (50, 3, 0), (51, 3, 0), (52, 4, 0), (53, 4, 0),
(54, 5, 0), (55, 5, 0), (56, 6, 0), (57, 6, 0), (58, 7, 0), (59, 7, 0), (60, 8, 0), (61, 8, 0),
(63, 9, 0), (63, 9, 0), (63,10, 0), (63,10, 0), (63,11, 0), (63,11, 0), (63,12, 0), (63,12, 0),
(63,13, 0), (63,13, 0), (63,14, 0), (63,14, 0), (63,15, 0), (63,15, 0), (63,16, 0), (63,16, 0),
(63,17, 0), (63,17, 0), (63,18, 0), (63,18, 0), (63,19, 0), (63,19, 0), (63,20, 0), (63,20, 0),
(63,21, 0), (63,21, 0), (63,22, 0), (63,22, 0), (63,23, 0), (63,24, 0), (63,24, 0), (63,25, 0),
(63,25, 0), (63,26, 0), (63,26, 0), (63,27, 0), (63,27, 0), (63,28, 0), (63,28, 0), (63,29, 0),
(63,29, 0), (63,30, 0), (63,30, 0), (63,31, 0), (63,31, 0), (63,32, 0), (63,32, 0), (63,33, 0),
(63,33, 0), (63,34, 0), (63,34, 0), (63,35, 0), (63,35, 0), (63,36, 0), (63,36, 0), (63,37, 0),
(63,38, 0), (63,38, 0), (63,39, 0), (63,39, 0), (63,40, 0), (63,40, 0), (63,41, 0), (63,41, 0),
(63,42, 0), (63,42, 0), (63,43, 0), (63,43, 0), (63,44, 0), (63,44, 0), (63,45, 0), (63,45, 0),
(63,46, 0), (63,46, 0), (63,47, 0), (63,47, 0), (63,48, 0), (63,48, 0), (63,49, 0), (63,49, 0),
(63,50, 0), (63,50, 0), (63,51, 0), (63,52, 0), (63,52, 0), (63,52, 0), (63,52, 0), (63,52, 0),
(63,53, 0), (63,53, 0), (63,53, 0), (63,53, 0), (63,54, 0), (63,54, 0), (63,54, 0), (63,54, 0),
(63,54, 0), (63,55, 0), (63,55, 0), (63,55, 0), (63,55, 0), (63,56, 0), (63,56, 0), (63,56, 0),
(63,56, 0), (63,57, 0), (63,57, 0), (63,57, 0), (63,57, 0), (63,57, 0), (63,58, 0), (63,58, 0),
(63,58, 0), (63,58, 0), (63,59, 0), (63,59, 0), (63,59, 0), (63,59, 0), (63,60, 0), (63,60, 0),
(63,60, 0), (63,60, 0), (63,60, 0), (63,61, 0), (63,61, 0), (63,61, 0), (63,61, 0), (63,62, 0),
(63,62, 0), (63,62, 0), (63,62, 0), (63,63, 0), (63,63, 1), (63,63, 2), (63,63, 3), (63,63, 4),
(63,63, 5), (63,63, 6), (63,63, 7), (63,63, 8), (63,63, 9), (63,63,10), (63,63,10), (63,63,11),
(63,63,12), (63,63,13), (63,63,14), (63,63,15), (63,63,16), (63,63,17), (63,63,18), (63,63,19),
(63,63,20), (63,63,21), (63,63,21), (63,63,22), (63,63,23), (63,63,24), (63,63,25), (63,63,26),
(63,63,27), (63,63,28), (63,63,29), (63,63,30), (63,63,31), (63,63,31), (63,63,32), (63,63,33),
(63,63,34), (63,63,35), (63,63,36), (63,63,37), (63,63,38), (63,63,39), (63,63,40), (63,63,41),
(63,63,42), (63,63,42), (63,63,43), (63,63,44), (63,63,45), (63,63,46), (63,63,47), (63,63,48),
(63,63,49), (63,63,50), (63,63,51), (63,63,52), (63,63,52), (63,63,53), (63,63,54), (63,63,55),
(63,63,56), (63,63,57), (63,63,58), (63,63,59), (63,63,60), (63,63,61), (63,63,62), (63,63,63));

var f   : array[0..102,0..159] of integer;
i,j : word;

function doit:word; assembler;
asm                 {output to screen}
mov si,offset f
mov ax,0a000h
mov es,ax
mov di,0
mov dx,100
@3:   mov bx,2
@2:   mov cx,160
@1:   mov al,[si]
mov ah,al
mov es:[di],ax     {word aligned write to display mem}
dec cx
jnz @1

sub si,320
dec bx
jnz @2

dec dx
jnz @3

mov ah,01h       { Taste im Puffer ? }
int 16h
mov ax,0h        { Returnwert = 0 }
je  @weiter

@clrkey:          { Taste(n) l”schen }
xor ah,ah
int 16h
mov ah,01h
int 16h
jne @clrkey

mov ax,03h       { Textmodus }
int 10h
mov ax,099       { Returnwert <> 0 }

@weiter:
end;

begin

asm
mov ax,13h      { Graphik-Modus und Palette setzen... }
int 10h

mov si,offset pal
mov cx,768      {no of colour registers}
mov dx,03c8h
xor al,al     {First colour to change pal for = 0}
out dx,al
inc dx
@7: outsb
dec cx        {safer than rep outsb}
jnz @7
end;

for i:=0 to 102 do
for j:=0 to 159 do
f[i,j]:=0;         {initialise array}

repeat
asm                {move lines up, averaging}
mov cx,16159; {no. elements to change}
mov di,offset f
add di,320       {di points to 1. el. of f in upper row (320 byte/row) }
@1:   mov ax,ds:[di-2]
shr ax,2         {divide by 4: average 4 elements of f}
jz @2
sub ax,1
@2:   mov word ptr ds:[di-320],ax
dec cx
jnz @1    {faster than _loop_ on 486}
end;

for j:=0 to 159 do  {set new bottom line}
begin
case random(10) of
0..2 : begin f[101,j]:=  0; f[102,j]:=  0; end;
3..4 : begin f[101,j]:=255; f[102,j]:=255; end;
end;
end;

until doit<>0;

end.

Top

 Post subject: Re: Cheap Flames effectPosted: Thu May 17, 2018 6:19 am
 PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3673
Location: Netherlands
Fig wrote:
Updated code. Add possibility to write in fire ink...

Looking at the code, I don't understand why you need two buffers.
The buffers don't seem to interact with each other

_________________
macOS 10.15 Catalina, Windows 10

Top

 Display posts from previous: All posts1 day7 days2 weeks1 month3 months6 months1 year Sort by AuthorPost timeSubject AscendingDescending
 Page 1 of 2 [ 19 posts ] Go to page 1, 2  Next

 All times are UTC + 1 hour

#### Who is online

Users browsing this forum: No registered users and 7 guests

 You cannot post new topics in this forumYou cannot reply to topics in this forumYou cannot edit your posts in this forumYou cannot delete your posts in this forum

Search for:
 Jump to:  Select a forum ------------------ PureBasic    Coding Questions    Game Programming    3D Programming    Assembly Programming    The PureBasic Editor    The PureBasic Form Designer    General Discussion    Feature Requests and Wishlists    Tricks 'n' Tips Bug Reports    Bugs - Windows    Bugs - Linux    Bugs - Mac OSX    Bugs - IDE    Bugs - Documentation OS Specific    AmigaOS    Linux    Windows    Mac OSX Miscellaneous    Announcement    Off Topic Showcase    Applications - Feedback and Discussion    PureFORM & JaPBe    TailBite