Ah! that reminds me of this:
@Dav you (or @Petr), musician and sound guy, could maybe turn the unholy sound from Bonker's Symphony Number 37 and make it sound sweet like Silent Night???
Good thing I can't/don't play a recording of the sound
Possibly each line of lights = notes of a Chord?
Code: (Select All)
Option _Explicit
_Title "Bonkers Synphony #37 (2019 Xmas Update) press spacebar for different view"
'2019-11-24 complete overhall for Xmas 2019 B+ from
' Bonkers Symphony no 37.bas for QB64 fork (B+=MGA) trans 2017-09-15 from
' from: Bonkers Symphony Number 37.bas SmallBASIC 0.12.8 [B+=MGA] 2017-04-21
Const xmax = 1000, ymax = 740
Const nB = 12, gravity = 4, speed = 12
Const maxLRow = 9 'lights
Type ballType
x As Single
y As Single
r As Single
a As Single
c As Integer
rr As Integer
gg As Integer
bb As Integer
End Type
Dim Shared nL
ReDim Shared L(0) As ballType, B(0) As ballType
Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 0
Dim lc, nx, i, j, clrMode, dx, dy 'screen and "tree"
ReDim B(1 To nB) As ballType
For i = 1 To nB
newBall i
Next
initLights
drawLandscape
clrMode = 0: nx = 1
While _KeyDown(27) = 0
lc = (lc + 1) Mod 24000
If _KeyHit = 32 Then
clrMode = 1 - clrMode
Cls
For i = 1 To nB
newBall i
Next
initLights
drawLandscape
nx = 0
End If
If clrMode Then Line (0, 0)-(xmax, ymax), _RGBA32(0, 0, 0, 5), BF
'draw lights
For i = 1 To nL
drawOrb L(i).x, L(i).y, L(i).r, L(i).rr, L(i).gg, L(i).bb, 0
Next
If lc Mod 100 = 0 Then nx = nx + 1
If nx > nB Then nx = nB
'calc collsions
For i = 1 To nx
For j = 1 To nL
If Sqr((B(i).x - L(j).x) ^ 2 + (B(i).y - L(j).y) ^ 2) < B(i).r + L(j).r Then
B(i).a = _Atan2(B(i).y - L(j).y, B(i).x - L(j).x)
L(j).c = L(j).c + 1
If L(j).c > 5 Then L(j).a = 1 - L(j).a: L(j).c = 0
snd L(j).y / ymax * maxLRow, L(j).x / xmax
If L(j).a = 0 Then
drawOrb L(j).x, L(j).y, L(j).r, L(j).rr, L(j).gg, L(j).bb, 1
Exit For
ElseIf L(j).a Then
drawOrb L(j).x, L(j).y, L(j).r, L(j).rr, L(j).gg, L(j).bb, 3
Exit For
End If
End If
Next
For j = i + 1 To nx
If j <> i And B(j).c <> 1 Then
If Sqr((B(i).x - B(j).x) ^ 2 + (B(i).y - B(j).y) ^ 2) < B(i).r + B(j).r Then
B(i).a = _Atan2(B(i).y - B(j).y, B(i).x - B(j).x)
B(j).a = _Atan2(B(j).y - B(i).y, B(j).x - B(i).x)
B(i).c = 1: B(j).c = 1
Exit For
End If
End If
Next
'update balls
dx = Cos(B(i).a) * speed
dy = Sin(B(i).a) * speed + gravity
B(i).a = _Atan2(dy, dx)
B(i).x = B(i).x + dx
B(i).y = B(i).y + dy
If B(i).x < 0 Or B(i).x > xmax Or B(i).y > ymax Then
newBall i
End If
'IF B(i).a > _PI(2) THEN B(i).a = B(i).a - _PI(2)
'IF B(i).a < 0 THEN B(i).a = B(i).a + _PI(2)
drawOrb B(i).x, B(i).y, B(i).r, B(i).rr, B(i).gg, B(i).bb, 2
B(i).c = 0
Next
_Display
_Limit 20
Wend
Sub newBall (i)
If Rnd < .5 Then B(i).x = irnd(xmax / 2 - 30, xmax / 2 - 5) Else B(i).x = irnd(xmax / 2 + 5, xmax / 2 + 30)
B(i).y = irnd(-100, -10)
B(i).r = irnd(3, 10)
B(i).a = _Pi(.5) + _Pi(1 / 90) * rdir
B(i).gg = irnd(60, 120)
B(i).rr = irnd(0, .5 * B(i).gg)
B(i).bb = irnd(0, .4 * B(i).gg)
End Sub
Sub initLights
Dim i, lxo, lyo, row, col, y
nL = maxLRow * (maxLRow + 1) * .5
lxo = xmax / (maxLRow + 1)
lyo = (ymax - 5 * (maxLRow + 1) * maxLRow / 2) / (maxLRow + 1) 'more space for lower rows
ReDim L(1 To nL) As ballType
i = 0: y = 0
For row = 1 To maxLRow
y = y + lyo + 5 * row 'more space for lower rows
For col = 1 To row
i = i + 1
L(i).x = lxo * col + (maxLRow - row) * .5 * lxo + irnd(-3 * row, 3 * row)
L(i).y = y + irnd(-15, 15)
L(i).r = 6 + irnd(row, row + 6) 'bigger for lower rows
L(i).rr = irnd(128, 255) 'red lights are great!
L(i).gg = irnd(128, 255) * irnd(0, 1) 'get rid of two many mixes
L(i).bb = irnd(128, 255) * irnd(0, 1)
Next
Next
End Sub
Sub drawOrb (x, y, r, red, green, blue, litMode) 'make sphere if lit or not
Dim rr
If litMode = 1 Then
fcirc x, y, r, _RGB32(red, green, blue)
For rr = 36 To 0 Step -2
fcirc x, y, rr, _RGBA32(255, 255, 255, 1)
Next
ElseIf litMode = 0 Then
For rr = r To 0 Step -1
fcirc x, y, rr, _RGB32(red - rr * 7, green - rr * 7, blue - rr * 7)
Next
ElseIf litMode = 2 Then
For rr = r To 0 Step -1
fcirc x, y, rr, _RGB32(red * (1 - rr / r), green * (1 - rr / r), blue * (1 - rr / r))
Next
ElseIf litMode = 3 Then
fcirc x, y, r, _RGB32(red, green, blue)
For rr = 36 To 0 Step -2
fcirc x, y, rr, _RGBA32(0, 0, 0, 2)
Next
End If
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub snd (frq, dur)
Sound 314.1592654 * (maxLRow - frq) + 220, dur + Rnd * .3
End Sub
Sub drawLandscape 'needs midInk, irnd
Dim i As Integer, startH As Single, rr As Integer, gg As Integer, bb As Integer
Dim mountain As Integer, Xright As Single, y As Single, upDown As Single, range As Single
Dim lastx As Single, X As Integer
'the sky
For i = 0 To ymax
midInk 0, 0, 25, 14, 0, 44, i / ymax
Line (0, i)-(xmax, i)
Next
'the land
startH = ymax - 400
rr = 40: gg = 50: bb = 60
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 * .5)
range = Xright + irnd(15, 25) * 2.5 / mountain
lastx = Xright - 1
For X = Xright To range
y = y + upDown
Color _RGB(rr, gg, bb)
Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
lastx = X
Next
Xright = range
Wend
rr = irnd(rr - 15, rr): gg = irnd(gg - 15, gg): bb = irnd(bb - 25, bb)
If rr < 0 Then rr = 0
If gg < 0 Then gg = 0
If bb < 0 Then bb = 0
startH = startH + irnd(5, 20)
Next
End Sub
Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
Color _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Sub
Function irnd (n1, n2) 'return random in interval
Dim l, h
If n1 > n2 Then l = n2: h = n1 Else l = n1: h = n2
irnd = Rnd * (h - l) + l
End Function
Function rdir ()
If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function@Dav you (or @Petr), musician and sound guy, could maybe turn the unholy sound from Bonker's Symphony Number 37 and make it sound sweet like Silent Night???
Good thing I can't/don't play a recording of the sound
Possibly each line of lights = notes of a Chord?
b = b + ...