Board Logo
« Winter fun 2016 Snow Scene »

Welcome Guest. Please Login or Register.
Jan 21st, 2018, 12:55am


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Please use the forums Search feature before asking.
Please post code using the code box described in Format Your Messages.
This will keep indentation, separate it better form the message and prevent gibberish.
If the code is too long for one post or additional files are needed, upload a ZIP archive to the Just BASIC Files Archive Site.

« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: Winter fun 2016 Snow Scene  (Read 503 times)
Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Winter fun 2016 Snow Scene
« Thread started on: Nov 1st, 2016, 04:52am »

It is winter in the northern hemisphere, time to retire indoors and code. So if you cannot see the snow falling, draw some.

Create a snow scene either with moving text or graphically. The more realistic the action the better. Will it accumulate on the ground? Will it hang on branches?

We will showcase the results here but post your code on the general board first.
User IP Logged

bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1255
xx Re: Winter fun 2016 Snow Scene
« Reply #1 on: Nov 9th, 2016, 6:45pm »

Richard Russell Quote:
Will somebody please cross-post this to the JB and LB forums on my behalf. The program benefits from a fast PC:


I am big fan of trees and BASIC "movies", this version is really nice and works in JB:
Code:

    ' Snow Scene for Liberty BASIC, Just BASIC & LB Booster
    ' (C) 2016 Richard Russell, http://www.rtrussell.co.uk/

    WindowWidth = 800
    WindowHeight = 600
    UpperLeftX = (DisplayWidth - WindowWidth)/2
    UpperLeftY = (DisplayHeight - WindowHeight)/2
    Flakes = 500

    global Flakes
    dim flake(Flakes,2)
    nomainwin
    open "Snow Scene" for graphics_nsb as #w
    #w "trapclose quit"
    call getmargins MarginX, MarginY
    floor = WindowHeight - MarginY
    #w "fill 0 0 200; down; rule over"
    call branch WindowWidth/3, WindowHeight, WindowHeight/5, 1.6, 10
    #w "flush; rule xor"
    #w "getbmp tree 0 0 ";WindowWidth-MarginX;" ";WindowHeight-MarginY
    bmp$ = getbmp$("tree")
    call initflakes
    timer 20, [animate]
    wait

[animate]
    timer 0
    winda = (winda + rnd(1)/10) mod (8 * atn(1))
    wind = sin(winda)
    gr$ = ""
    for i = 1 to Flakes
      if flake(i,2) <> flake(i-1,2) then gr$ = gr$;"size ";flake(i,2);";"
      flag = 0
      if rnd(1) < 0.02 then
        if flake(i,0) < WindowWidth-MarginX and flake(i,1) < WindowHeight-MarginY then
          if getpixel(bmp$, flake(i,0), flake(i,1)) = 0 then flag = 1
        end if
      end if
      if flake(i,1) > floor or flag then
         gr$ = gr$;"color white;rule over;"
         gr$ = gr$;"set ";int(flake(i,0));" ";int(flake(i,1));";"
         gr$ = gr$;"color black;rule xor;"
        flake(i,0) = rnd(1) * WindowWidth
        flake(i,1) = rnd(1) * 10
      else
         gr$ = gr$;"set ";int(flake(i,0));" ";int(flake(i,1));";"
      end if
      flake(i,0) = flake(i,0) + wind
      flake(i,1) = flake(i,1) + rnd(1)*3 + 1
      gr$ = gr$;"set ";int(flake(i,0));" ";int(flake(i,1));";"
    next
    #w gr$ + "segment seg;flush"
    #w "delsegment ";seg
    floor = floor - 0.01
    timer 20, [animate]
    wait

sub initflakes
    gr$ = ""
    for i = 1 to Flakes
      flake(i,0) = rnd(1) * (WindowWidth + 200) - 100
      flake(i,1) = rnd(1) * WindowHeight
      flake(i,2) = int(rnd(1) * 4 + 1)
      gr$ = gr$;"size ";flake(i,2);";"
      gr$ = gr$ + "set ";int(flake(i,0));" ";int(flake(i,1));";"
    next
    #w gr$
