Let it snow

For other topics related to the FreeBASIC project or its community.
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Let it snow

Postby D.J.Peters » Dec 24, 2018 23:46

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

Postby lizard » Dec 24, 2018 23:55

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: 1368
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Let it snow

Postby badidea » Dec 24, 2018 23:55

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

Re: Let it snow

Postby grindstone » Dec 25, 2018 8:33

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

Re: Let it snow

Postby jevans4949 » Dec 26, 2018 0:41

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

Re: Let it snow

Postby Linuxbob » Dec 26, 2018 3:44

Very cool, thanks and Merry Christmas!

Return to “Community Discussion”

Who is online

Users browsing this forum: No registered users and 1 guest