Flames in FTN95

module flames
  use mswin
  implicit none

  integer, parameter :: width = 800, height = 200

  type rgb_type
    integer R
    integer G
    integer B
  end type rgb_type

  type hsv_type
    integer H
    integer S
    integer V
  end type hsv_type

  ! our 256 color fire palette
  type(rgb_type) :: palette(0:255)
  ! we make buffer a little bit bigger than our graphics surface
  integer :: buffer(0:(width-1+2)*(height-1+3))

  integer :: addr

  contains

    subroutine HSV2RGB(HSV, RGB)
      type(hsv_type), intent(in)  :: HSV
      type(rgb_type), intent(out) :: RGB
      real :: H, S, V
      real :: f, p, q, t
      integer i

      H = anint(real(HSV%H)*255/360)
      S = anint(real(HSV%S)/255)
      v = anint(real(HSV%V)/255)

      if(nint(S).eq.0) then
        RGB%R = nint(V*255)
        RGB%G = nint(V*255)
        RGB%B = nint(V*255)

        return
      endif

      H = H/60
      i = floor(H)
      f = H-i
      p = V*(1-S)
      q = V*(1-S*f)
      t = V*(1-S*(1-f))

      select case(i)
        case(0)
          RGB%R = nint(V*255)
          RGB%G = nint(t*255)
          RGB%B = nint(p*255)
        case(1)
          RGB%R = nint(q*255)
          RGB%G = nint(V*255)
          RGB%B = nint(p*255)
        case(2)
          RGB%R = nint(p*255)
          RGB%G = nint(V*255)
          RGB%B = nint(t*255)
        case(3)
          RGB%R = nint(p*255)
          RGB%G = nint(q*255)
          RGB%B = nint(V*255)
        case(4)
          RGB%R = nint(t*255)
          RGB%G = nint(p*255)
          RGB%B = nint(V*255)
        case default
          RGB%R = nint(V*255)
          RGB%G = nint(p*255)
          RGB%B = nint(q*255)
      end select

    end  subroutine HSV2RGB


    integer function constrain(value, a, b)
      integer, intent(in) :: value, a, b
      integer c

      c = max(value, a)
      constrain = min(c, b)
    end function constrain


    integer function timer_func()
      integer :: q,x,y,padding, row, nrow, n1,n2,n3,decay,new

      padding=ls(rs(3*width+3,2),2)

      ! put fire emitter at bottom of the buffer
      do x=0, width+1, 1
        buffer(((width+2)*height) + x) = int(random@()*255)
      end do
      ! play with fire buffer
      do y=0,199,1
        ! calculate buffer row offsets
        row=y*(width+2)
        nrow=(y+1)*(width+2)
        do x=0,width-1,1
          n1=buffer(nrow+x)
          n2=buffer(nrow+x+1)
          n3=buffer(nrow+x+2)
          decay=3
          new=((n1+n2+n3)/3)-decay
          new=mod(new,256)
          if(new.lt.0) new=0
          buffer(row+x+1)=new
        end do
        ! blit buffer line
        do x=0,width-1,1
          q=3*x+padding*y
          core1(addr+q+2)=palette(buffer(row+x))%R
          core1(addr+q+1)=palette(buffer(row+x))%G
          core1(addr+q)=palette(buffer(row+x))%B
        end do
      end do

      call size_in_pixels@(40,40)
      call draw_characters@('Silverfrost',180,80,RGB@(0,0,255))
      call size_in_pixels@(120,120)
      call draw_characters@('FTN95',100,200,RGB@(255,0,0))
      call perform_graphics_update@()

      timer_func=2
    end function timer_func

end module flames


winapp
  use flames
  implicit none

  integer :: i

  type(hsv_type) hsv_color

  ! calculate fire palette, from black to yellow
  do i=0, 255, 1
    hsv_color%H = i/3
    hsv_color%S = 255
    hsv_color%V = constrain(i*3, 0, 255)
    call HSV2RGB(hsv_color, palette(i))
  end do

  i=winio@('%ww%ca[Flames]%gr[black,'//'user_surface]&',800,200,addr)
  i=winio@('%dl',0.016D0, timer_func)
end