+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Proggies (/showthread.php?tid=162)
RE: Proggies - CharlieJV - 01-06-2024
Sweet.
Here's what I had done in BAM, nothing fancy, hoping it can be easily ported to any BASIC:
RE: Proggies - bplus - 01-29-2024
Cardioid and Beyond
Johnno called this Animated String Art in his RCBasic mod but failed to add Plasma Coloring Effect which makes a big difference IMO.
Code: (Select All)
_Title "Cardioid and Beyond" 'B+ 2019-02-17
Const xmax = 700
Const ymax = 700
Const npoints = 200
Screen _NewImage(xmax, ymax, 32)
Dim Shared pR, pG, pB, cN
CX = xmax / 2
CY = ymax / 2
DA = _Pi(2 / npoints)
R = CX - 10
For Mult = 0 To 100 Step .01
Cls
Color &HFFFFFFFF
Print "Multiple: ";
Print Using "###.##"; Mult
If Mult = Int(Mult) Then resetPlasma
Circle (CX, CY), R, _RGB32(0, 128, 0)
For i = 1 To 200
x1 = CX + R * Cos(i * DA)
y1 = CY + R * Sin(i * DA)
x2 = CX + R * Cos(Mult * i * DA)
y2 = CY + R * Sin(Mult * i * DA)
changePlasma
Line (x1, y1)-(x2, y2)
Next
_Display
_Limit 30
Next
Sub changePlasma ()
cN = cN + 1
Color _RGB(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Sub
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End SubRE: Proggies - PhilOfPerth - 01-29-2024
I never cease to be amazed at what can be achieved with a few lines of code!
Incredible!
RE: Proggies - bplus - 01-30-2024
(01-29-2024, 11:24 PM)PhilOfPerth Wrote: I never cease to be amazed at what can be achieved with a few lines of code!
Incredible!
absolutely! I wonder going through this collection and other similar little gems, how many involve sin and cos and if there is some other commonalities?
RE: Proggies - bplus - 03-17-2024
Shamrocks!
Code: (Select All)
_Title "N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one? by bplus 2018-03-09"
' Shamrock 2018-03-09 mod to lessons learned with JB version 2018-03-09 tsh tips
' from N Leafed Shamrocks 2018-03-08
' Draw Angled Heart.bas SmallBASIC 0.12.11 (B+=MGA) 2018-03-07
Randomize Timer
Const xmax = 1280
Const ymax = 740
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 70, 0
Dim counts(7)
Cls , _RGB32(60, 30, 15)
While nLeafs < 7
luck = Rnd
Select Case luck
Case Is < 1 / 625: nLeafs = 7
Case Is < 1 / 125: nLeafs = 6
Case Is < 1 / 25: nLeafs = 5
Case Is < 1 / 5: nLeafs = 4
Case Else: nLeafs = 3
End Select
counts(nLeafs) = counts(nLeafs) + 1
counts(1) = counts(1) + 1
stat$ = Str$(counts(3))
For i = 4 To 7
stat$ = stat$ + " :" + Str$(counts(i))
Next
stat$ = stat$ + " =" + Str$(counts(1))
_Title stat$ + " N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one? (1 in 625 chance) by bplus 2018-03-09"
cc1% = Rnd * 100 + 50
cc2% = Rnd * 100 + 50
While Abs(cc1% - cc2%) < 30 'for contrast of 2 colors
cc2% = Rnd * 100 + 50
Wend
xp = Rnd * (xmax - 100) + 50
yp = Rnd * (ymax - 100) + 50
size = Int(Rnd * 40) + 10
ang = Rnd * _Pi(2)
Color _RGB32(0, cc1%, 0)
drawShamrockN xp + 1, yp, size, ang, nLeafs, 1
Color _RGB32(0, cc2%, 0)
For r = 1 To size Step 1
drawShamrockN xp, yp, r, ang, nLeafs, 0
Next
_Display
_Limit 10
Wend
Sleep
'draws an arc with center at xCenter, yCenter, radius from center is arcRadius
Sub myArc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
'notes:
'you may want to adjust size and color for line drawing
'using angle measures in degrees to match Just Basic ways with pie and piefilled
'this sub assumes drawing in a CW direction if dAMeasure positive
'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
'dAStart is degrees to start Angle, due East is 0 degrees
'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
rAngleStart = RAD(dAStart)
rAngleEnd = RAD(dAMeasure) + rAngleStart
Stepper = RAD(1 / (.1 * arcRadius)) 'fixed
For rAngle = rAngleStart To rAngleEnd Step Stepper
If rAngle = rAngleStart Then
lastX = xCenter + arcRadius * Cos(rAngle)
lastY = yCenter + arcRadius * Sin(rAngle)
Else
nextX = xCenter + arcRadius * Cos(rAngle)
If nextX <= lastX Then useX = nextX - 1 Else useX = nextX + 1
nextY = yCenter + arcRadius * Sin(rAngle)
If nextY <= lastY Then useY = nextY - 1 Else useY = nextY + 1
Line (lastX, lastY)-(nextX, nextY)
lastX = nextX
lastY = nextY
End If
Next
End Sub
Function RAD (a)
RAD = _Pi(a / 180)
End Function
Function DEG (a)
DEG = a * 180 / _Pi
End Function
Sub drawHeart (x, y, r, rl, a, solid)
'local x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6
'clockwise from due East, the V
x1 = x + r * Cos(a)
y1 = y + r * Sin(a)
x2 = x + rl * Cos(a + _Pi / 2)
y2 = y + rl * Sin(a + _Pi / 2)
x3 = x + r * Cos(a + _Pi)
y3 = y + r * Sin(a + _Pi)
x4 = x + r * Cos(a + 3 * _Pi / 2)
y4 = y + r * Sin(a + 3 * _Pi / 2)
x5 = (x3 + x4) / 2
y5 = (y3 + y4) / 2
x6 = (x4 + x1) / 2
y6 = (y4 + y1) / 2
If solid Then
filltri x1, y1, x2, y2, x3, y3
filltri x2, y2, x3, y3, x4, y4
fcirc x5, y5, .5 * r * 2 ^ .5
fcirc x6, y6, .5 * r * 2 ^ .5
Else
Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
'left hump
myArc x5, y5, .5 * r * 2 ^ .5, DEG(a) + 135, 180
'right hump
myArc x6, y6, .5 * r * 2 ^ .5, DEG(a) + 225, 180
End If
End Sub
Sub drawShamrockN (x, y, r, a, nLeafed, solid)
bigR = 2.05 * r * nLeafed / (2 * _Pi) '<<<<<<<<<<<< EDIT for fuller leaves
For leaf = 0 To nLeafed - 1
x1 = x + bigR * Cos(a + leaf * 2 * _Pi / nLeafed + 3 * _Pi / 2)
y1 = y + bigR * Sin(a + leaf * 2 * _Pi / nLeafed + 3 * _Pi / 2)
drawHeart x1, y1, r, bigR, a + leaf * 2 * _Pi / nLeafed, solid
Next
End Sub
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , 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), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
Sub filltri (xx1, yy1, xx2, yy2, xx3, yy3)
'make copies before swapping
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
'thanks Andy Amaya!
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then Swap x1, x2: Swap y1, y2
If x3 < x1 Then Swap x1, x3: Swap y1, y3
If x3 < x2 Then Swap x2, x3: Swap y2, y3
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / (x2 - x1)
For x = 0 To length
Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
'lastx2% = lastx%
lastx% = Int(x + x1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1: length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / (x3 - x2)
For x = 0 To length
'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN 'works! but need 2nd? check
If Int(x + x2) <> lastx% Then
Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
End If
Next
End If
End SubRE: Proggies - bplus - 03-24-2024
Flower Wheel 2
Code: (Select All)
_Title "Flower Wheel 2" ' b+ 2024-03-24
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
Do
Cls
o = o + _Pi / 180
drawc _Width / 2, _Height / 2, _Width / 4.1, .45, 4, o
_Display
_Limit 30
Loop
Sub drawc (x, y, r, a, n, o)
If n > 0 Then
For t = 0 To _Pi(2) Step _Pi(1 / 3)
xx = x + r * Cos(t + o)
yy = y + r * Sin(t + o)
Circle (xx, yy), r, _RGB32(t * 40 - 60, t * 40 - 60, 128, n * 63)
Circle (xx, yy), r - 1, _RGB32(t * 30 - 60, t * 30 - 60, 128, n * 63)
Circle (xx, yy), r - 2, _RGB32(t * 30 - 60, t * 30 - 60, 128, n * 63)
drawc xx, yy, a * r, a, n - 1, -1.5 * o - n * _Pi / 180
Next
End If
End Suboh perfect! https://www.youtube.com/watch?v=uVXR2LYeFBI
RE: Proggies - vince - 03-25-2024
nice mod, looks like video game water
RE: Proggies - bplus - 03-26-2024
Metatrons Cube
Code: (Select All)
_Title "Metatrons Cube" ' b+ 2024-03-25
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
cx = 350: cy = 350: r = 50
a = _Pi(2 / 6)
Dim ix(5), iy(5), ox(5), oi(5)
For i = 0 To 5
ix(i) = cx + 2 * r * Cos(a * i - _Pi / 2)
iy(i) = cy + 2 * r * Sin(a * i - _Pi / 2)
ox(i) = cx + 4 * r * Cos(a * i - _Pi / 2)
oy(i) = cy + 4 * r * Sin(a * i - _Pi / 2)
Next
Circle (cx, cy), r
For i = 0 To 5
Circle (ix(i), iy(i)), r
For j = 0 To 5
Circle (ox(j), oy(j)), r
If j <> i Then
Line (ix(i), iy(i))-(ix(j), iy(j))
Line (ix(i), iy(i))-(ox(j), oy(j))
Line (ox(i), oy(i))-(ox(j), oy(j))
End If
Next
Nextsome animation
Code: (Select All)
_Title "Metatrons Cube 2" ' b+ 2024-03-26
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
cx = 350: cy = 350: r = 20
a = _Pi(2 / 6)
Dim ix(5), iy(5), ox(5), oi(5)
For cr = r To 8 * r Step .1
Cls
For i = 0 To 5
ix(i) = cx + 2 * r * Cos(a * i - _Pi / 2)
iy(i) = cy + 2 * r * Sin(a * i - _Pi / 2)
ox(i) = cx + 4 * r * Cos(a * i - _Pi / 2)
oy(i) = cy + 4 * r * Sin(a * i - _Pi / 2)
Next
Circle (cx, cy), cr, &HFF0000FF
Circle (cx, cy), cr - 1, &HFF0000FF
Circle (cx, cy), cr - 2, &HFF0000FF
For i = 0 To 5
Circle (ix(i), iy(i)), cr, &HFFFFFF00
Circle (ix(i), iy(i)), cr - 1, &HFFFFFF00
For j = 0 To 5
Circle (ox(j), oy(j)), cr, &HFFFF0000
If j <> i Then
Line (ix(i), iy(i))-(ix(j), iy(j))
Line (ix(i), iy(i))-(ox(j), oy(j))
Line (ox(i), oy(i))-(ox(j), oy(j))
End If
Next
Next
_Display
_Limit 30
NextRE: Proggies - bplus - 05-11-2024
Orbit Demo - Make Hairy Wreath
Code: (Select All)
_Title "orbit demo make hairy wreath " 'b+ 2024-05-11
Const Xmax = 700, Ymax = 700
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 290, 20
Randomize Timer
x = _Width / 2: y = _Height / 2 ' start in center of screen
pentAngle = 72 ' the angles inside a pentagram are 360 / 5 = 72 degrees
forward = 10
angle = -36
stepper = 1
r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd: dc = 0
Do Until _KeyDown(27)
orbit _Width / 2, _Height / 2, Rnd * 360, 200, x, y
loops = loops + 1
Locate 1, 1: Print loops
If loops = 10 Then Cls: loops = 0: r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd: dc = 0
While y > 0 And y < _Height
orbit x, y, angle, forward, nextx, nexty
Color _RGB32(127 + 127 * Sin(r * dc), 127 + 127 * Sin(g * dc), 127 + 127 * Sin(b * dc))
Line (x, y)-(nextx, nexty)
forward = forward - stepper
If forward < 0 Then
forward = 20
orbit _Width / 2, _Height / 2, Rnd * 360, 200, nextx, nexty
angle = Rnd * 360
pentAngle = Rnd * 90
If Rnd < .5 Then pentAngle = -pentAngle
stepper = Rnd * 3 + .5
dc = dc + .00936
End If
angle = angle + pentAngle ' the absolute angle from 0 degrees accumulates at every turn
x = nextx: y = nexty ' restart where we left off
_Limit 2000
Wend
Loop
' !!!!!! featuring the use of this SUB routine !!!!
Sub orbit (X_Origin, Y_Origin, Degrees, Radius, xOut, yOut) ' all default single should be ok
xOut = X_Origin + Radius * Cos(_D2R(Degrees))
yOut = Y_Origin + Radius * Sin(_D2R(Degrees))
End SubRE: Proggies - bplus - 06-14-2024
Curlies
Code: (Select All)
Screen _NewImage(1200, 700, 12)
_ScreenMove 40, 20
Color 15, 4
For j = 3.14 To 6.28 Step .0314
Cls: c = c + 1: Print c, "press any..."
x = 600: x1 = x: y = 350: f = 0
For z = 1 To 200000
f = f + j: g = f * f * .25
x = x + Cos(g): x1 = x1 - Cos(g)
y = y + Sin(g): p = z Mod 255
PSet (x, y), _RGB(p, p, p)
PSet (x1, y), _RGB(p, p, p)
Next
Sleep
Next