+- 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 - bplus - 05-17-2022
2000th post here at Phoenix:
Code: (Select All)
_Title "Flower Wheel" ' b+ 2022-04?
Screen 12
Do
Cls
o = o + _Pi / 180
drawc _Width / 2, _Height / 2, _Width / 5, .25, 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
drawc xx, yy, a * r, a, n - 1, -o - n * _Pi / 180
Next
End If
End SubRE: Proggies - bplus - 05-17-2022
While we're here, here is another:
Code: (Select All)
_Title "Easy Spiral" 'b+ 2022-04? from Easy Lang site very Interesting! https://easylang.online
' this one inspired Johnno to post at RCBasic, https://rcbasic.freeforums.net , also an interesting site!
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 100
pi = _Pi: s = 7
Do
Cls
For c = 1 To 3000 '1320
h = c + tick
x = Sin(6 * h / pi) + Sin(3 * h)
h = c + tick * 2
y = Cos(6 * h / pi) + Cos(3 * h)
fcirc s * (20 * x + 50), s * (20 * y + 50), 2, &HFFFFFFFF
Next
_Display
_Limit 120
tick = tick + .001
Loop Until _KeyDown(27)
'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 SubRE: Proggies - bplus - 05-17-2022
Code: (Select All)
_Title "Infinite Heart" ' b+ 2022-02-14 trans from 2015
Const xmax = 698, ymax = 698, pi = 3.1415926
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 20
Color , &HFFFFFFFF: Cls
x = (xmax - 600) / 2 - 1: y = (ymax - 1.15 * 600) / 2: wide = 600
drawdblheart x, y, wide
drawdblheart x + wide / 2 - wide / 32, y + 1.15 * wide / 4 + wide / 8, wide / 16
Color _RGB32(255, 0, 0)
PSet (x + wide / 2, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 1, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 2, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 1, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 2)
Sleep
Sub drawblade (x, y, wide)
scale = wide / 200
sz = wide / 4
yax = x + wide / 2
lasty = y
steps = 230 * scale - sz
For da = 0 To 180 Step 180 / steps
Line (yax - (1 - Cos(_D2R(da))) * sz, lasty)-(yax + (1 - Cos(_D2R(da))) * sz, lasty)
lasty = lasty + 1
Next
fcirc yax - sz, y + 230 * scale - sz, sz, _RGB32(255, 255, 255)
fcirc yax + sz, y + 230 * scale - sz, sz, _RGB32(255, 255, 255)
End Sub
Sub drawdblheart (x, y, wide)
'for this heart height=wide*1.15
scale = wide / 200
sz = wide / 4
yax = x + wide / 2
lasty = y + 230 * scale
steps = 230 * scale - sz
For da = 0 To 180 Step 180 / steps
Line (yax - (1 - Cos(_D2R(da))) * sz, lasty)-(yax + (1 - Cos(_D2R(da))) * sz, lasty), _RGB32(255, 0, 0)
lasty = lasty - 1
Next
fcirc yax - sz, y + sz, sz, _RGB32(255, 0, 0)
fcirc yax + sz, y + sz, sz, _RGB32(255, 0, 0)
drawblade x + sz + sz / 2, y + sz, wide / 4
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 SubImagined very early on and drawn in SnallBASIC first I think.
RE: Proggies - bplus - 05-18-2022
Man I thought I had a decent Phoenix image but I like this one allot too!
and as requested by our Super Moderator a live fire!
![[Image: Your-Fired-Up.png]](https://i.ibb.co/4PtHXdf/Your-Fired-Up.png)
Code: (Select All)
_Title "Test Rainbow 3 add fire" ' b+ 2022-05-15
' 2022-05-17 New image for risen above the fire
w = _DesktopWidth: h = _DesktopHeight: hd2 = h / 2
Screen _NewImage(w, h, 32)
_FullScreen
img& = _LoadImage("clipart4468176.png") ' !!! thanks clipartmax !!!
' ref https://www.clipartmax.com/middle/m2H7d3G6d3i8H7Z5_phoenix-clipart-firebird-phoenix-bird-transparent-background/
dt = .001058321
For x = 0 To w
For y = 0 To h
r = Sin(1.1 * t) * hd2 - y + hd2
Line (x, y)-Step(1, 1), _RGB(-r, r - y, r), BF ' white , blue, red
Next
t = t + dt ' <<<<<<<<<<<< put this back in so the background is shaped
Next
_PutImage ((_Width - _Width(img&)) / 2, (_Height - _Height(img&)))-Step(_Width(img&), _Height(img&)), img&, 0
back& = _NewImage(_Width, _Height, 32)
_PutImage , 0, back&
xmax = w: ymax = h
xxmax = 500: yymax = 100 'pixels too slow
xstep = xmax / xxmax: ystep = ymax / yymax
Dim p~&(300) 'pallette
For i = 1 To 100
fr = 240 * i / 100 + 15
p~&(i) = _RGB32(fr, 0, 0)
p~&(i + 100) = _RGB32(255, fr, 0)
p~&(i + 200) = _RGB32(255, 255, fr)
Next
Dim f(xxmax, yymax + 2) 'fire array and seed
For x = 0 To xxmax
f(x, yymax + 1) = Int(Rnd * 2) * 300
f(x, yymax + 2) = 300
Next
While _KeyDown(27) = 0 'main fire
_PutImage , back&, 0
For x = 1 To xxmax - 1 'shift fire seed a bit
r = Rnd
If r < .15 Then
f(x, yymax + 1) = f(x - 1, yymax + 1)
ElseIf r < .3 Then
f(x, yymax + 1) = f(x + 1, yymax + 1)
ElseIf r < .35 Then
f(x, yymax + 1) = Int(Rnd * 2) * 300
End If
Next
For y = 0 To yymax 'fire based literally on 4 pixels below it like cellular automata
For x = 1 To xxmax - 1
f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
If f(x, y) > 100 Then
Line (x * xstep, y * ystep)-Step(xstep, ystep), p~&(f(x, y)), BF
End If
Next
Next
_Display
Wend
Function max (a, b)
If a > b Then max = a Else max = b
End FunctionRE: Proggies - bplus - 05-19-2022
Here is b+ mod of Cantor's Dust, a Binary Tree I did some time ago for fun, now we could call it Cantor's Tree:
Code: (Select All)
_Title "Binary Tree AKA Cantor Tree" 'b+ 2022-05-19 trans from
' binary tree.bas SmallBASIC 0.12.6 [B+=MGA] 2016-05-20
' line method added and posted with that mod 2016-05-22
xmax = 800: ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 250, 60
For i = 0 To ymax
Line (0, i)-(xmax, i), _RGB32(0, 0, 120 + 100 * i / ymax)
Next
xlength = xmax
p2 = 2
ystart = ymax
Do
xstart = xmax / p2
yheight = (ymax - 150) / p2
xlength = xlength / 2
th = .2 * yheight
For x = xstart To xmax - .5 Step 2 * xlength
cc = 180 - ((yheight / ymax) * 255)
brown~& = _RGB32(cc, cc * .5, cc * .25)
Line (x, ystart - yheight)-Step(th, yheight), brown~&, BF
Next
ystart = ystart - (ymax - 150) / p2
xhozstart = xstart / 2
For x = xhozstart To xmax - .5 Step 2 * xlength
cc = Rnd * 140: brown = _RGB32(cc, cc * .5, cc * .25)
Line (x, ystart)-(x + xlength, ystart), brown~&
Line (x, ystart - th)-Step(xlength + .5 * th, th + 2), brown~&, BF
Next
p2 = p2 * 2
Loop Until xlength / 2 < 1 Or yheight / 2 < 1
For i = 1 To 6000
Line (Rnd * xmax, 24 + Rnd * 123)-Step(Rnd * 5 + 1, Rnd * 5 + 1), _RGB32(Rnd * 45, 65 + Rnd * 190, Rnd * 15), BF
Next
SleepRE: Proggies - bplus - 05-20-2022
Code: (Select All)
_Title "So how do you like b's, move mouse wheel" 'B+ 2019-03-06
'2020-05-13 add smile
'2022-05-19 fix eye angles , smile when dist away
Const smile = 1 / 3 * _Pi
Screen 12
Dim Shared mw, dist
Color , 3
_MouseHide
While _KeyDown(27) = 0 'until esc keypress
Cls
drawFace
While _MouseInput
mw = mw + _MouseWheel
If mw > 100 Then mw = 100
If mw < 5 Then mw = 5
Wend
mx = _MouseX: my = _MouseY
dist = _Hypot(mx - 320, my - 240)
angle = _Atan2(my - 240, mx - 320)
angle1 = _Atan2(my - 240, mx - (320 - 75))
angle2 = _Atan2(my - 240, mx - (320 + 75))
x1 = 320 - 75 + 37 / 2 * Cos(angle1)
y1 = 240 + 37 / 2 * Sin(angle1)
x2 = 320 + 75 + 37 / 2 * Cos(angle2)
y2 = 240 + 37 / 2 * Sin(angle2)
FillCircle x1, y1, 37 / 2, 0
FillCircle x2, y2, 37 / 2, 0
' bee on top
For i = 1 To 8
If i Mod 2 Then bc = 0 Else bc = 14
FillCircle mx + i * 3, my + i * 3, 5, bc
Next
FillCircle mx - 15 + 20, my + 10, 8, 7
FillCircle mx + 8 + 20, my + 5, 8, 7
_Display 'prevent flicker
_Limit 60 'save CPU fan
Wend
Sub drawFace
FillCircle 320, 240, 150, 14 '<<<<<<<<<<<<<<<<< works for qb color numbers as well as rgb
FillCircle 320 - 75, 240, 37, 9
FillCircle 320 + 75, 240, 37, 9
'FillCircle 320, 240 + 80, 20, 12
arc 320, 240, 110, _Pi / 2 - smile * (.5 * mw / 100 + .5 * dist / 360), _Pi / 2 + smile * (.5 * mw / 100 + .5 * dist / 360), 12
End Sub
'fill circle
Sub FillCircle (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
' 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), 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
'use radians
Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long)
Dim al, a
'x, y origin, r = radius, c = color
'raStart is first angle clockwise from due East = 0 degrees
' arc will start drawing there and clockwise until raStop angle reached
If raStop < raStart Then
arc x, y, r, raStart, _Pi(2), c
arc x, y, r, 0, raStop, c
Else
' modified to easier way suggested by Steve
'Why was the line method not good? I forgot.
al = _Pi * r * r * (raStop - raStart) / _Pi(2)
For a = raStart To raStop Step 1 / al
Circle (x + r * Cos(a), y + r * Sin(a)), 3, c '<<< modify for smile
Next
End If
End SubRE: Proggies - SierraKen - 05-20-2022
LOL that's pretty cool B+! You could make that into a game or something. I really need to start looking at these special places on the forum, thanks for telling me.
RE: Proggies - bplus - 05-20-2022
Lander in 30 LOC (but some double parking)
Code: (Select All)
Screen _NewImage(800, 640, 32) ' b+ Lander 30 LOC (double parking cheat) 2020-11-13
g& = _NewImage(800, 640, 32)
ReDim g(-100 To 200)
Do
Cls: _KeyClear
h = 30: dx = 1: x = 3: y = 2
For i = -10 To 110
If Rnd < .5 Then h = h + Int(Rnd * 3) - 1 Else h = h
If h > 39 Then h = 39
If h < 25 Then h = 25
Line (i * 8, h * 16)-(i * 8 + 8, _Height), _RGB32(128), BF
g(i) = h
_PutImage , 0, g&
Next
While 1
_PutImage , g&, 0
Circle (x * 8 + 4, y * 16 + 8), 4, &HFF00FFFF
Circle (x * 8, y * 16 + 16), 4, &HFFFFFF00, 0, _Pi
Circle (x * 8 + 8, y * 16 + 16), 4, &HFFFFFF00, 0, _Pi
If y >= g(x - 1) Or y >= g(x + 1) Or y >= g(x) Or y >= 40 Or x < -5 Or x > 105 Then _PrintString (46 * 8, 2 * 16), "Crash": Exit While
If y = g(x - 1) - 1 And y = g(x + 1) - 1 Then _PrintString (46 * 8, 2 * 16), "Landed": Exit While
kh& = _KeyHit
If kh& = 19200 Or kh& = 97 Then dx = dx - 1
If kh& = 19712 Or kh& = 100 Then dx = dx + 1
If kh& = 18432 Or kh& = 119 Then y = y - 5
x = x + dx: y = y + 1
_Limit 2
Wend
_Delay 2
Loop
' 2020-11-15 fix off-sides x, add alternate keys: a=left d=right w=up so now arrow keys or WAD system worksRE: Proggies - bplus - 05-20-2022
Here's a nice one from Ashish:
Code: (Select All)
_Title "Arc Wave!"
Screen _NewImage(600, 600, 32)
angOffset# = 0
Do
Cls
For i = 1 To 30
r = i * 8
drawArc _Width / 2, _Height / 2, r, _Pi, _Pi + Abs(Sin(angOffset# + i / 10) * _Pi)
Next
angOffset# = angOffset# + .01
_Display
_Limit 60
Loop
Sub drawArc (xx, yy, r, s#, e#)
px = Cos(s#) * r + xx
py = Sin(s#) * r + yy
For i = s# To e# Step .02
x = Cos(i) * r + xx
y = Sin(i) * r + yy
Line (x, y)-(px, py)
px = x
py = y
Next
End SubRE: Proggies - Dav - 05-21-2022
Oh man this thread has some goodies in it! Excellent stuff.
- Dav