Cheap Flames effect

Advanced game related topics
User avatar
Fig
Enthusiast
Enthusiast
Posts: 351
Joined: Thu Apr 30, 2009 5:23 pm
Location: Côtes d'Azur, France

Cheap Flames effect

Post by Fig »

Inspired from here: https://web.archive.org/web/20160418004 ... m_fire.htm

Image

Code: Select all

;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 Dim gradient2.f(7,1)
    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
        gradient2(0,0)= #unit:gradient2(0,1)= #unit
        gradient2(1,0)=-#unit:gradient2(1,1)= #unit
        gradient2(2,0)= #unit:gradient2(2,1)=-#unit
        gradient2(3,0)=-#unit:gradient2(3,1)=-#unit
        gradient2(4,0)= 1:   gradient2(4,1)= 0
        gradient2(5,0)=-1:   gradient2(5,1)= 0
        gradient2(6,0)= 0:   gradient2(6,1)= 1
        gradient2(7,0)= 0:   gradient2(7,1)=-1
        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
    s     = gradient2(gi0,0)*tempX + gradient2(gi0,1)*tempY    
    tempX   = x-(x0+1)
    tempY   = y-y0
    t     = gradient2(gi1,0)*tempX + gradient2(gi1,1)*tempY
    tempX   = x-x0
    tempY   = y-(y0+1)
    u     = gradient2(gi2,0)*tempX + gradient2(gi2,1)*tempY
    tempX   = x-(x0+1)
    tempY   = y-(y0+1)
    v     = gradient2(gi3,0)*tempX + gradient2(gi3,1)*tempY    
    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)
Last edited by Fig on Wed May 16, 2018 8:31 pm, edited 10 times in total.
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: Cheap Flames effect

Post by wilbert »

Looks nice :)
The only thing is that the cpu load is very high.
Windows (x64)
Raspberry Pi OS (Arm64)
Dude
Addict
Addict
Posts: 1907
Joined: Mon Feb 16, 2015 2:49 pm

Re: Cheap Flames effect

Post by Dude »

Only does 25% CPU here?
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: Cheap Flames effect

Post by wilbert »

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%.
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
Zebuddi123
Enthusiast
Enthusiast
Posts: 794
Joined: Wed Feb 01, 2012 3:30 pm
Location: Nottinghamshire UK
Contact:

Re: Cheap Flames effect

Post by Zebuddi123 »

Well that`s a first :shock: 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.

Image
malleo, caput, bang. Ego, comprehendunt in tempore
davido
Addict
Addict
Posts: 1890
Joined: Fri Nov 09, 2012 11:04 pm
Location: Uttoxeter, UK

Re: Cheap Flames effect

Post by davido »

@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
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: Cheap Flames effect

Post by wilbert »

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: Select all

DisableDebugger
Global Dim gradient2.f(7,1)
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: Select all

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 Dim gradient2.f(7,1)
    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: Select all

Procedure Test()
  Static Dim A.i(1,1)
  Static Dim B.i(1)
EndProcedure
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
Fig
Enthusiast
Enthusiast
Posts: 351
Joined: Thu Apr 30, 2009 5:23 pm
Location: Côtes d'Azur, France

Re: Cheap Flames effect

Post by Fig »

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
User avatar
Zebuddi123
Enthusiast
Enthusiast
Posts: 794
Joined: Wed Feb 01, 2012 3:30 pm
Location: Nottinghamshire UK
Contact:

Re: Cheap Flames effect

Post by Zebuddi123 »

@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
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: Cheap Flames effect

Post by wilbert »

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: Select all

    Static Dim perm.l(511)
    Static Dim gradient2.f(7,1)
Windows (x64)
Raspberry Pi OS (Arm64)
davido
Addict
Addict
Posts: 1890
Joined: Fri Nov 09, 2012 11:04 pm
Location: Uttoxeter, UK

Re: Cheap Flames effect

Post by davido »

@wilbert,
Nice find. I'm impressed.

@Fig,
Works fine, now. Looks very nice, thank you.
DE AA EB
User avatar
Fig
Enthusiast
Enthusiast
Posts: 351
Joined: Thu Apr 30, 2009 5:23 pm
Location: Côtes d'Azur, France

Re: Cheap Flames effect

Post by Fig »

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
User avatar
Zebuddi123
Enthusiast
Enthusiast
Posts: 794
Joined: Wed Feb 01, 2012 3:30 pm
Location: Nottinghamshire UK
Contact:

Re: Cheap Flames effect

Post by Zebuddi123 »

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. :lol: 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
User avatar
Michael Vogel
Addict
Addict
Posts: 2666
Joined: Thu Feb 09, 2006 11:27 pm
Contact:

Re: Cheap Flames effect

Post by Michael Vogel »

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: Select all

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}
      add di,2
      add si,2
      dec cx
      jnz @1

      sub si,320
      dec bx
      jnz @2

      add si,320
      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]
      add ax,ds:[di]
      add ax,ds:[di+2]
      add ax,ds:[di+320]
      shr ax,2         {divide by 4: average 4 elements of f}
      jz @2
      sub ax,1
@2:   mov word ptr ds:[di-320],ax
      add di,2
      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.

wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: Cheap Flames effect

Post by wilbert »

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 :?
Windows (x64)
Raspberry Pi OS (Arm64)
Post Reply