end sub

sub branch x1, y1, size, angle, depth
    x2 = x1 - size * cos(angle)
    y2 = y1 - size * sin(angle)
    #w "size ";depth;";line ";x1;" ";y1;" ";x2;" ";y2
    if depth > 0 then
      call branch x2, y2, size * (rnd(1)/5 + 0.64), angle - 0.1 - rnd(1)/2, depth - 1
      call branch x2, y2, size * (rnd(1)/5 + 0.64), angle + 0.1 + rnd(1)/2, depth - 1
      if depth > 2 then
        call branch (x1+x2)/2, (y1+y2)/2, size * 0.4, angle + rnd(1) - 0.5, depth - 3
      end if
    end if
end sub

sub getmargins byref x, byref y
    #w "home;posxy xpos ypos"
    x = WindowWidth - 2 * xpos
    y = WindowHeight - 2 * ypos
end sub

function getbmp$(bmp$)
    dummy = mkdir("\temp\")
    bmpsave bmp$, "\temp\";bmp$;".bmp"
    open "\temp\";bmp$;".bmp" for input as #f
    getbmp$ = input$(#f, lof(#f))
    close #f
    kill "\temp\";bmp$;".bmp"
end function

function getpixel(bmp$, x, y)
    b = asc(mid$(bmp$,29,1)) / 8
    o = asc(mid$(bmp$,11,1)) + 256*asc(mid$(bmp$,12,1)) + 1
    w = asc(mid$(bmp$,19,1)) + 256*asc(mid$(bmp$,20,1))
    h = asc(mid$(bmp$,23,1)) + 256*asc(mid$(bmp$,24,1))
    w = ((w * b) + 3) and -4
    y = h - y - 1
    getpixel = asc(mid$(bmp$,o+b*int(x)+w*int(y),1))
end function

sub quit h$
    close #h$
    end
end sub

 


Interesting color effect when given the Anatoly Test.

There has been an edit, there is no longer an interesting color effect when the Anatoly Test is tried. ;-)

BTW, that getPixel function is very interesting!
« Last Edit: Nov 9th, 2016, 10:16pm by bplus » User IP Logged

B+
tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3636
xx Re: Winter fun 2016 Snow Scene
« Reply #2 on: Nov 10th, 2016, 01:12am »

That tree looks really real.
User IP Logged

Q: "And if I took your codes and compile them, and sell them for a profit"?
A: Go ahead. I had my share of good then I coded it for fun, if you can make better use of it - please do.
(enjoying JB 1.01 on WinXP, netbook and desktop)
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1255
xx Re: Winter fun 2016 Snow Scene
« Reply #3 on: Nov 22nd, 2016, 10:27pm »

Turn any bmp into a Snow Scene:
Code:
' Snow Machine 2.txt for JB [B+=MGA] 2016-11-22
' add snow to any bmp and make a scene

global XMAX, YMAX, PI  'universally needed
global FRM, nFlakes, WIND, WD 'just Snow Machine
XMAX = 1200 ' actual drawing space needed
YMAX = 700  ' actual drawing space needed
PI = acs(-1)
FRM = 1        'Snow Machine Frame counter
nFlakes= 0     'Count flakes made as forumla for count may change
WIND = 0
WD = 1
nomainwin

WindowWidth = XMAX + 8
WindowHeight = YMAX + 32  '>>>> fix: not 32, add 20 for menu bar!
UpperLeftX = 100
UpperLeftY = 40

open "Snow Machine 2" for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonDown lBD"
#gr "when characterInput charIn"
#gr "home"                  '< get drawing area
#gr "posxy w2 h2"           '<<<<<<<<<<<<<<<<<<
'notice "Screen size:" + chr$(13) + "w2 * 2 = ";w2*2;" h2 * 2 = ";h2*2
'>>> now reports 1200 x 700
#gr "down"

'get 348 snowflakes ready, use 5 radii, the smaller the more
for level = 1 to 5
    levelRadius = 14 - 2 * level  '12 to 4
    '8, 16, 32, 64, 128 keep < 500 sprites ~ 248 + 5*20 = 348
    levelNumber = 2 ^ (level + 2) + 20 'formula for level flake numbers
    call makeFlakeSprites levelRadius, levelNumber 'count nFlakes in maker
next
dim fx(nFlakes), fy(nFlakes) 'give them a place to start
for flake = 1 to nFlakes
    fx(flake) = rand(0, XMAX) : fy(flake) = rand(0, YMAX - 20)
    #gr "spritexy f";flake;" fx(";flake;") fy(";flake;")"
    #gr "spritevisible f";flake;" on"
next

' ============= VVVVVVVVVVVVVVVVVVVVVVV ==== load your bmp file here!!!
loadbmp "bak", "Snow Machine test.bmp"
#gr "background bak"
'snow!
while 1  'esc or q or click screen to quit
    scan
    call frame
    FRM = FRM + 1
    if FRM mod 10 = 0 then 'test the winds, mostly Easterly
        WIND = WIND + WD
        if WIND > 5 then WD = WD * -1 : WIND = 5
        if WIND < -2 then WD = WD * -1 : WIND = -2
    end if
wend
wait

' ==================== Window procedures

sub quit H$
    close #gr
    end
end sub

sub lBD H$, x, y  'left button mouse down
    call quit "h"
end sub

sub charIn H$, k$
    if k$ = "q" or k$ = chr$(27) then call quit "h"
end sub

' ================   procedures Snow Machine

sub makeFlakeSprites flakeRadius, flakeNumber
    sw = flakeRadius * 2 + 4
    sh = flakeRadius * 2 + 4
    #gr "cls"
    #gr "color 0 0 0"
    #gr "backcolor 0 0 0"
    #gr "place ";0;" ";sh
    #gr "boxfilled ";sw + 1;" ";2 * sh + 1
    #gr "color white"
    call flake flakeRadius + 2, sh + flakeRadius + 2, flakeRadius
    #gr "color black"
    call flake flakeRadius + 2, flakeRadius + 2, flakeRadius
    for i = 1 to flakeNumber
        nFlakes = nFlakes + 1
        scan
        #gr "getbmp f";nFlakes;" 0 0 ";sw;" ";2 * sh
        #gr "addsprite f";nFlakes;" f";nFlakes
    next
end sub

sub frame 'a snapshot in time
    #gr "discard"
    for flake = 1 to nFlakes
        scan
        if fy(flake) + 14 > YMAX - 24 then
            fy(flake) = 0 : fx(flake) = rand(0, XMAX)
        else
            fy(flake) = fy(flake) + rand(-1, 9)
            fx(flake) = fx(flake) + rand(0, WIND) + rand(-1,1)
            if fx(flake) < 0 then fx(flake) = XMAX
            if fx(flake) > XMAX then fx(flake) = 0
        end if
        #gr "spritexy f";flake;" ";fx(flake);" ";fy(flake)
    next
    #gr "drawsprites"
end sub

sub flake x, y, r  ' flake maker set color before using
    for a = 0 to 5
        armX = x + r * cos(a * PI/3)
        armY = y + r * sin(a * PI/3)
        #gr "line ";x;" ";y;" ";armX;" ";armY
        spikeX = x + .55 * r * cos(a * PI/3)
        spikeY = y + .55 * r * sin(a * PI/3)
        endX1 = spikeX + .3 * r * cos(a * PI/3 - 2 * PI/7)
        endY1 = spikeY + .3 * r * sin(a * PI/3 - 2 * PI/7)
        endX2 = spikeX + .3 * r * cos(a * PI/3 + 2 * PI/7)
        endY2 = spikeY + .3 * r * sin(a * PI/3 + 2 * PI/7)
        #gr "line "; spikeX;" "; spikeY;" "; endX1;" "; endY1
        #gr "line "; spikeX;" "; spikeY;" "; endX2;" "; endY2
    next
end sub

'==============  general supplementary procedures

function rand(n1, n2)
    if n1 > n2 then hi = n1 : lo = n2 else hi = n2 : lo = n1
    rand = int((hi - lo + 1) * rnd(0)) + lo
end function

 
User IP Logged

B+
Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls