Merry Christmas Banner

[bplus]

Since someone took down the code that had nice trees and snow fall...

Code: (Select All)

'$INCLUDE:'SaveImage.BI'

Const SaveTextAs256Color = 0 'Flag to Save as 256 color file or 32-bit color file, when converting SCREEN 0 to an image
'                             Set to TRUE (any non-zero value) to save text screens in 256 color mode.
'                             Set to FALSE (zero) to save text screens in 32-bit color mode.

_Title "Winter Christmas Theme Banner 11, space to take snap, escape for new tree layout" ' b+ 2022-11-07 Banner 5 with better and Rnd  Pine Trees
'started from Snowjob code

Const XMAX = 1235
Const YMAX = 256
Screen _NewImage(XMAX, YMAX, 32)
_ScreenMove 0, 100

'snow making machine
Type PARTICLE
    x As Single
    y As Single
    dx As Single
    dy As Single
    size As Single
    density As Single
    angle As Single
    dir As Single
    maxy As Single
End Type

Const nTrees = 70
Dim As Long logo, santa, fnt, wallpaper, t
ReDim savefile As String
savefile = "Merry Christmas Banner 2022.png"
'logo = _LoadImage("peLogo.png")
'santa = _LoadImage("Kindpng_301203.png")
'_ClearColor &HFFFFFFFF, santa
fnt = _LoadFont("FROSW___.ttf", 100)

restart: ' new wallpaper background
If wallpaper <= -1 Then _FreeImage wallpaper ' avoid memory leak
wallpaper = _NewImage(XMAX, YMAX, 32)
_Font fnt, wallpaper
_PrintMode _KeepBackground , wallpaper
_Dest wallpaper
drawLandscape
For t = 1 To nTrees
    NewTree wallpaper
Next
'_PutImage (25, 18)-Step(220, 220), logo, wallpaper
_Dest wallpaper
'_PutImage (1207, 127)-Step(50, 87), santa, wallpaper
Color _RGB32(200, 0, 0)
_PrintString (10, 120), "Merry Christmas 2022", wallpaper
_Dest 0

Dim As Long nLayers, flakes, layer, flake
Dim horizon
nLayers = 15
flakes = 2 ^ (nLayers + 1) - 1
ReDim snow(flakes) As PARTICLE
horizon = .5 * YMAX
For layer = nLayers To 1 Step -1
    For flake = 0 To 2 ^ layer
        snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
        snow(flake).y = Rnd * 2 * YMAX - YMAX ' <<<<<<<<<<<<<< fix clear clearing when first start by spreading over 2 screens
        snow(flake).dx = .1 * (nLayers + 1 - layer) * Cos(Rnd * _Pi(.6666) + _Pi(.0833))
        If snow(flake).dx < -.2 Then snow(flake).dx = -snow(flake).dx '              <<<<<<<<<<<<< add a little wind
        snow(flake).dy = .1 * (nLayers + 1 - layer) * Sin(Rnd * _Pi(.6666) + _Pi(.0833))
        If snow(flake).dy < .2 Then snow(flake).dy = .2 '                       <<<<<<<<<<<<<< make sure everything is falling
        snow(flake).size = .5 * (nLayers - layer)
        snow(flake).density = 2.3 + Rnd * .5
        snow(flake).angle = Rnd * _Pi
        If Rnd < .5 Then snow(flake).dir = -1 Else snow(flake).dir = 1
        snow(flake).maxy = horizon + (nLayers + 1 - layer) * 30
    Next
Next

Dim k$
Dim result
While _KeyDown(27) = 0 ' <<<<<<<<<<<<< allow escape from full screen
    _PutImage , wallpaper&, 0

    k$ = InKey$
    For flake = flakes To 0 Step -1
        If Rnd < .2 Then
            snow(flake).x = snow(flake).x + snow(flake).dx + Rnd * 2 - 1
            snow(flake).y = snow(flake).y + snow(flake).dy + Rnd * 2 - 1
        Else
            snow(flake).x = snow(flake).x + snow(flake).dx
            snow(flake).y = snow(flake).y + snow(flake).dy
        End If
        If snow(flake).size <= 1 Then
            PSet (snow(flake).x, snow(flake).y), _RGBA32(255, 255, 255, 80)
        ElseIf snow(flake).size <= 2 Then
            Circle (snow(flake).x, snow(flake).y), 1, _RGBA32(255, 255, 255, 100)
        Else
            snow(flake).angle = snow(flake).angle + snow(flake).dir * _Pi(1 / 100) ' <<<<<< turn flakes more
            rFlake snow(flake).x, snow(flake).y, snow(flake).size, snow(flake).density, snow(flake).angle
        End If
        If snow(flake).y > snow(flake).maxy Or snow(flake).x < -.5 * XMAX Or snow(flake).x > 1.5 * XMAX Then
            snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
            snow(flake).y = Rnd * YMAX - 1.1 * YMAX
        End If
    Next
    _Display
    If k$ = " " Then
        result = SaveImage(savefile, 0, 0, 0, _Width - 1, _Height - 1)
        If result = 1 Then 'file already found on drive
            Kill savefile 'delete the old file
            result = SaveImage(savefile, 0, 0, 0, _Width - 1, _Height - 1) 'save the new one again
        End If
        If result >= 0 Then Cls: Print "Save Failed": Beep: End ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<  beep = failed
    End If
    _Limit 60
