Let it snow

General discussion for topics related to the FreeBASIC project or its community.
Post Reply
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Let it snow

Post by D.J.Peters »

Code: Select all

const NFLEKS = 10000
type tFlake
  as integer x,y
end type

sub InitFlake(iWidth as integer,iHeight as integer,byref aFlake as tFlake)
  with aFlake
    .y = -(iHeight*2)*rnd -1
    .x = 1 + rnd*(iWidth-2)
  end with
end sub

sub InitFlakes(iWidth as integer,iHeight as integer,flakes() as tFlake)
  for i as integer=0 to NFLEKS-1
    InitFlake(iWidth,iHeight,flakes(i))
  next  
end sub

function Init(iWidth as integer,iHeight as integer,flakes() as tFlake) as any ptr
  const as string msg="MERRY CHRISTMAS!"
  const as integer nChars=len(msg)
  initFlakes(iWidth,iHeight,flakes())
  var bg = imagecreate(iWidth,iHeight)
  var txt= imagecreate(nChars*8,8)
  draw string txt,(0,0),msg,15
  var size=iWidth/(nChars*8)
  var xs=(iWidth/2)-(nChars*4*size)
  var ys=iHeight/2
  
  for y as integer=0 to 7
    var w=0.0
    for x as integer=0 to nChars*8-1
      if point(x,y,txt)<>0 then
        line bg,(xs+40+x*size,(ys+sin(w)*size) + y*size)-step(size-1,size+2),32+x\2,BF
      end if  
      w+=0.1
    next
    xs-=8
  next  
  ImageDestroy(txt)
  
  return bg
end function

sub UpdateFlakes(byval fg as any ptr, _
                 byval bg as any ptr, _
                 flakes() as tFlake)
  static as integer iWidth,iHeight,iPitch,bgPitch
  static as ubyte ptr FGPixels,BGPixels
  dim as integer x,y,index,index2
  if iPitch=0 orelse FGPixels=0 orelse BGPixels=0 then
    imageinfo fg,iWidth,iHeight,,iPitch,FGPixels
    imageinfo bg,      ,       ,,      ,BGPixels
    line bg,(0,iHeight-1)-step(iWidth-1,0),15
  end if
  line fg,(0,0)-(iWidth-1,iHeight-1),0,BF
  for i as integer=0 to NFLEKS-1
    with flakes(i)
      if .y<0 then 
        .y+=1 
      else
        index=.y*iPitch+.x
        index2=index+iPitch
        if .y=iHeight-1 then
          BGPixels[index]=15 
          InitFlake(iWidth,iHeight,flakes(i))
        elseif BGPixels[index2]=0 then 
          FGPixels[index2]=15 : .y+=1
        elseif BGPixels[index2-1]=0 then
          .x-=1 : .y+=1
          if .x<0 then 
            InitFlake(iWidth,iHeight,flakes(i))
            BGPixels[index]=15 
          else  
            FGPixels[index2-1]=15 
          end if         
        elseif BGPixels[index2+1]=0 then    
          .x+=1 : .y+=1
          if .x=iWidth then 
            InitFlake(iWidth,iHeight,flakes(i))
            BGPixels[index]=15 
          else  
            FGPixels[index2+1]=15 
          end if  
        elseif BGPixels[index2-1]=0 andalso BGPixels[index-1]=0 then  
          FGPixels[index-1]=15 
          .x-=1
        elseif BGPixels[index2+1]=0 andalso BGPixels[index+1]=0 then    
          FGPixels[index+1]=15
          .x+=1
        else
          BGPixels[index]=15
          InitFlake(iWidth,iHeight,flakes(i))
        end if
      end if 
    end with
  next
end sub

'
' main
'
dim as tFlake Flakes(NFLEKS-1) 
dim as integer iWidth,iHeight
screeninfo iWidth,iHeight
iWidth*=0.9 
iHeight*=.5
screenres iWidth,iHeight
var fg=imagecreate(iWidth,iHeight)
var bg=init(iWidth,iHeight,flakes())
while inkey()=""
  UpdateFlakes(fg,bg,flakes())
  ScreenLock
  put (0,0),bg,PSET
  put (0,0),fg,TRANS
  ScreenUnlock
  Sleep 8
wend

lizard
Posts: 440
Joined: Oct 17, 2017 11:35
Location: Germany

Re: Let it snow

Post by lizard »

Code: Select all

' cairo_snowflake.bas

' http://www.informatik.uni-kiel.de/~sb/wissrech/cairo3_recursion.c

#include once "cairo/cairo.bi"

sub snowflake_arm(byval cr as cairo_t ptr, byval l as integer)
  cairo_move_to(cr, 0.0, 0.0)
  cairo_line_to(cr, 0.0, 0.5)
  cairo_stroke(cr)
  if l > 0 then
    cairo_save(cr)
    cairo_translate(cr, 0.0, 0.5)
    cairo_scale(cr, 0.45, 0.45)
    snowflake_arm(cr, l - 1)
    cairo_rotate(cr, 1.2)
    snowflake_arm(cr, l - 1)
    cairo_rotate(cr, -2.4)
    snowflake_arm(cr, l - 1)
    cairo_restore(cr)
  end if
end sub

const pi = 4 * atn(1)
const zoom = 3
const screen_w = zoom * 320
const screen_h = zoom * 80

screenres(screen_w, screen_h, 32)

dim as cairo_surface_t ptr surface = cairo_image_surface_create_for_data( _
       screenptr(), cairo_format_argb32, screen_w, screen_h, screen_w * 4)
  
dim as cairo_t ptr cr = cairo_create(surface)

screenlock()
  cairo_set_source_rgba(cr, 1, 1, 1, 1)
  cairo_paint(cr)
  cairo_set_source_rgba(cr, 0, 0, 0, 1)
  for l as integer = 0 to 3
    cairo_save(cr)
    cairo_translate(cr, zoom * 40.0 + l * zoom * 80.0, zoom * 40.0)
    cairo_scale(cr, zoom * 40.0, zoom * 40.0)
    cairo_set_line_width(cr, 0.01)
    for i as integer = 0 to 4
      cairo_save(cr)
      cairo_rotate(cr, 2.0 * pi * i / 5)
      snowflake_arm(cr, l)
      cairo_restore(cr)
    next i
  cairo_restore(cr)
  next l
screenunlock()

cairo_surface_write_to_png(surface, "data/snowflake.png")
cairo_destroy(cr)
cairo_surface_destroy(surface)

sleep

Last edited by lizard on Dec 24, 2018 23:56, edited 1 time in total.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Let it snow

Post by badidea »

More like thick rain, but nice.
grindstone
Posts: 862
Joined: May 05, 2015 5:35
Location: Germany

Re: Let it snow

Post by grindstone »

Nice idea. Reminds me a bit of "Lemmings". :-)
jevans4949
Posts: 1186
Joined: May 08, 2006 21:58
Location: Crewe, England

Re: Let it snow

Post by jevans4949 »

My kids say it reminds them of Christmas Jetpack!
Linuxbob
Posts: 60
Joined: Sep 01, 2010 1:03
Location: Ohio, USA

Re: Let it snow

Post by Linuxbob »

Very cool, thanks and Merry Christmas!
Post Reply