+- 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)
Proggies - bplus - 04-24-2022
Update: Retitle this thread "Proggies" for very short snippets to demo some method or just a fun little ditty, from me, probably a graphics thingy.
Refining what a Proggie is, I would say 100 lines more or less and only one bas source file, images graphically drawn and sound not from a 2nd file either.
Fell free to join in if you have a mod, that's my MO! Please include: "Mod Your_Avatar_Name" in the _Title at start and a date would not be unwelcome.
_________________________________________________________________________________________________________________________
Light up your balls: Double color shifting with balls example. I modified my regular drawBall sub for this demo.
MidInk is a very, very handy Function for getting a color somewhere between two colors using a fraction between 0 = the first color and 1 the 2nd color so .5 would be halfway between them.
Code: (Select All)
_Title "Light up your balls" 'b+ 2022-04-24
Screen _NewImage(800, 600, 32)
_ScreenMove 300, 40
Randomize Timer
balls = 25
Dim r(balls), x(balls), y(balls), c~&(balls)
For i = 1 To balls
r(i) = Rnd * 80 + 15
x(i) = Rnd * _Width
y(i) = Rnd * _Height
c~&(i) = _RGB32(Rnd * 100, Rnd * 100, Rnd * 100)
Next
For f## = 0 To 1 Step .01
Cls
For b = 0 To balls
rr = _Red32(c~&(b)): gg = _Green32(c~&(b)): bb = _Blue32(c~&(b))
m~& = midInk~&(rr, gg, bb, 255, 255, 255, f##)
drawBall x(b), y(b), r(b), m~&
Next
Print f##
_Display
_Limit 10
Next
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = .5 * (1 - rr / r) + .5
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
'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 - 04-26-2022
Here is some fun with my Avatar Celtic Square Knot. I used my favorite chameleon space ship and drew an animated Avatar sort of like crop circles in Space:
Code: (Select All)
Option _Explicit ' b+ changing avatar challenge entry #3 2021-05-26
_Title "Celtic Space Ship Knot 2"
Const xmax = 720
Const ymax = 720
Const cx = 360
Const cy = 360
Dim As Long temp, CSK
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim As _Unsigned Long sc1, sc2, sc3 ' ship colors
sc1 = _RGB32(255, 255, 0)
sc2 = _RGB32(200, 0, 0) ' horiontal
sc3 = _RGB32(0, 0, 160) ' vertical
Dim a, x, y, b, c, dc, db
dc = -2 / 45: db = 1 / 45
c = 240: b = 60
_MouseHide
Do
Line (0, 0)-(xmax, ymax), &H09220044, BF
a = a + _Pi(2 / 360): b = b + db: c = c + dc
If b < 60 Then b = 60: db = -db
If b > 120 Then b = 120: db = -db
If c < 120 Then c = 120: dc = -dc
If c > 240 Then c = 240: dc = -dc
x = cx + 120 * Cos(a): y = cy + 120 * Sin(a)
drawShip x, y, sc1
x = cx + c * Cos(a + _Pi(2 / 3)): y = cy + b * Sin(a + _Pi(2 / 3))
drawShip x, y, sc2
x = cx + b * Cos(a + _Pi(4 / 3)): y = cy + c * Sin(a + _Pi(4 / 3))
drawShip x, y, sc3
_Display
_Limit 60
Loop Until _KeyDown(27)
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
' ======== helper subs for drawShip that you can use for other things specially fcirc = fill_circle x, y, radius, color
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
Sub fcirc (x As Long, y As Long, R As Long, C As _Unsigned Long) 'vince version fill circle x, y, radius, color
Dim x0 As Long, y0 As Long, e As Long
x0 = R: y0 = 0: e = 0
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
e = e + 2 * y0
Else
Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
x0 = x0 - 1: e = e - 2 * x0
End If
Loop
Line (x - R, y)-(x + R, y), C, BF
End SubFeel free to take the ship out for a spin, you will need the fill circle routine, I call fcirc, and the fill ellipse routine, called fellipse.
Maybe you can have some fun animating your Avatar?
RE: Proggies - bplus - 04-26-2022
Code: (Select All)
_Title "How bplus gets full of 'mself" 'b+ 2022-04-27
Dim bplus As String: bplus = "b+": Print bplus: _Delay 1
bplus: bplus = bplus + bplus: Cls: Print bplus: _Delay 1: GoTo bplusRE: Proggies - bplus - 05-01-2022
5 - Branching
Code: (Select All)
_Title "Globe-5 branching" 'b+ 2021-11-29
DefDbl A-Z
Const ss = 730
Screen _NewImage(ss, ss, 32)
_ScreenMove 250, 10
_Font 8
Dim As Integer top, l, r, n, i
aFix = _Pi(3 / 2)
top = (5 ^ 5 - 1) / 4
Dim xp(1 To top), yp(1 To top)
For l = 0 To 4
r = l * 90
n = 5 ^ l
stepper = _Pi(2 / n)
ao = stepper / 2
'Circle (ss / 2, ss / 2), r
For a = 0 To _Pi(2) - .000001 Step stepper
i = i + 1
xp(i) = ss / 2 + r * Cos(a + ao + aFix)
yp(i) = ss / 2 + r * Sin(a + ao + aFix)
'Circle (xp(i), yp(i)), 2
's$ = _Trim$(Str$(i))
'_PrintString (xp(i) - Len(s$) * 4, yp(i) - 4), s$
'Sleep
Next
Next
For i = 1 To 156
Line (xp(i), yp(i))-(xp(5 * i - 3), yp(5 * i - 3))
Line (xp(i), yp(i))-(xp(5 * i - 2), yp(5 * i - 2))
Line (xp(i), yp(i))-(xp(5 * i - 1), yp(5 * i - 1))
Line (xp(i), yp(i))-(xp(5 * i), yp(5 * i))
Line (xp(i), yp(i))-(xp(5 * i + 1), yp(5 * i + 1))
Next
Sleep'
FizzBuzz for all primes to 11 (Bizz for 2, Fizz for 3, Buzz for 5, Fuzz for 7, Wow for 11 (standard version only does 3 and 5, Fizz and Buzz)
Code: (Select All)
_Title "FizzBuzz"
check$ = "0203050711": say$ = "BizzFizzBuzzFuzzWow"
For i = 1 To 100
Flag = 1
For j = 0 To 4
If i Mod Val(Mid$(check$, j * 2 + 1, 2)) = 0 Then Print Mid$(say$, j * 4 + 1, 4);: Flag = 0
Next
If Flag Then Print i, Else Print ,
Next'
Fuzzy a program that has been around I imagine (third attempt to post)
Code: (Select All)
_Title "Fuzzy" 'B+ trans 2019-01-04
' from Fuzzy.bas SmallBASIC 0.12.8 [B+=MGA] 2016-12-18
'Another animation, the life of Fuzzy.
'// Fuzzy Logic Fractal
'// See: Scientific American Magazine, February 1993, "A Partly True Story"
'// http://en.wikipedia.org/wiki/Fuzzy_logic
'// FB - 201108147
'// Adapted to Yabasic 2.769 by Galileo 12/2016
'// drawing area
xa = -1.2: xb = 1.2: ya = -1.2: yb = 1.2
maxIt = 64 '// max iterations allowed
'// image size
imgx = 512: imgy = 512
Screen _NewImage(imgx, imgy, 32)
offs = .8
Do
For ky = 1 To imgy
For kx = 1 To imgx
x = kx * (xb - xa) / (imgx - 1) + xa
y = ky * (yb - ya) / (imgy - 1) + ya
For i = 1 To maxIt
If Sqr(x * x + y * y) + offs > 1.1 Then Exit For
x0 = 1 - Abs(x - y)
y = 1 - Abs(y - (1 - x))
x = x0
Color _RGB32((i Mod 8) * 32, (i Mod 4) * 64, (i Mod 16) * 16)
PSet (kx, ky)
Next i
Next kx
Next ky
offs = offs - .01
_Display
_Limit 5
Loop Until offs < -.2RE: Proggies - dcromley - 05-01-2022
'Prime Numbers from 1 to 100
'2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97.
Where the heck did you come up with FizzBuzz?
_______________________________________
But I see now that 11 > sqr(100) has quite a bit to do with it.
And your Globe-5 is striking!
EDIT: ___________________________________
Fuzzy is also striking! Got to look at that!
RE: Proggies - bplus - 05-01-2022
@dcromley thanks for coming to my aid.
FizzBuzz was used as an interview question for potential programmer hires. The task was to count to 100 and if the number a multiple of 3, say Fizz instead of the number, if the number were multiple of 5 say Buzz instead of the number AND if the number a multiple of 3 and 5 say FizzBuzz instead of the number.
https://micheleriva.medium.com/about-coding-the-fizzbuzz-interview-question-9bcd08d9dfe5
The author of FizzBuzz article was also praising making your code in a way that you could come back to it and modify easily in the future.
I made FizzBuzz and then modified it for more prime numbers, the first 5, instead of just 2. So I made the task harder but answered with same number of lines of code. It's just a little ditty but I am kind of proud of it.
RE: Proggies - bplus - 05-01-2022
And Fuzzy! You'd never expect the final results when you first see the start!
Fuzzy has been passed around allot since 1993, I got my version from a guy named Galileo coding with Yabasic.
RE: Proggies - bplus - 05-01-2022
Hot off the presses today, a new proggie (for QB64) called Lights On which is old as the 86's, Fellippe did 910+ LOC here's one a little less complex.
Code: (Select All)
Option _Explicit ' avoid typo's
_Title "Lights On - all the [x, y] cells lit up." ' b+ 2022-04-27 trans Felixp7
' 2022-05-01 Mod for n levels levels
Dim Shared As Long n ' used in most all procedures
Dim As Long x, y, moves, xx, yy
Dim answer$
restart:
Input "Please enter n for n x n board to run, < 2 quits"; n
If n < 2 Or n > 10 Then GoTo restart
ReDim Shared As Long board(1 To n, 1 To n)
moves = 0
For y = 1 To n 'setup puzzle
For x = 1 To n
If (Int(Rnd * 2) Mod 2) = 0 Then
toggle x, y
End If
Next
Next
Do 'run the game
Cls
showBoard
Print "Moves: "; moves;
Input " Your move x,y "; xx, yy ' get user choice, laugh moo ha, ha
If ((xx > 0) And (xx <= n)) And ((yy > 0) And (yy <= n)) Then ' input OK
toggle xx, yy
moves = moves + 1
Else 'bad input see if want to quit
Input "Quit game? "; answer$
answer$ = UCase$(Left$(answer$, 1))
If answer$ <> "N" Then
Print "Thanks for playing!"
End
End If
End If
Loop Until lightsOn
Cls
showBoard
Print "You win in"; moves; "moves."
GoTo restart
Sub showBoard () ' default color is 7,0 white on black background unless a lit cell
Dim As Long x, y
For y = 1 To n
For x = 1 To n
Print " ";
If board(x, y) Then Color 0, 7 ' light up cell
Print "["; ns$(x); ","; ns$(y); "]";
Color 7, 0
Next
Print
Print
Next
End Sub
Sub toggle (x, y) ' toogle 4 lites around point up, down, left right
board(x, y) = Not board(x, y) ' switch x, y
If x > 1 Then board(x - 1, y) = Not board(x - 1, y)
If x < n Then board(x + 1, y) = Not board(x + 1, y)
If y > 1 Then board(x, y - 1) = Not board(x, y - 1)
If y < n Then board(x, y + 1) = Not board(x, y + 1)
End Sub
Function lightsOn () ' check if lights are all through board return -1 = true if so
Dim As Long x, y
For y = 1 To n
For x = 1 To n
If board(x, y) = 0 Then Exit Function 'something still off
Next
Next
lightsOn = -1
End Function
Function ns$ (num) ' formated number string for 2 digit integers
ns$ = Right$(" " + _Trim$(Str$(num)), 2) ' trim because QB64 adds space to pos integers
End FunctionRE: Proggies - bplus - 05-03-2022
Guts
Code: (Select All)
_Title "Guts" 'passed down through ages, I first encountered it through Richard Russel author BBC 4 Windows
' 2019-04-05 B+ translation to QB64 from: Guts.bas SmallBASIC 0.12.0 2015-11-17 MGA/B+
'modified > GUTS Original ARM BBC BASIC version by Jan Vibe, 800x600 ?
Randomize Timer
Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 60
Dim bX(15), bY(15), bZ(15), COLR(15) As _Unsigned Long
bX(1) = -100: A = 0
For N = 1 To 15
COLR(16 - N) = _RGB32(7 * N + 150, 14 * N + 45, 14 * N + 45)
Next
X1 = Rnd * xmax: Y1 = Rnd * ymax: DX1 = (Rnd * 16 + 1) * (Rnd - .5): DY1 = (Rnd * 16 + 1) * (Rnd - .5)
X2 = Rnd * xmax: Y2 = Rnd * ymax: DX2 = (Rnd * 16 + 1) * (Rnd - .5): DY2 = (Rnd * 16 + 1) * (Rnd - .5)
While _KeyDown(27) = 0
H = X1 + DX1: If H < 0 Or H > xmax Then DX1 = (Rnd * 16 + 1) * -Sgn(DX1)
H = Y1 + DY1: If H < 0 Or H > ymax Then DY1 = (Rnd * 16 + 1) * -Sgn(DY1)
X1 = X1 + DX1: Y1 = Y1 + DY1
If X2 < X1 And DX2 < 24 Then DX2 = DX2 + 1
If X2 > X1 And DX2 > -24 Then DX2 = DX2 - 1
If Y2 < Y1 And DY2 < 24 Then DY2 = DY2 + 1
If Y2 > Y1 And DY2 > -24 Then DY2 = DY2 - 1
X2 = X2 + DX2: Y2 = Y2 + DY2: A = (A + 10) Mod 360: Z = (Sin(_D2R(A) + 1)) + 2
For N = 2 To 15
bX(N - 1) = bX(N): bY(N - 1) = bY(N): bZ(N - 1) = bZ(N)
Next
bX(15) = X2: bY(15) = Y2: bZ(15) = Z
For N = 1 To 15: fcirc bX(N), bY(N), N * bZ(N) + 5, COLR(N): Next
_Display
_Limit 60
Wend
Sleep
'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
' 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 SubRE: Proggies - vince - 05-03-2022
Yes, the tapeworm simulator! One of my favourite B+ mods