PureBasic Forums - English

Posted: **Tue May 15, 2018 9:23 pm**

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

;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)

Posted: **Wed May 16, 2018 6:09 am**

Looks nice

The only thing is that the cpu load is very high.

Posted: **Wed May 16, 2018 6:21 am**

Only does 25% CPU here?

Posted: **Wed May 16, 2018 6:31 am**

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

Posted: **Wed May 16, 2018 8:54 am**

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.

Posted: **Wed May 16, 2018 10:37 am**

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

Posted: **Wed May 16, 2018 5:52 pm**

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

Posted: **Wed May 16, 2018 6:34 pm**

Update, I colored the fire.

Is it really a bug, should I report it ?

Posted: **Wed May 16, 2018 7:14 pm**

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

Posted: **Wed May 16, 2018 7:29 pm**

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)

Posted: **Wed May 16, 2018 7:38 pm**

@wilbert,
Nice find. I'm impressed.

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

Posted: **Wed May 16, 2018 8:02 pm**

Updated code. Add possibility to write in fire ink...

Thank you all !

Posted: **Wed May 16, 2018 8:51 pm**

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.

Posted: **Thu May 17, 2018 6:10 am**

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.

Posted: **Thu May 17, 2018 6:19 am**

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

PureBasic Forums - English

Cheap Flames effect

Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect

Re: Cheap Flames effect