+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Christmas Code (https://qb64phoenix.com/forum/forumdisplay.php?fid=48)
+---- Thread: Merry Christmas Banner (/showthread.php?tid=1304)
Merry Christmas Banner - bplus - 12-18-2022
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'Merry Christmas!