Posts: 3,974
Threads: 177
Joined: Apr 2022
Reputation:
219
Code: (Select All) Option _Explicit
_Title "Programmable Tree Lights v2" ' b+ 2020-12-19 2022-12-18 fixed k$
Randomize Timer
Const Xmax = 700, Ymax = 700, N_Rows = 10, N_Cols = 2 * N_Rows - 1
Const X_Spacer = 30, Y_Spacer = 52, X_Offset = 50
Type ColorSeed
Red As Single
Green As Single
Blue As Single
End Type
Dim Shared ColorSet(10) As ColorSeed, ColorSetIndex As Long
Dim Shared pR, pG, pB, pN, pStart, pMode$
Dim Shared TG(1 To N_Cols, 1 To N_Rows) As Long
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim As Long i, row, Col, nstars, back, cc
Dim horizon, r, land
Dim l$, o$, b$, k$
' setup some color seeds in ColorSet user can change out with Shift + digit key
For i = 0 To 9 ' 10 random color seeds
resetPlasma
ColorSet(i).Red = pR: ColorSet(i).Green = pG: ColorSet(i).Blue = pB
Next
'Stringing the lights on tree, adjusted to fit mostly on the tree 2*N - 1 Pryramid
For row = 1 To 10
l$ = xStr$(2 * row - 1, "X")
o$ = xStr$(10 - row, "O")
b$ = o$ + l$ + o$
For Col = 1 To N_Cols
If Mid$(b$, Col, 1) = "O" Then TG(Col, row) = 0 Else TG(Col, row) = -1
Next
Print b$
Next
' making the stars
horizon = Ymax - 4 * r
nstars = 100
Dim xstar(100), ystar(100), rstar(100)
For i = 1 To 100
xstar(i) = Rnd * (Xmax): ystar(i) = Rnd * horizon:
If i < 75 Then
rstar(i) = 0
ElseIf i < 95 Then
rstar(i) = 1
Else
rstar(i) = 2
End If
Next
Cls
' make a circle tree and align circles to tree with spacers and offsets with new Pyramid Scheme
'Pinetree 25, 30, 650, 600
'FOR row = 1 TO N_Rows
' FOR col = 1 TO N_Cols
' IF TG(col, row) THEN CIRCLE (col * X_Spacer + X_Offset, row * Y_Spacer), 10
' NEXT
'NEXT
' making the background
back = _NewImage(_Width, _Height, 32)
Cls
horizon = Ymax - 100
For i = 0 To horizon
Line (0, i)-(Xmax, i), _RGB32(i / horizon * 70, i / horizon * 22, 60 * (i) / horizon)
Next
land = Ymax - horizon
For i = horizon To Ymax
cc = 128 + (i - horizon) / land * 127
Line (0, i)-(Xmax, i), _RGB32(cc, cc, cc)
Next
For i = 1 To 100
fcirc xstar(i), ystar(i), rstar(i), &HFFEEEEFF
Next
_PutImage , 0, back
ColorSetIndex = 1: pMode$ = "h"
show ' avoid the pause for key checking
Do
k$ = InKey$
If Len(k$) Then
If InStr("0123456789", k$) > 0 Then
ColorSetIndex = Val(k$)
ElseIf InStr("vhde", k$) > 0 Then
pMode$ = k$
End If
End If
_PutImage , back, 0
show
_Display
_Limit 10
Loop Until _KeyDown(27)
Sub show
Dim row, prow, col
Pinetree 25, 30, 650, 600
_Title "Programmable Tree Lights (0-9) Color Set: " + TS$(ColorSetIndex) + " (v, h, d, e) Mode: " + pMode$
pR = ColorSet(ColorSetIndex).Red: pG = ColorSet(ColorSetIndex).Green: pB = ColorSet(ColorSetIndex).Blue
pStart = pStart + 1
Select Case pMode$
Case "h"
For row = 1 To N_Rows
prow = pStart + row
For col = 1 To N_Cols
pN = prow
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer, Plasma~&
Next
Next
Case "v"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer, Plasma~&
Next
Next
Case "d"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col - row
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer, Plasma~&
Next
Next
Case "e"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + row + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer, Plasma~&
Next
Next
End Select
End Sub
Sub Lite (x, y, c As _Unsigned Long)
Dim cR, cG, cB, cA, r
cAnalysis c, cR, cG, cB, cA
For r = 35 To 0 Step -2
fcirc x, y, r, _RGB32(cR, cG, cB, 1)
Next
fcirc x, y, 4, c
End Sub
Sub Pinetree (treeX, treeY, wide, high)
Dim bpx, bpy, tpx, bpxx, bpyy, aa, ra, tpy, ht, xs, xsh, rs, tpxx, tpyy, fra, x1, x2, y1, y2, wf, hf
'tannen baum by PeterMaria W orig 440x460
'fits here LINE (0, 0)-(440, 410), , B
Static t&
If t& = 0 Then
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 (bpxx, bpy)-(bpx, 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 (tpx, tpy)-(tpxx, 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 (x1, y1)-(x2, y2), _RGB32(Rnd * 80, Rnd * 70 + 40, Rnd * 60)
Next
Next
ra = ra - 4
tpy = tpy - 9
Next
_Dest 0
End If
wf = wide / 440: hf = high / 410
_PutImage (treeX, treeY)-Step(440 * wf, 410 * hf), t&, 0
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 Plasma~& ()
pN = pN + 1 'dim shared cN as _Integer64, pR as integer, pG as integer, pB as integer
Plasma~& = _RGB32(127 + 127 * Sin(pR * pN), 127 + 127 * Sin(pG * pN), 127 + 127 * Sin(pB * pN))
End Function
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: pN = 0
End Sub
Function xStr$ (x, strng$)
Dim i, rtn$
For i = 1 To x
rtn$ = rtn$ + strng$
Next
xStr$ = rtn$
End Function
Function TS$ (n As Integer)
TS$ = _Trim$(Str$(n))
End Function
'from Steve Gold standard
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
Line (CX - Y, CY + X)-(CX + Y, CY + X), C
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C
Line (CX - X, CY + Y)-(CX + X, CY + Y), C
Wend
End Sub
b = b + ...
Posts: 3,974
Threads: 177
Joined: Apr 2022
Reputation:
219
OMG not so straight!
Code: (Select All) Option _Explicit
_Title "Programmable Tree Lights v3" ' b+ 2020-12-19 2022-12-18 fixed k$ v3 random position lights
Randomize Timer
Const Xmax = 700, Ymax = 700, N_Rows = 10, N_Cols = 2 * N_Rows - 1
Const X_Spacer = 30, Y_Spacer = 52, X_Offset = 50
Type ColorSeed
Red As Single
Green As Single
Blue As Single
End Type
Dim Shared ColorSet(10) As ColorSeed, ColorSetIndex As Long
Dim Shared pR, pG, pB, pN, pStart, pMode$
Dim Shared TG(1 To N_Cols, 1 To N_Rows) As Long
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim As Long i, row, Col, nstars, back, cc
Dim horizon, r, land
Dim l$, o$, b$, k$
' setup some color seeds in ColorSet user can change out with Shift + digit key
For i = 0 To 9 ' 10 random color seeds
resetPlasma
ColorSet(i).Red = pR: ColorSet(i).Green = pG: ColorSet(i).Blue = pB
Next
'Stringing the lights on tree, adjusted to fit mostly on the tree 2*N - 1 Pryramid
For row = 1 To 10
l$ = xStr$(2 * row - 1, "X")
o$ = xStr$(10 - row, "O")
b$ = o$ + l$ + o$
For Col = 1 To N_Cols
If Mid$(b$, Col, 1) = "O" Then TG(Col, row) = 0 Else TG(Col, row) = -1
Next
Print b$
Next
' making the stars
horizon = Ymax - 4 * r
nstars = 100
Dim xstar(100), ystar(100), rstar(100)
For i = 1 To 100
xstar(i) = Rnd * (Xmax): ystar(i) = Rnd * horizon:
If i < 75 Then
rstar(i) = 0
ElseIf i < 95 Then
rstar(i) = 1
Else
rstar(i) = 2
End If
Next
Cls
' make a circle tree and align circles to tree with spacers and offsets with new Pyramid Scheme
'Pinetree 25, 30, 650, 600
'FOR row = 1 TO N_Rows
' FOR col = 1 TO N_Cols
' IF TG(col, row) THEN CIRCLE (col * X_Spacer + X_Offset, row * Y_Spacer), 10
' NEXT
'NEXT
' making the background
back = _NewImage(_Width, _Height, 32)
Cls
horizon = Ymax - 100
For i = 0 To horizon
Line (0, i)-(Xmax, i), _RGB32(i / horizon * 70, i / horizon * 22, 60 * (i) / horizon)
Next
land = Ymax - horizon
For i = horizon To Ymax
cc = 128 + (i - horizon) / land * 127
Line (0, i)-(Xmax, i), _RGB32(cc, cc, cc)
Next
For i = 1 To 100
fcirc xstar(i), ystar(i), rstar(i), &HFFEEEEFF
Next
_PutImage , 0, back
ColorSetIndex = 1: pMode$ = "h"
show ' avoid the pause for key checking
Do
k$ = InKey$
If Len(k$) Then
If InStr("0123456789", k$) > 0 Then
ColorSetIndex = Val(k$)
ElseIf InStr("vhde", k$) > 0 Then
pMode$ = k$
End If
End If
_PutImage , back, 0
show
_Display
_Limit 10
Loop Until _KeyDown(27)
Sub show
Dim row, prow, col
Pinetree 25, 30, 650, 600
_Title "Programmable Tree Lights (0-9) Color Set: " + TS$(ColorSetIndex) + " (v, h, d, e) Mode: " + pMode$
pR = ColorSet(ColorSetIndex).Red: pG = ColorSet(ColorSetIndex).Green: pB = ColorSet(ColorSetIndex).Blue
pStart = pStart + 1
Select Case pMode$
Case "h"
For row = 1 To N_Rows
prow = pStart + row
For col = 1 To N_Cols
pN = prow
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col, Plasma~&
Next
Next
Case "v"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col, Plasma~&
Next
Next
Case "d"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col - row
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col, Plasma~&
Next
Next
Case "e"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + row + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset, row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col, Plasma~&
Next
Next
End Select
End Sub
Sub Lite (x, y, c As _Unsigned Long)
Dim cR, cG, cB, cA, r
cAnalysis c, cR, cG, cB, cA
For r = 35 To 0 Step -2
fcirc x, y, r, _RGB32(cR, cG, cB, 1)
Next
fcirc x, y, 4, c
End Sub
Sub Pinetree (treeX, treeY, wide, high)
Dim bpx, bpy, tpx, bpxx, bpyy, aa, ra, tpy, ht, xs, xsh, rs, tpxx, tpyy, fra, x1, x2, y1, y2, wf, hf
'tannen baum by PeterMaria W orig 440x460
'fits here LINE (0, 0)-(440, 410), , B
Static t&
If t& = 0 Then
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 (bpxx, bpy)-(bpx, 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 (tpx, tpy)-(tpxx, 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 (x1, y1)-(x2, y2), _RGB32(Rnd * 80, Rnd * 70 + 40, Rnd * 60)
Next
Next
ra = ra - 4
tpy = tpy - 9
Next
_Dest 0
End If
wf = wide / 440: hf = high / 410
_PutImage (treeX, treeY)-Step(440 * wf, 410 * hf), t&, 0
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 Plasma~& ()
pN = pN + 1 'dim shared cN as _Integer64, pR as integer, pG as integer, pB as integer
Plasma~& = _RGB32(127 + 127 * Sin(pR * pN), 127 + 127 * Sin(pG * pN), 127 + 127 * Sin(pB * pN))
End Function
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: pN = 0
End Sub
Function xStr$ (x, strng$)
Dim i, rtn$
For i = 1 To x
rtn$ = rtn$ + strng$
Next
xStr$ = rtn$
End Function
Function TS$ (n As Integer)
TS$ = _Trim$(Str$(n))
End Function
'from Steve Gold standard
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
Line (CX - Y, CY + X)-(CX + Y, CY + X), C
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C
Line (CX - X, CY + Y)-(CX + X, CY + Y), C
Wend
End Sub
b = b + ...
Posts: 2,171
Threads: 222
Joined: Apr 2022
Reputation:
103
12-18-2022, 10:51 PM
(This post was last modified: 12-18-2022, 10:51 PM by Pete.)
Next time you go and decorate the tree, put a heel lift in your left shoe!
Very pretty!
Pete 
Posts: 3,974
Threads: 177
Joined: Apr 2022
Reputation:
219
12-18-2022, 11:21 PM
(This post was last modified: 12-18-2022, 11:23 PM by bplus.)
(12-18-2022, 10:51 PM)Pete Wrote: Next time you go and decorate the tree, put a heel lift in your left shoe!
Very pretty!
Pete
So you picked up on the fact that right side is supposed to be higher than left, like a string of lights spiraling up the tree.
Pretty good eye.
BTW I am hoping @dbox will catch this on one of 3 forums and figure out what I am missing for QBJS.
b = b + ...
Posts: 2,171
Threads: 222
Joined: Apr 2022
Reputation:
103
> Pretty good eye.
Yep, better than the average Cyclops. I'm sure db will see it, and tree it.
Pete
Posts: 1,586
Threads: 59
Joined: Jul 2022
Reputation:
52
12-19-2022, 10:42 AM
(This post was last modified: 12-19-2022, 10:45 AM by mnrvovrfc.)
In some places and cultures, the left side is wicked. So raising the right side is considered a normal thing and "good luck". Being left-handed was horrible in a society that condemned the left side.
"AARGH I killed it! Everything I touch gets ruined." This line from Charlie Brown almost made me cry.
(12-18-2022, 11:21 PM)bplus Wrote: So you picked up on the fact that right side is supposed to be higher than left, like a string of lights spiraling up the tree.
Except the "blind" side of the tree is going to have less lights for that picture. Maybe a bit more separation between the lines that could be seen could be more realistic.
Posts: 3,974
Threads: 177
Joined: Apr 2022
Reputation:
219
12-19-2022, 11:59 AM
(This post was last modified: 12-19-2022, 12:06 PM by bplus.)
Well these comments are just desperate calls for more lights!
Code: (Select All) Option _Explicit
_Title "Programmable Tree Lights v4" ' b+ 2020-12-19 2022-12-18 fixed k$ v3 random position lights v4 more!
Randomize Timer
Const Xmax = 700, Ymax = 700, N_Rows = 10, N_Cols = 2 * N_Rows - 1
Const X_Spacer = 30, Y_Spacer = 52, X_Offset = 50
Type ColorSeed
Red As Single
Green As Single
Blue As Single
End Type
Dim Shared ColorSet(10) As ColorSeed, ColorSetIndex As Long
Dim Shared pR, pG, pB, pN, pStart, pMode$
Dim Shared As Long TG(1 To N_Cols, 1 To N_Rows), Rd(1 To N_Cols, 1 To N_Rows), Rd2(1 To N_Cols, 1 To N_Rows)
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim As Long i, row, Col, nstars, back, cc
Dim horizon, r, land
Dim l$, o$, b$, k$
' setup some color seeds in ColorSet user can change out with Shift + digit key
For i = 0 To 9 ' 10 random color seeds
resetPlasma
ColorSet(i).Red = pR: ColorSet(i).Green = pG: ColorSet(i).Blue = pB
Next
'Stringing the lights on tree, adjusted to fit mostly on the tree 2*N - 1 Pryramid
For row = 1 To 10
l$ = xStr$(2 * row - 1, "X")
o$ = xStr$(10 - row, "O")
b$ = o$ + l$ + o$
For Col = 1 To N_Cols
If Mid$(b$, Col, 1) = "O" Then TG(Col, row) = 0 Else TG(Col, row) = -1
Rd(Col, row) = Rnd * 8 - 4
Rd2(Col, row) = Rnd * 10 - 5
Next
Print b$
Next
' making the stars
horizon = Ymax - 4 * r
nstars = 100
Dim xstar(100), ystar(100), rstar(100)
For i = 1 To 100
xstar(i) = Rnd * (Xmax): ystar(i) = Rnd * horizon:
If i < 75 Then
rstar(i) = 0
ElseIf i < 95 Then
rstar(i) = 1
Else
rstar(i) = 2
End If
Next
Cls
' make a circle tree and align circles to tree with spacers and offsets with new Pyramid Scheme
'Pinetree 25, 30, 650, 600
'FOR row = 1 TO N_Rows
' FOR col = 1 TO N_Cols
' IF TG(col, row) THEN CIRCLE (col * X_Spacer + X_Offset, row * Y_Spacer), 10
' NEXT
'NEXT
' making the background
back = _NewImage(_Width, _Height, 32)
Cls
horizon = Ymax - 100
For i = 0 To horizon
Line (0, i)-(Xmax, i), _RGB32(i / horizon * 70, i / horizon * 22, 60 * (i) / horizon)
Next
land = Ymax - horizon
For i = horizon To Ymax
cc = 128 + (i - horizon) / land * 127
Line (0, i)-(Xmax, i), _RGB32(cc, cc, cc)
Next
For i = 1 To 100
fcirc xstar(i), ystar(i), rstar(i), &HFFEEEEFF
Next
_PutImage , 0, back
ColorSetIndex = 1: pMode$ = "h"
show ' avoid the pause for key checking
Do
k$ = InKey$
If Len(k$) Then
If InStr("0123456789", k$) > 0 Then
ColorSetIndex = Val(k$)
ElseIf InStr("vhde", k$) > 0 Then
pMode$ = k$
End If
End If
_PutImage , back, 0
show
_Display
_Limit 10
Loop Until _KeyDown(27)
Sub show
Dim row, prow, col
_Title "Programmable Tree Lights (0-9) Color Set: " + TS$(ColorSetIndex) + " (v, h, d, e) Mode: " + pMode$
pR = ColorSet(ColorSetIndex).Red: pG = ColorSet(ColorSetIndex).Green: pB = ColorSet(ColorSetIndex).Blue
pStart = pStart + 1
Select Case pMode$
Case "h"
For row = 1 To N_Rows
prow = pStart + row
For col = 1 To N_Cols
pN = prow
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) + 1.3 * col + 5, Plasma~&
Next
Next
Case "v"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) + 1.3 * col + 5, Plasma~&
Next
Next
Case "d"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col - row
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) + 1.3 * col + 5, Plasma~&
Next
Next
Case "e"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + row + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) + 1.3 * col + 5, Plasma~&
Next
Next
End Select
Pinetree 25, 30, 650, 600
pR = ColorSet(ColorSetIndex).Red: pG = ColorSet(ColorSetIndex).Green: pB = ColorSet(ColorSetIndex).Blue
pStart = pStart + 1
Select Case pMode$
Case "h"
For row = 1 To N_Rows
prow = pStart + row
For col = 1 To N_Cols
pN = prow
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd2(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col + 5, Plasma~&
Next
Next
Case "v"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd2(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col + 5, Plasma~&
Next
Next
Case "d"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + col - row
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd2(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col + 5, Plasma~&
Next
Next
Case "e"
For row = 1 To N_Rows
For col = 1 To N_Cols
pN = pStart + row + col
If TG(col, row) Then Lite col * X_Spacer + X_Offset + Rd2(col, row), row * Y_Spacer + 7 * Sin(col * X_Spacer + X_Offset) - 1.3 * col + 5, Plasma~&
Next
Next
End Select
End Sub
Sub Lite (x, y, c As _Unsigned Long)
Dim cR, cG, cB, cA, r
cAnalysis c, cR, cG, cB, cA
For r = 35 To 0 Step -2
fcirc x, y, r, _RGB32(cR, cG, cB, 1)
Next
fcirc x, y, 4, c
End Sub
Sub Pinetree (treeX, treeY, wide, high)
Dim bpx, bpy, tpx, bpxx, bpyy, aa, ra, tpy, ht, xs, xsh, rs, tpxx, tpyy, fra, x1, x2, y1, y2, wf, hf
'tannen baum by PeterMaria W orig 440x460
'fits here LINE (0, 0)-(440, 410), , B
Static t&
If t& = 0 Then
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 (bpxx, bpy)-(bpx, 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 (tpx, tpy)-(tpxx, 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 (x1, y1)-(x2, y2), _RGB32(Rnd * 80, Rnd * 70 + 40, Rnd * 60)
Next
Next
ra = ra - 4
tpy = tpy - 9
Next
_Dest 0
End If
wf = wide / 440: hf = high / 410
_PutImage (treeX, treeY)-Step(440 * wf, 410 * hf), t&, 0
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 Plasma~& ()
pN = pN + 1 'dim shared cN as _Integer64, pR as integer, pG as integer, pB as integer
Plasma~& = _RGB32(127 + 127 * Sin(pR * pN), 127 + 127 * Sin(pG * pN), 127 + 127 * Sin(pB * pN))
End Function
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: pN = 0
End Sub
Function xStr$ (x, strng$)
Dim i, rtn$
For i = 1 To x
rtn$ = rtn$ + strng$
Next
xStr$ = rtn$
End Function
Function TS$ (n As Integer)
TS$ = _Trim$(Str$(n))
End Function
'from Steve Gold standard
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
Line (CX - Y, CY + X)-(CX + Y, CY + X), C
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C
Line (CX - X, CY + Y)-(CX + X, CY + Y), C
Wend
End Sub
b = b + ...
Posts: 3,974
Threads: 177
Joined: Apr 2022
Reputation:
219
Did someone say, "More lights?"
Code: (Select All) _Title "More Lights" 'b+ 2021-11-28
' ref: https://justbasiccom.proboards.com/thread/759/polinom-interpolation-3-points
' mod to xmax tree ?
' 2021-12-02 start More Lights mod
Const sw = 600, sh = 700, cx = sw / 2, cy = sh / 2, treeAreaDvPI = 22707
Screen _NewImage(sw, sh, 32)
_ScreenMove 320, 40
Randomize Timer
Dim As Integer topLight
lastTopLight = 2
topLight = 50
Dim Shared pX(1 To 3), pY(1 To 3)
ReDim lx(1 To topLight), ly(1 To topLight)
moreLights:
Cls
'tree
stepper = .75 * sh / 12
For y = .125 * sh To .875 * sh Step stepper
r = (y - .125 * sh) * Sin(_Pi(1 / 12))
pX(1) = cx - r: pX(2) = cx: pX(3) = cx + r
pY(1) = y: pY(2) = y - 1.5 * stepper: pY(3) = y
'Line (pX(1), pY(1))-(pX(3), pY(3)), &HFF00FF00
For x = pX(1) To pX(3)
If Rnd < .75 Then PSet (x, para(x)), &HFF005500
Next
pY(2) = y - .5 * stepper
For x = pX(1) To pX(3)
If Rnd < .15 Then PSet (x, para(x)), &HFF005500
Next
Next
'lights
lx(1) = cx: ly(1) = .125 * sh - .5 * stepper - 5
Circle (lx(1), ly(1)), 4, &HFFFFFF88 ' topper
Circle (lx(1), ly(1)), 6, &HFFFFFFFF
For r = 3 To 30 Step 1
fcirc lx(1), ly(1), r, &H03FFFFFF
Next
dTopSq = Sqr(treeAreaDvPI / (topLight - .5 * topLight)) ' best spread of lights
For i = lastTopLight To topLight ' save 1 for top of tree
If i Mod 100 = 0 Then 'light the whole area around the tree
If i > 1200 Then
For rr = 0 To sh Step 1
fcirc cx, cy, rr, _RGB32(255, 255 - rr / 2, 200 - rr, 20)
_Limit 250 + 2 * rr
Next
GoTo finished
Else
For rr = cy To 0 Step -20
fcirc cx, cy, rr, _RGB32(255, 255, 255, 1)
Next
End If
End If
again:
x = Rnd * sw + 1: y = Rnd * sh + 1
If y > .125 * sh And y <= .875 * sh Then
If x > cx - (y - .125 * sh) * Sin(_Pi(1 / 12)) And x < cx + (y - .125 * sh) * Sin(_Pi(1 / 12)) Then
' dang have to space them out better
If i > 2 Then
ok = -1
For j = 1 To i - 1
d = ((lx(j) - x) ^ 2 + (ly(j) - y) ^ 2) ^ .5
If d < dTopSq Then ok = 0: Exit For
Next
If ok Then
rc~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
For r = 0 To 2 Step .5
Circle (x, y), r, rc~&
Next
For r = 3 To 10 Step 1
fcirc x, y, r, &H03FFFFFF
Next
lx(i) = x: ly(i) = y ' save the place
Else
GoTo again
End If
End If
Else
GoTo again
End If
Else
GoTo again
End If
Next
' Beep ' make sure we finish in reasonable amount of time ie balance number of lights to distance d
startLights = Timer
pause = pause + 2
While Timer - startLights < (3 + pause) And _KeyDown(27) = 0
Locate 1, 1: Print topLight ', dTopSq
rl = Int(Rnd * (topLight - 1)) + 1
rc~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
For r = 0 To 2 Step .5
If lx(rl) <> 0 And ly(rl) <> 0 Then Circle (lx(rl), ly(rl)), r, rc~&
Next
_Limit 15
Wend
Cls
s$ = "More lights!"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$
_Delay 2
topLight = topLight + .5 * topLight
ReDim lx(1 To topLight), ly(1 To topLight)
GoTo moreLights
finished:
Cls
_Delay 2
s$ = "Oops"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$
_Delay 2.15
s$ = "Have a Merry (and safe) Christmas!"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$
Function para (x) 'thanks tsh73 at Just Basic Forum
'uses shared arrays pX(), pY()
y = 0
For i = 1 To 3
p = 1
For j = 1 To 3
If i <> j Then
p = p * (x - pX(j)) / (pX(i) - pX(j))
End If
Next
y = y + pY(i) * p
Next
para = y
End Function
'from Steve Gold standard
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
b = b + ...
Posts: 301
Threads: 16
Joined: Apr 2022
Reputation:
51
wow bplus, I recognize that JB original routine
Posts: 2,171
Threads: 222
Joined: Apr 2022
Reputation:
103
Gee Thanks. I ran your program before sunrise, and a plane crashed into my house! On the "bright" side, I really think these onboard peanuts are underrated.
250-something was my favorite.
+ 1 on the finished spiral design, too.
Pete
Shoot first and shoot people who ask questions, later.
|
