It is currently Sun Dec 16, 2018 9:50 am

All times are UTC + 1 hour




Post new topic Reply to topic  [ 19 posts ]  Go to page 1, 2  Next
Author Message
 Post subject: Cheap Flames effect
PostPosted: Tue May 15, 2018 9:23 pm 
Offline
Enthusiast
Enthusiast
User avatar

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

Image

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

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

Win10, Pb x86 5.62


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

Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 6:09 am 
Offline
PureBasic Expert
PureBasic Expert

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

_________________
macOS 10.14 Mojave, PB 5.62 x64


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 6:21 am 
Offline
Addict
Addict

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


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 6:31 am 
Offline
PureBasic Expert
PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3268
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.14 Mojave, PB 5.62 x64


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 8:54 am 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 695
Location: Nottinghamshire UK
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 10:37 am 
Offline
Addict
Addict

Joined: Fri Nov 09, 2012 11:04 pm
Posts: 1603
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
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 5:52 pm 
Offline
PureBasic Expert
PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3268
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
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:
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:
Procedure Test()
  Static Dim A.i(1,1)
  Static Dim B.i(1)
EndProcedure

_________________
macOS 10.14 Mojave, PB 5.62 x64


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 6:34 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Apr 30, 2009 5:23 pm
Posts: 288
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 x86 5.62


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 7:14 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 695
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
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 7:29 pm 
Offline
PureBasic Expert
PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3268
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)
    Static Dim gradient2.f(7,1)

_________________
macOS 10.14 Mojave, PB 5.62 x64


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 7:38 pm 
Offline
Addict
Addict

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

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

_________________
DE AA EB


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 8:02 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Apr 30, 2009 5:23 pm
Posts: 288
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 x86 5.62


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Wed May 16, 2018 8:51 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Wed Feb 01, 2012 3:30 pm
Posts: 695
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. :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


Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Thu May 17, 2018 6:10 am 
Offline
Addict
Addict
User avatar

Joined: Thu Feb 09, 2006 11:27 pm
Posts: 2354
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}
      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.



Top
 Profile  
Reply with quote  
 Post subject: Re: Cheap Flames effect
PostPosted: Thu May 17, 2018 6:19 am 
Offline
PureBasic Expert
PureBasic Expert

Joined: Sun Aug 08, 2004 5:21 am
Posts: 3268
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.14 Mojave, PB 5.62 x64


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 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 5 guests


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

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye