04-09-2023, 03:05 PM (This post was last modified: 04-09-2023, 03:08 PM by bplus.)
Wouldn't that look great for an Easter Egg!
Happy Easter!
Code: (Select All)
_Title "Easter Egg Clock" 'B+ 2022-04-01
' to do - draw the whole face and then save to image then just show time with hands!!!
Randomize Timer
Const xmax = 594, ymax = 706
Const sq = 640 '<<<<<<<<<<<<<< everything is scaled to this
Const xy0 = sq / 2, dr = .6 * xy0, br = .1 * xy0, hh = .52 * xy0, mh = .6 * xy0, sh = .6 * xy0, thk = .01 * xy0
Const pi = 3.141592653589793, pm2 = 2 * pi, pd2 = pi / 2, pm2d12 = 2 * pi / 12, pm2d60 = 2 * pi / 60 ' pi stuff
Const xc = xmax / 2, yc = ymax / 2
Screen _NewImage(xmax, ymax, 32)
_ScreenMove (1200 - sq) / 2, 10
be& = _LoadImage("Brown Egg.png")
Dim Shared pr(12), pg(12), pb(12)
For i = 0 To 12
pr(i) = Rnd: pg(i) = Rnd: pb(i) = Rnd
Next
Do
_PutImage , be&, 0
t# = Timer(.001)
hour% = Int(t# / 3600)
If hour% > 12 Then showHr# = t# / 3600 - 12 Else showHr# = t# / 3600
min# = t# / 60 - hour% * 60
sec# = t# - hour% * 3600 - Int(min#) * 60
For r = dr - dr / 11 To dr + dr / 11 Step .25 ' main circle
Circle (xc, yc), r, &HFFFFFFFF
Next
lyne xc, yc - dr, 2 * dr, pd2, dr / 5.5, &HFFFFFFFF
lyne xc, yc, dr, pi * .25, dr / 5.5, &HFFFFFFFF
lyne xc, yc, dr, pi * .75, dr / 5.5, &HFFFFFFFF
For i = 0 To 59
If i Mod 5 = 0 Then
x = xc + (dr + 30) * Cos(i * pm2d60): y = yc + (dr + 30) * Sin(i * pm2d60)
drawEasterEgg x, y, 30, _Atan2(yc - y, xc - x)
Else
r = 1
Circle (xc + dr * Cos(i * pm2d60), yc + dr * Sin(i * pm2d60)), r * .5 * thk, &HFFBF0A30
End If
Next
lyne xc, yc, hh, pm2d12 * showHr# - pd2, 8 * thk, &HFF000AFF
lyne xc, yc, mh, pm2d60 * min# - pd2, 6 * thk, &HFFBF0A30
lyne xc, yc, sh, pm2d60 * sec# - pd2, 2 * thk, &HFFFFFF00
Circle (xc, yc), 3, &HFF000000
'_Limit 120
_Display
Loop Until _KeyDown(27)
Sub lyne (x0, y0, lngth, ra, thic, c As _Unsigned Long)
Dim x As Integer, y As Integer, l As Integer
While l < lngth
l = l + 1: x = x0 + l * Cos(ra): y = y0 + l * Sin(ra)
For radius = 0 To thic / 2
Circle (x, y), radius, c, BF
Next
Wend
End Sub
Sub drawEasterEgg (xc, yc, scale, radianAngle)
Static index
index = (index + 1) Mod 12
Dim r, g, b, x, y, c, a, d
r = pr(index): g = pg(index): b = pb(index)
For x = -1 To 1 Step .01
For y = -1 To 1 Step .01
If x < 0 Then c = c + .0005 Else c = c - .0005
If (x * x + (1.4 ^ x * 1.6 * y) ^ 2 - 1) <= .01 Then
If y > 0 Then
Color _RGB32(128 * (1 - y) + 128 * (1 - y) * Sin(c * r), 128 * (1 - y) + 128 * (1 - y) * Sin(c * g), 127 * (1 - y) + 127 * (1 - y) * Sin(c * b))
Else
Color _RGB32(128 + 128 * Sin(c * r), 128 + 128 * Sin(c * g), 127 + 127 * Sin(c * b))
End If
a = _Atan2(y, x)
d = scale * Sqr(x * x + y * y)
Line (xc + d * Cos(a + radianAngle), yc + d * Sin(a + radianAngle))-Step(1, 1)
End If
Next
Next
End Sub
07-23-2023, 12:16 PM (This post was last modified: 07-23-2023, 12:29 PM by bplus.)
Here are some Crop Circles while we wait for Jarvis version:
Code: (Select All)
_Title "Crop Circles #3 Mod 2 Blender" 'b+ trans and mod to QB64 2021-01-25
Const Xmax = 1024, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2, nCrops = 4
ReDim Shared CCircle As Long
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
ReDim Shared LowColr As _Unsigned Long, HighColr As _Unsigned Long, cNum As Long
HighColr = _RGB32(240, 220, 80): LowColr = _RGB32(100, 50, 10)
crop0
Do
_PutImage , CCircle, 0
While _MouseInput: Wend 'aim with mouse
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
drawShip mx, my, LowColr
If mb Then
PLC mx, my, Cx, Cy, 360
_Display
_Delay .2
FlagChange = -1
End If
If FlagChange Then
If Rnd < .5 Then
crop3
Else
cNum = (cNum + 1) Mod nCrops
Select Case cNum
Case 0: crop0
Case 1: crop1
Case 2: crop2
Case 3: crop3
End Select
End If
FlagChange = 0
End If
_Display
Loop Until _KeyDown(27)
'crop0 uses this
Sub drawc (mx, my)
ReDim cc As _Unsigned Long
cr = .5 * Sqr((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
For i = m To 0 Step -1
If i Mod 2 = 0 Then cc = HighColr Else cc = LowColr
x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
fcirc x, y, r, cc
Next
End Sub
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
Sub PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
r = Rnd ^ 2 * Rnd: g = Rnd ^ 2 * Rnd: b = Rnd ^ 2 * Rnd: hp = _Pi(.5) ' red, green, blue, half pi
ta = _Atan2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
dist = _Hypot(targetY - baseY, targetX - baseX) ' distance cannon to target
dr = targetR / dist
For r = 0 To dist Step .25
x = baseX + r * Cos(ta)
y = baseY + r * Sin(ta)
c = c + .3
fcirc x, y, dr * r, _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
Next
For rr = dr * r To 0 Step -.5
c = c + 1
LowColr = _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
fcirc x, y, rr, LowColr
Next
cAnalysis LowColr, rr, gg, bb, aa
HighColr = _RGB32(255 - rr, 255 - gg, 255 - bb)
End Sub
' PLC uses this
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
Sub drawShip (x, y, colr As _Unsigned Long) 'shipType collisions same as circle x, y radius = 30
Static ls
Dim light As Long, r As Long, g As Long, b As Long
r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
fellipse x, y, 30, 7, _RGB32(r, g, b)
For light = 0 To 5
fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
Next
ls = ls + 1
If ls > 5 Then ls = 0
End Sub
' drawShip needs
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Function rand (low, high)
rand = Rnd * (high - low) + low
End Function
Sub crop0
If CCircle Then _FreeImage CCircle
CCircle = _NewImage(_Width, _Height, 32)
_Dest CCircle
Color , HighColr
Cls
n = 12: stp = -40
For br = 360 To 0 Step stp
shft = shft + 720 / (n * n)
For i = 1 To n
x = Cx + br * Cos(_D2R(i * 360 / n + shft))
y = Cy + br * Sin(_D2R(i * 360 / n + shft))
drawc x, y
Next
Next
_Dest 0
End Sub
Sub crop1
If CCircle Then _FreeImage CCircle
CCircle = _NewImage(_Width, _Height, 32)
_Dest CCircle
Color , HighColr
Cls
ga = 137.5: bn = 800
br = 9.5: lr = .5: r = br: dr = (br - lr) / bn
hc = 180: lc = 120: cr = (hc - lc) / bn
For n = 1 To bn
x = Cx + 10 * Sqr(n) * Cos(_D2R(n * ga))
y = Cy + 10 * Sqr(n) * Sin(_D2R(n * ga))
r = r - dr
fcirc x, y, r, LowColr
Next
_Dest 0
End Sub
Sub crop2
If CCircle Then _FreeImage CCircle
CCircle = _NewImage(_Width, _Height, 32)
_Dest CCircle
'this needs big constrast of color
HighColr = _RGB32(Rnd * 80, Rnd * 80, Rnd * 80) ' field
LowColr = _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Color , HighColr
Cls
For i = 45 To Xmax Step 50
Line (i, 0)-(i + 10, Ymax), LowColr, BF
Line (0, i)-(Xmax, i + 10), LowColr, BF
Next
For y = 50 To 650 Step 50
For x = 50 To Xmax Step 50
fcirc x, y, 10, LowColr
Next
Next
_Dest 0
End Sub
Sub crop3
If CCircle Then _FreeImage CCircle
CCircle = _NewImage(_Width, _Height, 32)
_Dest CCircle
Color , HighColr
Cls
r0 = rand(1, 5) / 5: r1 = rand(1, 5) / 10: r2 = rand(1, 5) / 10
fc = rand(1, 200) / 10: st = rand(10, 500) / 1000
xol = 0
yol = 0
mol = 0
For i = 0 To 120 Step st
a0 = (i / r0) * (2 * _Pi)
a1 = ((i / r1) * (2 * _Pi)) * -1
x1 = Cx + (Sin(a0) * ((r0 - r1) * fc)) * 30
y1 = Cy + (Cos(a0) * ((r0 - r1) * fc)) * 30
x2 = x1 + (Sin(a1) * ((r2) * fc)) * 30
y2 = y1 + (Cos(a1) * ((r2) * fc)) * 30
If mol = 0 Then
mol = 1
xol = x2
yol = y2
Else
Line (xol, yol)-(x2, y2), LowColr
xol = x2
yol = y2
End If
Next
Thankyou at GareBear I hope you are inspired to try a version of your own. My first ever was the first screen shot a long time ago, I was just fooling around with drawing concentric circles off-setting them consistently and next thing I knew I had those petal like things Or find an actual crop circle that you find interesting and try and duplicate it. Sometimes you get a happy accident.
(07-23-2023, 07:35 PM)bplus Wrote: Thankyou at GareBear I hope you are inspired to try a version of your own. My first ever was the first screen shot a long time ago, I was just fooling around with drawing concentric circles off-setting them consistently and next thing I knew I had those petal like things Or find an actual crop circle that you find interesting and try and duplicate it. Sometimes you get a happy accident.
OK so this:
Code: (Select All)
_Title "SpiderMans Crop Circle" ' b+ 2023-07-24
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 50
grass~& = &HFF008800: light~& = &HFFDDFF00
Color , grass~&: Cls
cx = 300
lx = 150
rx = 550
cy = 300
dleft = (cx - lx) / 10
dright = (rx - cx) / 10
drr = (250 - 20) / 10
drl = (150 - 20) / 10
For i = 0 To 9
If i Mod 2 = 0 Then c~& = light~& Else c~& = grass~&
If i < 4 Then adj = 10 Else adj = 0
FCirc lx + dleft * i - adj, cy, lx - i * drl + 2 * adj, c~&
FCirc rx - dright * i + adj, cy, 250 - i * drr + 2 * adj, c~&
Next
FCirc 0, cy, 100, grass~&
FCirc 800, cy, 170, grass~&
FCirc 110, cy - 30, 20, light~&
FCirc 110, cy + 30, 20, light~&
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
$If WEB Then
G2D.FillCircle CX, CY, R, C
$Else
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 If
End Sub
_Title "SpiderMans Crop Circle mod" ' b+ 2023-07-24
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 50
grass~& = &HFF008800: light~& = &HFFDDFF00
Color , grass~&: Cls
cx = 300
lx = 150
rx = 550
cy = 300
dleft = (cx - lx) / 10
dright = (rx - cx) / 10
drr = (250 - 20) / 10
drl = (150 - 20) / 10
For i = 0 To 4
If i Mod 2 = 0 Then c~& = light~& Else c~& = grass~&
If i < 4 Then adj = 10 Else adj = 0
FCirc lx + dleft * i - adj, cy, lx - i * drl + 2 * adj, c~&
FCirc rx - dright * i + adj, cy, 250 - i * drr + 2 * adj, c~&
Next
FCirc 0, cy, 100, grass~&
FCirc 800, cy, 170, grass~&
FCirc 110, cy - 30, 20, light~&
FCirc 110, cy + 30, 20, light~&
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
$If WEB Then
G2D.FillCircle CX, CY, R, C
$Else
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 If
End Sub
08-17-2023, 07:17 AM (This post was last modified: 08-17-2023, 10:13 AM by bplus.)
In the middle of the night, I wake up and have an idea to slightly improve with more consistent pattern bplus old classic Particle Fountain. I just tweaked one number!
Code: (Select All)
_Title "Particle Fountain" 'b+ 2020-08-27
' 2023-08-17 tweaked a number for improved more consistent performance
Const nP = 50000
Type particle
x As Single
y As Single
dx As Single
dy As Single
r As Single
c As _Unsigned Long
End Type
Dim Shared p(1 To nP) As particle
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
For i = 1 To nP
new i
Next
Color , &HFF002200
Do
Cls
If lp < nP Then lp = lp + 10
For i = 1 To lp
p(i).dy = p(i).dy + .1
p(i).x = p(i).x + p(i).dx
p(i).y = p(i).y + p(i).dy
If p(i).x < 0 Or p(i).x > _Width Then new i
If p(i).y > _Height And p(i).dy > 0 Then
p(i).dy = -.75 * p(i).dy: p(i).y = _Height - 5
End If
Circle (p(i).x, p(i).y), p(i).r, p(i).c
Next
_Display
_Limit 60
Loop Until _KeyDown(27)
Sub new (i)
p(i).x = _Width / 2 + Rnd * 20 - 10
p(i).y = _Height + Rnd * 5
p(i).dx = Rnd * 1 - .5
p(i).dy = -10
p(i).r = Rnd * 3
p(i).c = _RGB32(50 * Rnd + 165, 50 * Rnd + 165, 255)
End Sub
dbox has a really nice version of this using pset instead of circles on QBJS. Let me see if the link to it works here:
Well according to Search here i haven't posted this one yet.
Just got it working in QBJS as well with following code:
Code: (Select All)
'Option _Explicit
'_Title "Psychedelic Star Swirl bplus 2018-03-04" ' attempt QBJS
' translated from
' Psychedelic Star Swirl.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-03
' Spiral Pearl Swirl 4 SB.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-01
' from Spiral Pearl Swirl.bas for FreeBASIC [B+=MGA] 2017-02-28
' from SdlBasic 3d version 2017-02-28
' inspired by spiral Bang
Const xmax = 1200
Const ymax = 760
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 70, 0
Dim Shared r, g, b, clr
'whatever screen size your device here is middle
Dim cx, cy, k$, size, radius, angle, sangle, x, y, r2
cx = xmax / 2: cy = ymax / 2: r = Rnd: g = Rnd: b = Rnd: k$ = " "
While _KeyDown(27) = 0
size = 1
radius = .06
angle = sangle
Cls
While radius < 800
x = Cos(angle) * radius
y = Sin(angle) * radius
r2 = (x ^ 2 + y ^ 2) ^ .5
size = 4 * r2 ^ .25
For r = size To 1 Step -4
'cc = 160 + 95 * radius/400 - r/size*120
chColor
star cx + x, cy + y, r / 3, r * 1.6, 5, Rnd * 360
Next
angle = angle - .4
radius = radius + 1
Wend
_Display ' update screen with new image
_Limit 15 '<<<<<<<<<<<<<<<<<<<<<<<<<< adjust to higher speeds if you dare
sangle = sangle + _Pi(1 / 18)
Wend
Sub star (x, y, rInner, rOuter, nPoints, angleOffset)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, i, x2, y2, x3, y3
pAngle = RAD(360 / nPoints): radAngleOffset = RAD(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
x1 = x3: y1 = y3
Next
End Sub
Sub chColor ()
clr = clr + 1
Color _RGB32(127 + 127 * Sin(r * clr), 127 + 127 * Sin(g * clr), 127 + 127 * Sin(b * clr))
If clr > 100000 Then r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd: clr = 0
End Sub
Function RAD (dA)
RAD = _Pi(dA / 180)
End Function
Or find an actual crop circle that you find interesting and try and duplicate it. Sometimes you get a happy accident.