Wend
GoTo restart

Sub rFlake (x, y, r, DV, rAng)
    'DV = flake density
    Dim As Long a
    Dim armX, armY
    Color _RGBA32(225, 225, 245, r ^ 2 * 30)
    For a = 0 To 5
        armX = x + r * Cos(a * _Pi(1 / 3) + rAng)
        armY = y + r * Sin(a * _Pi(1 / 3) + rAng)
        Line (x, y)-(armX, armY)
        If r > 2.5 Then rFlake armX, armY, r / DV, DV, rAng
    Next
End Sub

Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Sub

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

Sub drawLandscape
    'needs midInk, rand
    'the sky
    Dim As Long i, rgb, mountain
    Dim startH, updown, range, lastX, Xright, y, x
    For i = 0 To .33 * YMAX
        midInk 120, 50, 100, 255, 255, 150, i / (.3 * YMAX) '<<<<<<<<<<<<  dark on top lighter redder lower
        Line (0, i)-(XMAX, i)
    Next
    'the land
    startH = .2 * YMAX
    rgb = 195 ' <<<<<<<<<<<<<<<<<<<<<< less white
    For mountain = 1 To 6
        Xright = 0
        y = startH
        While Xright < XMAX
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            updown = (Rnd * .8 - .35) / (mountain * 2)
            range = Xright + rand%(15, 35) * 3.5 / mountain
            lastX = Xright - 1
            Color _RGB32(rgb + 10 * mountain, rgb + 8 * mountain, rgb + 10 * mountain)
            For x = Xright To range
                y = y + updown
                Line (lastX, y)-(x, YMAX), , BF 'just lines weren't filling right
                lastX = x
            Next
            Xright = range
        Wend
        '_DELAY 1
        rgb = rand%(rgb, rgb + 20)
        startH = startH + rand%(5, 20)
    Next
End Sub

Sub NewTree (d&)
    Dim h, w
    horz = _Height - 135 - 60
    h = Rnd * 100 + 25
    w = h / 2 + Rnd * h / 8 - h / 16
    Pinetree _Width * Rnd, horz - .5 * h, w, h, d&
End Sub

Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub

Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
    Dim R1, G1, B1, A1, R2, G2, B2, A2
    cAnalysis c1, R1, G1, B1, A1
    cAnalysis c2, R2, G2, B2, A2
    Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function

Sub Pinetree (treeX, treeY, wide, high, dst&)
    'tannen baum by PeterMaria W  orig 440x460
    'fits here  LINE (0, 0)-(440, 410), , B
    Dim t&, bpx, bpy, tpx, aa, bpxx, bpyy, x, y, ra, tpy, ht, xs, xsh, rs, tpxx, tpyy, fra, x1, x2, y1, y2, wf, hf
    t& = _NewImage(440, 410, 32)
    _Dest t&
    bpx = 220: bpy = 410
    tpx = bpx
    For aa = -4 To 4
        bpxx = bpx + aa
        bpyy = bpy - 390
        Line (x + bpxx, y + bpy)-(x + bpx, y + bpyy), _RGB32(30, 30, 0)
    Next
    ra = 160
    tpy = bpy - 40
    For ht = 1 To 40
        For xs = -100 To 100 Step 40
            xsh = xs / 100
            rs = Rnd * 4 / 10
            tpxx = tpx + (xsh * ra)
            tpyy = tpy - rs * ra
            Line (x + tpx, y + tpy)-(x + tpxx, y + tpyy), _RGB32(50, 40, 20)
            For aa = 1 To 30
                fra = Rnd * 10 / 10 * ra
                x1 = tpx + (xsh * fra)
                y1 = tpy - rs * fra
                x2 = tpx + xsh * (fra + ra / 5)
                y2 = tpy - rs * fra + (-rs + (Rnd * 8) / 10 - 0.4) * (ra / 5)
                Line (x + x1, y + y1)-(x + x2, y + y2), _RGB32(Rnd * 120, Rnd * 70 + 70, Rnd * 80)
            Next
        Next
        ra = ra - 4
        tpy = tpy - 9
    Next
    _Source t&
    For i = 1 To 30000
        x = Rnd * 440: y = Rnd * 410
        If Point(x, y) > 0 Then PSet (x, y), &HFFFFFFFF
    Next
    _Dest 0: _Source 0
    wf = wide / 440: hf = high / 410
    _PutImage (treeX, treeY)-Step(440 * wf, 410 * hf), t&, dst&
    _FreeImage t&
End Sub

'$INCLUDE:'SaveImage.BM'

Really nice pine trees! from Peter W code modified by me many a time, eg Tree + lights + options... https://qb64phoenix.com/forum/showthread...7#pid11787

Merry Christmas!