diff --git a/.gitignore b/.gitignore index dfcfd56..015ca6f 100644 --- a/.gitignore +++ b/.gitignore @@ -348,3 +348,5 @@ MigrationBackup/ # Ionide (cross platform F# VS Code tools) working folder .ionide/ + +*.exe diff --git a/.vscode/launch.json b/.vscode/launch.json new file mode 100644 index 0000000..f5e5906 --- /dev/null +++ b/.vscode/launch.json @@ -0,0 +1,26 @@ +{ + "version": "0.2.0", + "configurations": [ + { + "name": "QB64 Build and Run", + "type": "QB64", + "request": "launch", + "command": "${config:qb64.installPath}/qb64.exe -c -x \"${fileDirname}\\${fileBasename}\" -o \"${fileDirname}\\${fileBasenameNoExtension}.exe\" -x; if ($?) { cd \"${fileDirname}\"; start \"${fileDirname}\\${fileBasenameNoExtension}.exe\"}", + "terminalName": "QB64", + "terminalIndex": -1, + "showTerminal": true, + "linux": { + "name": "QB64 Build and Run", + "type": "QB64", + "request": "launch", + "command": "${config:qb64.installPath}/qb64 '${fileDirname}/${fileBasename}' -c -x -o '${fileDirname}/${fileBasenameNoExtension}' && '${fileDirname}/${fileBasenameNoExtension}'", + }, + "osx": { + "name": "QB64 Build and Run", + "type": "QB64", + "request": "launch", + "command": "${config:qb64.installPath}/qb64 '${fileDirname}/${fileBasename}' -c -x -o '${fileDirname}/${fileBasenameNoExtension}'; mv '${fileDirname}/${fileBasenameNoExtension}' '${fileDirname}/${fileBasenameNoExtension}.run'; '${fileDirname}/${fileBasenameNoExtension}.run'", + } + } + ] + } \ No newline at end of file diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..c133ecc --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,43 @@ +{ + "files.exclude": { + "**/*.bas-bak": true, + "**/*.bi-bak": true, + "**/*.bm-bak": true, + "**/*.cmp-out": true, + "**/*.json-bak": true, + "**/desktop.ini": true + }, + "files.defaultLanguage": "QB64", + "editor.multiCursorModifier": "ctrlCmd", + "editor.tokenColorCustomizations": { + "textMateRules": [ + { + "scope": [ + "graphics.QB64" + ], + "settings": { + "foreground": "#00ff2a" + } + }, + { + "scope": [ + "sound.QB64" + ], + "settings": { + "foreground": "#f0b411" + } + }, + { + "scope": [ + "keyword.control.QB64" + ], + "settings": { + "foreground": "#d611f0" + } + } + ] + }, + "editor.detectIndentation": false, + "editor.insertSpaces": true, + "editor.tabSize": 2 + } \ No newline at end of file diff --git a/.vscode/tasks.json b/.vscode/tasks.json new file mode 100644 index 0000000..438186d --- /dev/null +++ b/.vscode/tasks.json @@ -0,0 +1,99 @@ +{ + "version": "2.0.0", + "tasks": [ + { + "label": "build", + "type": "shell", + "command": "${config:qb64.installPath}/qb64.exe", + "args": [ + "-c", + "'${fileDirname}/${fileBasename}'", + "-x", + "-o", + "'${fileDirname}/${fileBasenameNoExtension}.exe'" + ], + "linux": { + "command": "${config:qb64.installPath}/qb64", + "args": [ + "-c", + "'${fileDirname}/${fileBasename}'", + "-x", + "-o", + "'${fileDirname}/${fileBasenameNoExtension}'" + ] + }, + "osx": { + "command": "${config:qb64.installPath}/qb64", + "args": [ + "-c", + "'{fileDirname}/${fileBasename}'", + "-x", + "-o", + "'${fileDirname}/${fileBasenameNoExtension}'" + ] + }, + "group": { + "kind": "build", + "isDefault": true + }, + "presentation": { + "reveal": "always", + "panel": "new" + } + }, + { + "label": "Clean QB64", + "type": "shell", + "options": { + "cwd": "${config:qb64.installPath}/internal", + }, + "command": "${config:qb64.installPath}/internal/clean.bat", + "linux": { + "command":"${config:qb64.installPath}/internal/clean.sh", + }, + "osx": { + "command":"${config:qb64.installPath}/internal/clean.sh", + }, + "group": { + "kind": "build", + "isDefault": false + }, + "presentation": { + "reveal": "always", + "panel": "new" + } + }, + { + "label": "Exe Compact", + "type": "shell", + "windows": { + "command": "compact", + "args": [ + "/c", + "/exe:lzx", + "\"${fileDirname}\\${fileBasenameNoExtension}.exe\"" + ] + }, + "linux": { + "command": "upx", + "args": [ + "${fileDirname}/${fileBasenameNoExtension}.exe" + ] + }, + "osx": { + "command": "upx", + "args": [ + "${fileDirname}/${fileBasenameNoExtension}.exe" + ] + }, + "group": { + "kind": "build", + "isDefault": false + }, + "presentation": { + "reveal": "always", + "panel": "new" + } + } + ] + } \ No newline at end of file diff --git a/code/bplus/ascii fireworks mod 2 seed n sound.zip b/code/bplus/ascii fireworks mod 2 seed n sound.zip new file mode 100644 index 0000000..f9dd02a Binary files /dev/null and b/code/bplus/ascii fireworks mod 2 seed n sound.zip differ diff --git a/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope.bas b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope.bas new file mode 100644 index 0000000..034df4a --- /dev/null +++ b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope.bas @@ -0,0 +1,38 @@ +_Title "Bilateral Kaleidoscope" ' 2023-01-02 NOT May 2022 version by b+ +Const sh = 600, sw = 800 +Screen _NewImage(sw, sh, 32) +'_ScreenMove 200, 100 +_FullScreen +Randomize Timer +Do + If lc = 0 Then + dx1 = 0: dx2 = 0: dy1 = 0: dy2 = 0: dr = 0: dg = 0: db = 0 + x1 = sw * Rnd: y1 = sh * Rnd: x2 = sw * Rnd: y2 = sh * Rnd: r = Rnd * 255: g = Rnd * 255: b = Rnd * 255 + While dx1 = 0: dx1 = Rnd * 6 - 3: Wend + While dx2 = 0: dx2 = Rnd * 6 - 3: Wend + While dy1 = 0: dy1 = Rnd * 6 - 3: Wend + While dy2 = 0: dy2 = Rnd * 6 - 3: Wend + While dr = 0: dr = Rnd * 4 - 2: Wend + While dg = 0: dg = Rnd * 4 - 2: Wend + While db = 0: db = Rnd * 4 - 2: Wend + End If + Line (x1, y1)-(x2, y2), _RGB32(r, g, b, 100) + Line (sw - x1, y1)-(sw - x2, y2), _RGB32(r, g, b, 100) + Line (x1, sh - y1)-(x2, sh - y2), _RGB32(r, g, b, 100) + Line (sw - x1, sh - y1)-(sw - x2, sh - y2), _RGB32(r, g, b, 100) + x1 = Remainder(x1 + dx1, sw) + x2 = Remainder(x2 + dx2, sw) + y1 = Remainder(y1 + dy1, sh) + y2 = Remainder(y2 + dy2, sh) + r = Remainder(r + dr, 255) + g = Remainder(g + dr, 255) + b = Remainder(b + db, 255) + lc = lc + 1 + If ((Rnd > .999) And (lc > 300)) Or (lc > 4000) Then Sleep 1: Cls: lc = 0 + _Limit 60 +Loop Until _KeyDown(27) + +Function Remainder (n, d) + If d = 0 Then Exit Function + Remainder = n - (d) * Int(n / (d)) +End Function diff --git a/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope2.bas b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope2.bas new file mode 100644 index 0000000..9342dc5 --- /dev/null +++ b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope2.bas @@ -0,0 +1,56 @@ +_Title "Bilateral Kaleidoscope 2 - shape shifter" ' 2023-01-02 NOT May 2022 version by b+ +Const sh = 600, sw = 800: linelimit = 400 +Type lion + As Single x1, y1, x2, y2 + As _Unsigned Long c +End Type +Dim Shared l(linelimit) As lion, li As Long +Screen _NewImage(sw, sh, 32) +'_ScreenMove 200, 100 +_FullScreen +Randomize Timer +Do + If lc = 0 Then + dx1 = 0: dx2 = 0: dy1 = 0: dy2 = 0: dr = 0: dg = 0: db = 0 + x1 = sw * Rnd: y1 = sh * Rnd: x2 = sw * Rnd: y2 = sh * Rnd: r = Rnd * 255: g = Rnd * 255: b = Rnd * 255 + While dx1 = 0: dx1 = Rnd * 6 - 3: Wend + While dx2 = 0: dx2 = Rnd * 6 - 3: Wend + While dy1 = 0: dy1 = Rnd * 6 - 3: Wend + While dy2 = 0: dy2 = Rnd * 6 - 3: Wend + While dr = 0: dr = Rnd * 4 - 2: Wend + While dg = 0: dg = Rnd * 4 - 2: Wend + While db = 0: db = Rnd * 4 - 2: Wend + End If + Cls + For i = 0 To li + Line (l(i).x1, l(i).y1)-(l(i).x2, l(i).y2), l(i).c + Line (sw - l(i).x1, l(i).y1)-(sw - l(i).x2, l(i).y2), l(i).c + Line (l(i).x1, sh - l(i).y1)-(l(i).x2, sh - l(i).y2), l(i).c + Line (sw - l(i).x1, sh - l(i).y1)-(sw - l(i).x2, sh - l(i).y2), l(i).c + Next + x1 = Remainder(x1 + dx1, sw) + x2 = Remainder(x2 + dx2, sw) + y1 = Remainder(y1 + dy1, sh) + y2 = Remainder(y2 + dy2, sh) + r = Remainder(r + dr, 255) + g = Remainder(g + dr, 255) + b = Remainder(b + db, 255) + If li < linelimit Then + li = li + 1 + l(li).x1 = x1: l(li).y1 = y1: l(li).x2 = x2: l(li).y2 = y2: l(li).c = _RGB32(r, g, b, 100) + Else + For i = 0 To linelimit - 1 + l(i) = l(i + 1) + Next + l(linelimit).x1 = x1: l(linelimit).y1 = y1: l(linelimit).x2 = x2: l(linelimit).y2 = y2: l(linelimit).c = _RGB32(r, g, b, 100) + End If + lc = lc + 1 + If lc > 4000 Then Sleep 1: Cls: lc = 0: li = 0 + _Display + _Limit 100 +Loop Until _KeyDown(27) + +Function Remainder (n, d) + If d = 0 Then Exit Function + Remainder = n - (d) * Int(n / (d)) +End Function diff --git a/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope_using_maptriagle.bas b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope_using_maptriagle.bas new file mode 100644 index 0000000..bca2c27 --- /dev/null +++ b/code/bplus/bilateral_kaleidoscope/bilateral_kaleidoscope_using_maptriagle.bas @@ -0,0 +1,33 @@ +_Title "Kaleidoscope" 'b+ 2022-05-24 +' it so obvious to use maptriangle! +Randomize Timer +Dim Shared sH, sW, sHd2, sWd2 +sH = 700: sW = 700: sHd2 = sH / 2: sWd2 = sW / 2 +Screen _NewImage(700, 700, 32) +_ScreenMove 290, 0 +Do Until _KeyDown(27) + If Rnd > .05 Then Line (0, 0)-(sW - 1, sH - 1), _RGB32(0, 0, 0, 10), BF Else Cls + n = (n + 1) Mod 66 + 4 + If n Mod 2 Then n = n + 1 + ReDim px(0 To n - 1), py(0 To n - 1) + circleDivN = _Pi(2 / n) + For i = 0 To n - 1 + px(i) = sWd2 + sHd2 * Cos(i * circleDivN) + py(i) = sHd2 + sHd2 * Sin(i * circleDivN) + Next + For i = 1 To 700 + Line (Rnd * sW, Rnd * sH)-Step(Rnd * 5, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF + Circle (Rnd * sW, Rnd * sH), Rnd * 8 + 2, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255) + Next + For i = 1 To 30 + w = Rnd * 700 + Line (sWd2 - w / 2, Rnd * sH)-Step(w, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF + Next + For s = 0 To n - 1 + For i = 0 To n - 1 + _MapTriangle (sWd2, sHd2)-(px((i + s) Mod n), py((i + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)), 0 To(sWd2, sHd2)-(px((i + 2 + s) Mod n), py((i + 2 + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)) + Next + Next + _Display + _Limit 2 +Loop diff --git a/code/bplus/bubble_universe/bubble_universe.bas b/code/bplus/bubble_universe/bubble_universe.bas new file mode 100644 index 0000000..e26aa46 --- /dev/null +++ b/code/bplus/bubble_universe/bubble_universe.bas @@ -0,0 +1,35 @@ +Const xmax = 512, ymax = 512 +_Title "Bubble Universe - ESC to exit" ' from johnno at RCBasic forum 2022-11-14 +Screen _NewImage(xmax, ymax, 32) +' --------------- +' Paul Dunn posted this code but for SpecBAS in a facebook group. +' It looked so cool that I had to rewrite it in Naalaa 7. Marcus +' +' bplus QB64 Mod of RCB version by Johnno56 +TAU = 6.283185307179586 +n = 200 +r = TAU / 235 +x = 0 +y = 0 +v = 0 +t = 0 +hw = xmax / 2 +hh = ymax / 2 +Do + Color _RGB32(0, 0, 0) + Cls + For i = 0 To n + For j = 0 To n + u = Sin(i + v) + Sin(r * i + x) + v = Cos(i + v) + Cos(r * i + x) + x = u + t + Color _RGB(i, j, 99) + PSet (hw + u * hw * 0.4, hh + v * hh * 0.4) + Next + Next + t = t + 0.001 ' slowed way way down from .025 + _Display + _Limit 30 +Loop Until _KeyDown(27) + + diff --git a/code/bplus/celtic_knot/celtic_knot.bas b/code/bplus/celtic_knot/celtic_knot.bas new file mode 100644 index 0000000..ddabcce --- /dev/null +++ b/code/bplus/celtic_knot/celtic_knot.bas @@ -0,0 +1,87 @@ + +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 Sub + diff --git a/code/bplus/explosions/explosions.bas b/code/bplus/explosions/explosions.bas new file mode 100644 index 0000000..08dc4c7 --- /dev/null +++ b/code/bplus/explosions/explosions.bas @@ -0,0 +1,138 @@ +'https://qb64.boards.net/thread/98/explosions +Option _Explicit +_Title "Explosions test" 'b+ revisit 2023-02-08 + +Const xmax = 800, ymax = 600 +Screen _NewImage(xmax, ymax, 32) +_ScreenMove (1280 - xmax) / 2 + 30, (760 - ymax) / 2 +Randomize Timer +Type particle ' ===================================== Explosions Setup + As Long life, death + As Single x, y, dx, dy, r + As _Unsigned Long c +End Type + +Dim Shared nDots +nDots = 2000 +ReDim Shared dots(nDots) As particle ' ============================== +Dim As Long mx, my, mb + +Do + Cls + While _MouseInput: Wend + mx = _MouseX: my = _MouseY: mb = _MouseButton(1) + Circle (mx, my), 5 + If mb Then + ' explode sets up dots and runs them out over several loops + Explode mx, my, 150, 120, 60, 30 + Circle (mx, my), 150 + _Display + _Delay .2 ' alittle delay for user to release mousebutton + End If + DrawDots + _Display + _Limit 30 ' or 60 +Loop +Print "done" + +' This sub sets up Dots array to display with DrawDots +' this sub uses rndCW and requires some setup in main +Sub Explode (x, y, spread, cr, cg, cb) + ' x, y explosion origin + ' spread is diameter of area to cover from it number of dots, number of frames and speed are calculated + ' cr, cg, cb for _RGB32() color +-20 + + ' setup for explosions in main + 'Type particle ' ===================================== Explosions Setup + ' As Long life, death + ' As Single x, y, dx, dy, r + ' As _Unsigned Long c + 'End Type + + 'Dim Shared nDots + 'nDots = 2000 + 'ReDim Shared dots(nDots) As particle ' ============================== + + Dim As Long i, dotCount, newDots + Dim angle, speed, rd, rAve, frames + newDots = spread / 2 ' quota + frames = spread / 5 + speed = spread / frames ' 0 to spread in frames + rAve = .5 * spread / Sqr(newDots) + For i = 1 To nDots ' find next available dot + If dots(i).life = 0 Then + dots(i).life = 1 ' turn on display + dots(i).death = frames + angle = _Pi(2 * Rnd) + dots(i).x = x: dots(i).y = y ' origin + rd = Rnd + dots(i).dx = rd * speed * Cos(angle) ' moving + dots(i).dy = rd * speed * Sin(angle) + dots(i).r = RndCW(rAve, rAve) ' radius + dots(i).c = _RGB32(cr + Rnd * 40 - 20, cg + Rnd * 40 - 20, cb + Rnd * 40 - 20) 'color + dotCount = dotCount + 1 + If dotCount >= newDots Then Exit Sub + End If + Next +End Sub + +' this sub uses FCirc and requires some setup in main +Sub DrawDots ' this sub needs fcirc to Fill Circles and Sub Explode sets up the Dots to draw. + ' setup in main for explosions + 'Type particle ' ===================================== Explosions Setup + ' As Long life, death + ' As Single x, y, dx, dy, r + ' As _Unsigned Long c + 'End Type + + 'Dim Shared nDots + 'nDots = 2000 + 'ReDim Shared dots(nDots) As particle ' ============================== + + Dim As Long i + For i = 1 To nDots ' display of living particles + If dots(i).life Then + FCirc dots(i).x, dots(i).y, dots(i).r, dots(i).c + ' update dot + If dots(i).life + 1 >= dots(i).death Then + dots(i).life = 0 + Else + dots(i).life = dots(i).life + 1 + ' might want air resistence or gravity added to dx or dy + dots(i).x = dots(i).x + dots(i).dx + dots(i).y = dots(i).y + dots(i).dy + If dots(i).x < 0 Or dots(i).x > xmax Then dots(i).life = 0 + If dots(i).y < 0 Or dots(i).y > ymax Then dots(i).life = 0 + dots(i).r = dots(i).r * 1 - (dots(i).life / dots(i).death) ' puff! + If dots(i).r <= 0 Then dots(i).life = 0 + End If + End If + Next +End Sub + +'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, 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 + +Function RndCW (C As Single, range As Single) 'center +/-range weights to center + RndCW = C + Rnd * range - Rnd * range +End Function diff --git a/code/bplus/explosions/spider_pixel_collisions.bas b/code/bplus/explosions/spider_pixel_collisions.bas new file mode 100644 index 0000000..c4d5913 --- /dev/null +++ b/code/bplus/explosions/spider_pixel_collisions.bas @@ -0,0 +1,342 @@ +'https://qb64.boards.net/thread/90/pixel-collision-app +Option _Explicit +_Title "Spider Pixel Collisions" 'b+ 2023-01-23 !!! Speaker volume around 20 maybe! !!! + +' !!!!!!!!!!!!!!!!!!! Escape to Quit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +Randomize Timer +Dim Shared xmax As Integer, ymax As Integer +xmax = _DesktopWidth +ymax = _DesktopHeight +Const nSpinners = 30 +Type SpinnerType + x As Single + y As Single + dx As Single + dy As Single + a As Single + sz As Single + c As _Unsigned Long +End Type +Dim Shared s(1 To nSpinners) As SpinnerType + +Type TypeSPRITE ' sprite definition ' for Terry's PixelCollide +++++++++++++++++++ + image As Long ' sprite image + x1 As Integer ' upper left X + y1 As Integer ' upper left Y + x2 As Integer ' lower right X + y2 As Integer ' lower right Y +End Type + +Type TypePOINT ' x,y point definition + x As Integer ' x coordinate + y As Integer ' y coordinate +End Type ' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +Dim power1, power2, power +Dim As Long i, imoved, j, iImg, jImg, lc, i2, sc +Dim As TypeSPRITE sIo, sJo +Dim intxy As TypePOINT +sc = _ScreenImage +Screen _NewImage(xmax, ymax, 32) +_FullScreen +For i = 1 To nSpinners + newSpinner i +Next +i2 = 1 +While InKey$ <> Chr$(27) + _PutImage , sc, 0 + lc = lc + 1 + If lc Mod 100 = 99 Then + lc = 0 + If i2 < nSpinners Then i2 = i2 + 1 + End If + For i = 1 To i2 + + 'ready for collision check + + ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++++++ + iImg = _NewImage(140, 140, 32) + _Dest iImg + drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c + _Dest 0 + sIo.x1 = s(i).x - 70 + sIo.y1 = s(i).y - 70 + sIo.x2 = sIo.x1 + 140 + sIo.y2 = sIo.y1 + 140 ' this meets requirements for collision obj1 + sIo.image = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + s(i).a = _Atan2(s(i).dy, s(i).dx) + power1 = (s(i).dx ^ 2 + s(i).dy ^ 2) ^ .5 + imoved = 0 + For j = i + 1 To i2 + + ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++ + jImg = _NewImage(140, 140, 32) + _Dest jImg + drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c + _Dest 0 + sJo.x1 = s(j).x - 70 + sJo.y1 = s(j).y - 70 + sJo.x2 = sIo.x1 + 140 + sJo.y2 = sIo.y1 + 140 ' this meets requirements for collision obj1 + sJo.image = jImg + + 'PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT) + If PixelCollide(sIo, sJo, intxy) Then '+++++++++++++++++++++++++++++++++++++++ + '_SndPlay bump + Sound Rnd * 5000 + 1000, .1 * Rnd + If Rnd > .7 Then + imoved = 1 + s(i).a = _Atan2(s(i).y - s(j).y, s(i).x - s(j).x) + s(j).a = _Atan2(s(j).y - s(i).y, s(j).x - s(i).x) + 'update new dx, dy for i and j balls + power2 = (s(j).dy ^ 2 + s(j).dy ^ 2) ^ .5 + power = (power1 + power2) / 2 + s(i).dx = power * Cos(s(i).a) + s(i).dy = power * Sin(s(i).a) + s(j).dx = power * Cos(s(j).a) + s(j).dy = power * Sin(s(j).a) + s(i).x = s(i).x + s(i).dx + s(i).y = s(i).y + s(i).dy + s(j).x = s(j).x + s(j).dx + s(j).y = s(j).y + s(j).dy + Exit For + End If + End If + _FreeImage jImg + Next + If imoved = 0 Then + s(i).x = s(i).x + s(i).dx + s(i).y = s(i).y + s(i).dy + End If + If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i + 'drawSpinner s(i).x, s(i).y, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c + _PutImage (s(i).x - 70, s(i).y - 70), iImg, 0 + _FreeImage iImg + Next + _Display + _Limit 15 +Wend + +Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color? + Dim r + s(i).sz = Rnd * .25 + .5 + If Rnd < .5 Then r = -1 Else r = 1 + s(i).dx = (s(i).sz * Rnd * 8) * r * 2 + 2: s(i).dy = (s(i).sz * Rnd * 8) * r * 2 + 2 + r = Int(Rnd * 4) + Select Case r + Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy + Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy + Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx + Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx + End Select + r = Rnd * 155 + 40 + s(i).c = _RGB32(Rnd * .5 * r, r, Rnd * .25 * r) +End Sub + +Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long) + Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green + Static switch As Integer + switch = switch + 2 + switch = switch Mod 16 + 1 + red = _Red32(c): green = _Green32(c): blue = _Blue32(c) + r = 10 * scale + x1 = x + r * Cos(heading): y1 = y + r * Sin(heading) + r = 2 * r 'lg lengths + For lg = 1 To 8 + If lg < 5 Then + a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10) + Else + a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10) + End If + x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a) + drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5) + If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1 + a1 = a + d * _Pi(1 / 12) + x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1) + drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8) + rd = Int(Rnd * 8) + 1 + a2 = a1 + d * _Pi(1 / 8) * rd / 8 + x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2) + drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12) + Next + r = r * .5 + fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5) + x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12)) + fcirc x2, y2, r * .2, &HFF000000 + x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12)) + fcirc x2, y2, r * .2, &HFF000000 + r = r * 2 + x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi) + TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue) +End Sub + +Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long) + Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6 + a = _Atan2(y2 - y1, x2 - x1) + a1 = a + _Pi(1 / 2) + a2 = a - _Pi(1 / 2) + x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1) + x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2) + x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1) + x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2) + fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c + fcirc x1, y1, r1, c + fcirc x2, y2, r2, c +End Sub + +'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4 +Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long) + ftri idest&, x1, y1, x2, y2, x4, y4, c + ftri idest&, x3, y3, x4, y4, x1, y1, c +End Sub + +Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long) + Dim a& + a& = _NewImage(1, 1, 32) + _Dest a& + PSet (0, 0), K + _Dest idest& + _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3) + _FreeImage a& '<<< this is important! +End Sub + +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, 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 TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long) + Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single + Dim prc As _Unsigned Long, tef As Long + prc = _RGB32(255, 255, 255, 255) + If a > b Then max = a + 1 Else max = b + 1 + mx2 = max + max + tef = _NewImage(mx2, mx2) + _Dest tef + _Source tef 'point wont read without this! + For k = 0 To 6.2832 + .05 Step .1 + i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang) + j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang) + If k <> 0 Then + Line (lasti, lastj)-(i, j), prc + Else + PSet (i, j), prc + End If + lasti = i: lastj = j + Next + Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer + For y = 0 To mx2 + x = 0 + While Point(x, y) <> prc And x < mx2 + x = x + 1 + Wend + xleft(y) = x + While Point(x, y) = prc And x < mx2 + x = x + 1 + Wend + While Point(x, y) <> prc And x < mx2 + x = x + 1 + Wend + If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x + Next + _Dest destHandle& + For y = 0 To mx2 + If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF + Next + _FreeImage tef +End Sub + +Function PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT) + '-------------------------------------------------------------------------------------------------------- + '- Checks for pixel perfect collision between two rectangular areas. - + '- Returns -1 if in collision - + '- Returns 0 if no collision - + '- - + '- obj1 - rectangle 1 coordinates - + '- obj2 - rectangle 2 coordinates - + '--------------------------------------------------------------------- + Dim x%, y% + Dim x1%, y1% ' upper left x,y coordinate of rectangular collision area + Dim x2%, y2% ' lower right x,y coordinate of rectangular collision area + Dim Test1& ' overlap image 1 to test for collision + Dim Test2& ' overlap image 2 to test for collision + Dim Hit% ' -1 (TRUE) if a collision occurs, 0 (FALSE) otherwise + Dim Osource& ' original source image handle + Dim p1~& ' alpha value of pixel on image 1 + Dim p2~& ' alpha value of pixel on image 2 + + Obj1.x2 = Obj1.x1 + _Width(Obj1.image) - 1 ' calculate lower right x,y coordinates of both objects + Obj1.y2 = Obj1.y1 + _Height(Obj1.image) - 1 + Obj2.x2 = Obj2.x1 + _Width(Obj2.image) - 1 + Obj2.y2 = Obj2.y1 + _Height(Obj2.image) - 1 + Hit% = 0 ' assume no collision + + '+-------------------------------------+ + '| perform rectangular collision check | + '+-------------------------------------+ + + If Obj1.x2 >= Obj2.x1 Then ' rect 1 lower right X >= rect 2 upper left X ? + If Obj1.x1 <= Obj2.x2 Then ' rect 1 upper left X <= rect 2 lower right X ? + If Obj1.y2 >= Obj2.y1 Then ' rect 1 lower right Y >= rect 2 upper left Y ? + If Obj1.y1 <= Obj2.y2 Then ' rect 1 upper left Y <= rect 2 lower right Y ? + + '+-----------------------------------------------------------------------+ + '| rectangular collision detected, perform pixel perfect collision check | + '+-----------------------------------------------------------------------+ + + If Obj2.x1 <= Obj1.x1 Then x1% = Obj1.x1 Else x1% = Obj2.x1 ' calculate overlapping coordinates + If Obj2.y1 <= Obj1.y1 Then y1% = Obj1.y1 Else y1% = Obj2.y1 + If Obj2.x2 <= Obj1.x2 Then x2% = Obj2.x2 Else x2% = Obj1.x2 + If Obj2.y2 <= Obj1.y2 Then y2% = Obj2.y2 Else y2% = Obj1.y2 + Test1& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) ' make overlap image of object 1 + Test2& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) ' make overlap image of object 2 + _PutImage (-(x1% - Obj1.x1), -(y1% - Obj1.y1)), Obj1.image, Test1& ' place overlap area of object 1 + _PutImage (-(x1% - Obj2.x1), -(y1% - Obj2.y1)), Obj2.image, Test2& ' place overlap area of object 2 + x% = 0 ' reset overlap area coordinate counters + y% = 0 + Osource& = _Source ' remember calling source + Do ' begin pixel collide loop + _Source Test1& ' read from image 1 + p1~& = _Alpha32(Point(x%, y%)) ' get alpha level of pixel + _Source Test2& ' read from image 2 + p2~& = _Alpha32(Point(x%, y%)) ' get alpha level of pixel + If (p1~& <> 0) And (p2~& <> 0) Then ' are both pixels transparent? + Hit% = -1 ' no, there must be a collision + Intersect.x = x1% + x% ' return collision coordinates + Intersect.y = y1% + y% ' + End If + x% = x% + 1 ' increment column counter + If x% > _Width(Test1&) - 1 Then ' beyond last column? + x% = 0 ' yes, reset x + y% = y% + 1 ' increment row counter + End If + Loop Until y% > _Height(Test1&) - 1 Or Hit% ' leave when last row or collision detected + _Source Osource& ' restore calling source + _FreeImage Test1& ' remove temporary image from RAM + _FreeImage Test2& + End If + End If + End If + End If + PixelCollide = Hit% ' return result of collision check + +End Function diff --git a/code/bplus/explosions/spiders_experiment_3.bas b/code/bplus/explosions/spiders_experiment_3.bas new file mode 100644 index 0000000..4188811 --- /dev/null +++ b/code/bplus/explosions/spiders_experiment_3.bas @@ -0,0 +1,408 @@ +'https://qb64.boards.net/thread/98/explosions + +Option _Explicit +_Title "Spiders with Box and Pixel Collisions Experiment 3" 'b+ 2023-01-30/31 +' 2023-02-08 Another experiment in handling Spider collisions, +' At collision, explosion! +' Tweaked number of spiders, speeds, colors and sizes and sound if collide + +' !!!!!!!!!!!!!!!!!!! Escape to Quit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +' !!! Speaker volume around 20 maybe! !!! + +Randomize Timer +Dim Shared xmax As Integer, ymax As Integer +xmax = _DesktopWidth +ymax = _DesktopHeight +Const nSpinners = 40 +Type SpinnerType + As Single x, y, dx, dy, sz + c As _Unsigned Long +End Type +Dim Shared s(1 To nSpinners) As SpinnerType + +Type boxType ' for PixelCollison& + As Long img, x, y, w, h + c As _Unsigned Long +End Type + +Type particle 'setup for explosions ======================================= + As Long life, death + As Single x, y, dx, dy, r + As _Unsigned Long c +End Type + +Dim Shared nDots +nDots = 2000 +ReDim Shared dots(nDots) As particle '===================================== + + +Dim As Long i, j, iImg, jImg, lc, i2, sc, intx, inty +Dim As boxType sIo, sJo + +sc = _ScreenImage +Screen _NewImage(xmax, ymax, 32) +'_ScreenMove 0, 0 +_FullScreen +For i = 1 To nSpinners + newSpinner i +Next +i2 = 1 +While InKey$ <> Chr$(27) + '_Title Str$(i2) + " spiders" ' when testing spider speeds + _PutImage , sc, 0 + lc = lc + 1 + If lc Mod 50 = 49 Then + lc = 0 + If i2 < nSpinners Then i2 = i2 + 1 + End If + For i = 1 To i2 + + 'ready for collision check + + ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++++++ + iImg = _NewImage(140, 140, 32) + _Dest iImg + drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c + _Dest 0 + sIo.x = s(i).x - 70 + sIo.y = s(i).y - 70 + sIo.w = 140 + sIo.h = 140 ' this meets requirements for collision obj1 + sIo.img = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + For j = i + 1 To i2 + ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++ + jImg = _NewImage(140, 140, 32) + _Dest jImg + drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c + _Dest 0 + sJo.x = s(j).x - 70 + sJo.y = s(j).y - 70 + sJo.w = 140 + sJo.h = 140 ' this meets requirements for collision obj1 + sJo.img = jImg + If PixelCollision&(sIo, sJo, intx, inty) Then '+++++++++++++++++++++++++++++++++++++++ + Sound Rnd * 7000 + 400, .05 + explode s(i).x, s(i).y, 150 * s(i).sz, 200, 200, 200 + newSpinner i + 's(i).x = s(i).x + s(i).dx + rndCW(0, 3.5) + 's(i).y = s(i).y + s(i).dy + rndCW(0, 3.5) + 's(j).x = s(j).x + s(j).dx + rndCW(0, 3.5) + 's(j).y = s(j).y + s(j).dy + rndCW(0, 3.5) + Exit For + End If + _FreeImage jImg + Next + s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5) + s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5) + If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i + _PutImage (s(i).x - 70, s(i).y - 70), iImg, 0 + _FreeImage iImg + Next + drawDots + _Display + _Limit 30 +Wend + +Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color? + Dim r + s(i).sz = rndCW(.5, .25) ' * .55 + .2 + If Rnd < .5 Then r = -1 Else r = 1 + s(i).dx = (s(i).sz * Rnd * 8 + 1) * r * 2: s(i).dy = (s(i).sz * Rnd * 8 + 1) * r * 2 + r = Int(Rnd * 4) + Select Case r + Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy + Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy + Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx + Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx + End Select + r = Rnd * 80 + 40 + s(i).c = _RGB32(r, 20 + rndCW(.5 * r, 15), 10 + rndCW(.25 * r, 10)) +End Sub + +Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long) + Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green + Static switch As Integer + switch = switch + 2 + switch = switch Mod 16 + 1 + red = _Red32(c): green = _Green32(c): blue = _Blue32(c) + r = 10 * scale + x1 = x + r * Cos(heading): y1 = y + r * Sin(heading) + r = 2 * r 'lg lengths + For lg = 1 To 8 + If lg < 5 Then + a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10) + Else + a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10) + End If + x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a) + drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5) + If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1 + a1 = a + d * _Pi(1 / 12) + x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1) + drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8) + rd = Int(Rnd * 8) + 1 + a2 = a1 + d * _Pi(1 / 8) * rd / 8 + x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2) + drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12) + Next + r = r * .5 + fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5) + x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12)) + fcirc x2, y2, r * .2, &HFF000000 + x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12)) + fcirc x2, y2, r * .2, &HFF000000 + r = r * 2 + x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi) + TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue) +End Sub + +Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long) + Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6 + a = _Atan2(y2 - y1, x2 - x1) + a1 = a + _Pi(1 / 2) + a2 = a - _Pi(1 / 2) + x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1) + x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2) + x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1) + x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2) + fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c + fcirc x1, y1, r1, c + fcirc x2, y2, r2, c +End Sub + +'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4 +Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long) + ftri idest&, x1, y1, x2, y2, x4, y4, c + ftri idest&, x3, y3, x4, y4, x1, y1, c +End Sub + +Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long) + Dim a& + a& = _NewImage(1, 1, 32) + _Dest a& + PSet (0, 0), K + _Dest idest& + _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3) + _FreeImage a& '<<< this is important! +End Sub + +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, 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 TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long) + Dim TEmax As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single + Dim prc As _Unsigned Long, tef As Long + prc = _RGB32(255, 255, 255, 255) + If a > b Then TEmax = a + 1 Else TEmax = b + 1 + mx2 = TEmax + TEmax + tef = _NewImage(mx2, mx2) + _Dest tef + _Source tef 'point wont read without this! + For k = 0 To 6.2832 + .05 Step .1 + i = TEmax + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang) + j = TEmax + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang) + If k <> 0 Then + Line (lasti, lastj)-(i, j), prc + Else + PSet (i, j), prc + End If + lasti = i: lastj = j + Next + Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer + For y = 0 To mx2 + x = 0 + While Point(x, y) <> prc And x < mx2 + x = x + 1 + Wend + xleft(y) = x + While Point(x, y) = prc And x < mx2 + x = x + 1 + Wend + While Point(x, y) <> prc And x < mx2 + x = x + 1 + Wend + If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x + Next + _Dest destHandle& + For y = 0 To mx2 + If xleft(y) <> mx2 Then Line (xleft(y) + x0 - TEmax, y + y0 - TEmax)-(xright(y) + x0 - TEmax, y + y0 - TEmax), c, BF + Next + _FreeImage tef +End Sub + +Function BoxCollision% (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) + ' x, y represent the box left most x and top most y + ' w, h represent the box width and height which is the usual way sprites / tiles / images are described + ' such that boxbottom = by + bh + ' and boxright = bx + bw + + If (b1y + b1h < b2y) Or (b1y > b2y + b2h) Or (b1x > b2x + b2w) Or (b1x + b1w < b2x) Then + BoxCollision% = 0 + Else + BoxCollision% = -1 + End If +End Function + +' this needs max, min functions as well as BoxCollision% +Sub Intersect2Boxes (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h, bix As Long, biy As Long, biw As Long, bih As Long) + If b2x >= b1x And b2x <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'top left corner in 2nd box + bix = b2x: biy = b2y + If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x + If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y + ElseIf b2x >= b1x And b2x <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'bottom left corner of 2nd box in first + bix = b2x + If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x + If b2y <= b1y Then biy = b1y: bih = b2y + b2h - b1y Else biy = b2y: bih = b2h + ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'right top corner 2nd box in first + If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x + biy = b2y + If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y + ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'left bottom corners in first box + If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x + If b2y >= b1y Then biy = b2y: bih = b2h Else biy = b1y: bih = b2y + b2h - b1y + ElseIf BoxCollision%(b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) Then + bix = max(b1x, b2x): biy = max(b1y, b2y) + biw = min(b1x + b1w, b2x + b2w) - bix: bih = min(b1y + b1h, b2y + b2h) - biy + Else 'no intersect + bix = -1: biy = -1: biw = 0: bih = 0 + End If +End Sub + +Function max (a, b) + If a > b Then max = a Else max = b +End Function + +Function min (a, b) + If a < b Then min = a Else min = b +End Function + +' this sub needs Intersect2Boxes which uses max, min, and BoxCollision Functions +Function PixelCollision& (img1 As boxType, img2 As boxType, intx As Long, inty As Long) + ' boxType here needs at least an x, y, w, h and img + Dim As Long x, y, ix, iy, iw, ih + Dim As _Unsigned Long p1, p2 + intx = -1: inty = -1 ' no collision set + Intersect2Boxes img1.x, img1.y, img1.w, img1.h, img2.x, img2.y, img2.w, img2.h, ix, iy, iw, ih + If ix <> -1 Then ' the boxes intersect + y = iy: x = ix + Do + _Source img1.img + p1 = Point(x - img1.x, y - img1.y) ' point minus img x, y location = location in image I hope + _Source img2.img + p2 = Point(x - img2.x, y - img2.y) + If (p1 <> 0) And (p2 <> 0) Then + PixelCollision& = -1: intx = x: inty = y: Exit Function + End If + If (x + 1) > (ix + iw - 1) Then ' get rid of 2 slow For Loops + x = ix: y = y + 1 + If y >= (iy + ih - 1) Then + _Source 0: Exit Function + Else + y = y + 1 + End If + Else + x = x + 1 + End If + Loop + End If +End Function + +Function rndCW (C As Single, range As Single) 'center +/-range weights to center + rndCW = C + Rnd * range - Rnd * range +End Function + +' explode sets up old dead particles for display for a life +' This sub sets up Dots to display with DrawDots +Sub explode (x, y, spread, cr, cg, cb) + ' x, y explosion origin + ' spread is diameter of area to cover from it number of dots, number of frames and speed are calculated + + ' setup + 'Type particle + ' As Long life, death + ' As Single x, y, dx, dy, r + ' As _Unsigned Long c + 'End Type + + 'Dim Shared nDots + 'nDots = 2000 + 'ReDim Shared dots(nDots) As particle + + Dim As Long i, dotCount, newDots + Dim angle, speed, rd, rAve, frames + newDots = spread / 2 ' quota + frames = spread / 5 + speed = spread / frames ' 0 to spread in frames + rAve = .5 * spread / Sqr(newDots) + For i = 1 To nDots ' find next available dot + If dots(i).life = 0 Then + dots(i).life = 1 ' turn on display + dots(i).death = frames + angle = _Pi(2 * Rnd) + dots(i).x = x: dots(i).y = y ' origin + rd = Rnd + dots(i).dx = rd * speed * Cos(angle) ' moving + dots(i).dy = rd * speed * Sin(angle) + dots(i).r = rndCW(rAve, rAve) ' radius + dots(i).c = _RGB32(cr + Rnd * 40 - 20, cg + Rnd * 40 - 20, cb + Rnd * 40 - 20) 'color + dotCount = dotCount + 1 + If dotCount >= newDots Then Exit Sub + End If + Next +End Sub + +Sub drawDots ' this sub needs fcirc to Fill Circles and Sub Explode sets up the Dots to draw. + ' setup in main + 'Type particle + ' As Long life, death + ' As Single x, y, dx, dy, r + ' As _Unsigned Long c + 'End Type + + 'Dim Shared nDots + 'nDots = 2000 + 'ReDim Shared dots(nDots) As particle + + Dim As Long i + For i = 1 To nDots ' display of living particles + If dots(i).life Then + fcirc dots(i).x, dots(i).y, dots(i).r, dots(i).c + ' update dot + If dots(i).life + 1 >= dots(i).death Then + dots(i).life = 0 + Else + dots(i).life = dots(i).life + 1 + ' might want air resistence or gravity added to dx or dy + dots(i).x = dots(i).x + dots(i).dx + dots(i).y = dots(i).y + dots(i).dy + If dots(i).x < 0 Or dots(i).x > xmax Then dots(i).life = 0 + If dots(i).y < 0 Or dots(i).y > ymax Then dots(i).life = 0 + dots(i).r = dots(i).r * 1 - (dots(i).life / dots(i).death) ' puff! + If dots(i).r <= 0 Then dots(i).life = 0 + End If + End If + Next +End Sub + + diff --git a/code/bplus/files_function/direntry.h b/code/bplus/files_function/direntry.h new file mode 100644 index 0000000..9e73706 --- /dev/null +++ b/code/bplus/files_function/direntry.h @@ -0,0 +1,62 @@ +#include +#include +#include + +const int IS_DIR_FLAG = 1, IS_FILE_FLAG = 2; + +DIR *pdir; +struct dirent *next_entry; +struct stat statbuf1; + +char current_dir[FILENAME_MAX]; +#ifdef QB64_WINDOWS + #define GetCurrentDir _getcwd +#else + #define GetCurrentDir getcwd +#endif + +int load_dir (char * path) { + struct dirent *pent; + struct stat statbuf1; +//Open current directory +pdir = opendir(path); +if (!pdir) { +return 0; //Didn't open +} +return -1; +} + +int has_next_entry () { + next_entry = readdir(pdir); + if (next_entry == NULL) return -1; + + stat(next_entry->d_name, &statbuf1); + return strlen(next_entry->d_name); +} + +void get_next_entry (char * nam, int * flags, int * file_size) { + strcpy(nam, next_entry->d_name); + if (S_ISDIR(statbuf1.st_mode)) { + *flags = IS_DIR_FLAG; + } else { + *flags = IS_FILE_FLAG; + } + *file_size = statbuf1.st_size; + return ; +} + +void close_dir () { + closedir(pdir); + pdir = NULL; + return ; +} + +int current_dir_length () { + GetCurrentDir(current_dir, sizeof(current_dir)); + return strlen(current_dir); +} + +void get_current_dir(char *dir) { + memcpy(dir, current_dir, strlen(current_dir)); + return ; +} diff --git a/code/bplus/files_function/files_function.bas b/code/bplus/files_function/files_function.bas new file mode 100644 index 0000000..5968cef --- /dev/null +++ b/code/bplus/files_function/files_function.bas @@ -0,0 +1,89 @@ +_Title "Files Function" ' b+ 2022-10-27 + +' direntry.h needs to be in QB64 folder see end of code if don't have +Declare CustomType Library ".\direntry" + Function load_dir& (s As String) + Function has_next_entry& () + Sub close_dir () + Sub get_next_entry (s As String, flags As Long, file_size As Long) +End Declare + +f$ = files$ ' gets files in _CWD$ +ReDim currentDir$(1 To 1) ' redim makes dynamic storage array for files list +Split f$, Chr$(10), currentDir$() +For i = 1 To UBound(currentDir$) + Print i, currentDir$(i) + If i Mod 20 = 0 Then + Print: Print "zzz... press any to continue" + Sleep + Cls + End If +Next + + +Function files$ ' mimics old QB45 files$ except that it is saved in a string you can process! + ReDim dList$(0), fList$(0) + ' the way GetLists is setup the 0 place is left blank, the ubound of list coming out should be number of items + GetLists _CWD$, dList$(), fList$() + 'convert flist$ to an Astring$, dang there are empty strings, do manual join + temp$ = "" + For i = LBound(fList$) To UBound(fList$) + If Len(fList$(i)) Then + If Len(temp$) Then temp$ = temp$ + Chr$(10) + fList$(i) Else temp$ = fList$(i) + End If + Next + files$ = temp$ +End Function + +Sub GetLists (SearchDirectory As String, DirList() As String, FileList() As String) + Const IS_DIR = 1 + Const IS_FILE = 2 + Dim flags As Long, file_size As Long, DirCount As Integer, FileCount As Integer, length As Long + Dim nam$ + ReDim _Preserve DirList(100), FileList(100) + DirCount = 0: FileCount = 0 + + If load_dir(SearchDirectory + Chr$(0)) Then + Do + length = has_next_entry + If length > -1 Then + nam$ = Space$(length) + get_next_entry nam$, flags, file_size + If (flags And IS_DIR) Then + DirCount = DirCount + 1 + If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 100) + DirList(DirCount) = nam$ + ElseIf (flags And IS_FILE) Then + FileCount = FileCount + 1 + If FileCount > UBound(FileList) Then ReDim _Preserve FileList(UBound(FileList) + 100) + FileList(FileCount) = nam$ + End If + End If + Loop Until length = -1 + 'close_dir 'move to after end if might correct the multi calls problem + Else + End If + close_dir 'this might correct the multi calls problem + + ReDim _Preserve DirList(DirCount) + ReDim _Preserve FileList(FileCount) +End Sub + +' note: I buggered this twice now, FOR base 1 array REDIM MyArray (1 to 1) AS ... the (1 to 1) is not same as (1) which was the Blunder!!! +'notes: REDIM the array(0) to be loaded before calling Split '<<<< IMPORTANT dynamic array and empty, can use any lbound though +'This SUB will take a given N delimited string, and delimiter$ and create an array of N+1 strings using the LBOUND of the given dynamic array to load. +'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given. rev 2019-08-27 +Sub Split (SplitMeString As String, delim As String, loadMeArray() As String) + Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has + curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim) + dpos = InStr(curpos, SplitMeString, delim) + Do Until dpos = 0 + loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos) + arrpos = arrpos + 1 + If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String + curpos = dpos + LD + dpos = InStr(curpos, SplitMeString, delim) + Loop + loadMeArray(arrpos) = Mid$(SplitMeString, curpos) + ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct +End Sub \ No newline at end of file diff --git a/code/bplus/impossible_oval/impossible_oval.bas b/code/bplus/impossible_oval/impossible_oval.bas new file mode 100644 index 0000000..f84daf8 --- /dev/null +++ b/code/bplus/impossible_oval/impossible_oval.bas @@ -0,0 +1,21 @@ +_Title "Impossible Oval" 'b+ 2023-01-23 + +Screen _NewImage(800, 600, 32) +Dim As Long block +block = _NewImage(80, 40, 32) +_Dest block +For y = 0 To 40 + Line (0, y)-(100, y), midInk~&(80, 0, 0, 255, 100, 100, 1 - y / 40), BF +Next +_Dest 0 +r = 230: a = 0 +Do + x = 410 + r * 1.5 * Cos(a): y = 300 + r * Sin(a) + _PutImage (x - 50, y - 20), block, 0 + a = a + .002 + _Limit 1000 +Loop Until a >= _Pi(2.47) + +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 diff --git a/code/bplus/mandala_life/mandala_life_eternal_border_seed.bas b/code/bplus/mandala_life/mandala_life_eternal_border_seed.bas new file mode 100644 index 0000000..676152a --- /dev/null +++ b/code/bplus/mandala_life/mandala_life_eternal_border_seed.bas @@ -0,0 +1,57 @@ +Option _Explicit +_Title "Mandala Life trans from sb" 'b+ 2023-01-15 +'Mandala life.bas SmallBASIC (not MS) B+ for Bpf 2015-03-25 +Screen _NewImage(600, 600, 12) +Dim As Long an, s, bigblock, g, x, y, pc, lc, cl +an = 60: s = 10: bigblock = 600: g = 0 +Dim As Long a(1 To an, 1 To an), ng(1 To an, 1 To an), ls(1 To an, 1 To an) +Dim r$ + +While _KeyDown(27) = 0 + 'If g Mod 2 = 0 Then ' keep a pulsing border + For x = 1 To an + a(x, 1) = 1: a(x, an) = 1: a(1, x) = 1: a(an, x) = 1 + Next + 'End If + For x = 2 To an - 1 + For y = 2 To an - 1 + pc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1) + ls(x, y) = pc: r$ = _Trim$(Str$(pc)) + If a(x, y) Then + If InStr("2346", r$) Then ng(x, y) = 1 Else ng(x, y) = 0 + Else 'birth? + If InStr("34", r$) Then ng(x, y) = 1 Else ng(x, y) = 0 + End If + Next + Next + Line (1, 1)-(bigblock, bigblock), 15, BF + For y = 1 To an + For x = 1 To an + If a(x, y) Then + Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s, s), 0, BF + Else + lc = ls(x, y) + Select Case lc + Case 0: cl = 15 'br white + Case 1: cl = 11 'cyan + Case 2: cl = 7 'low white, br gray + Case 3: cl = 10 'light green + Case 4: cl = 9 'blue + Case 5: cl = 13 'violet + Case 6: cl = 12 'br red + Case 7: cl = 4 'dark red + Case 8: cl = 1 'indigo + End Select + Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s, s), cl, BF + End If + Next + Next + For y = 1 To an + For x = 1 To an + a(x, y) = ng(x, y) + Next + Next + g = g + 1 + If g > 60 Then _delay .25 + +Wend diff --git a/code/bplus/mandala_life/mandala_life_perpetual_random_border.bas b/code/bplus/mandala_life/mandala_life_perpetual_random_border.bas new file mode 100644 index 0000000..ab8099b --- /dev/null +++ b/code/bplus/mandala_life/mandala_life_perpetual_random_border.bas @@ -0,0 +1,70 @@ +'Option _Explicit +_Title "Mandala Life Perpetual Random Border" 'b+ 2023-01-17 from no pulse +Randomize Timer +Dim Shared As Long CellsPerSide, pixPerSide, Block +CellsPerSide = 60: pixPerSide = 10: Block = 600 +Dim Shared Seed(1 To CellsPerSide) +Dim As Long a(1 To CellsPerSide, 1 To CellsPerSide), ng(1 To CellsPerSide, 1 To CellsPerSide), ls(1 To CellsPerSide, 1 To CellsPerSide) +Dim r$ +Dim As Long g, x, y, pc, lc, cl +Screen _NewImage(Block, Block, 12) +_Title "Press Spacebar to Reseed Perpetual Border..." +makeSeed +While _KeyDown(27) = 0 + If _KeyHit = 32 Then makeSeed + For x = 1 To CellsPerSide 'redraw random seed around border + a(x, 1) = Seed(x) + a(x, CellsPerSide) = Seed(x) + a(1, x) = Seed(x) + a(CellsPerSide, x) = Seed(x) + Next + For x = 2 To CellsPerSide - 1 + For y = 2 To CellsPerSide - 1 + pc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1) + ls(x, y) = pc: r$ = _Trim$(Str$(pc)) + If a(x, y) Then + If InStr("2346", r$) Then ng(x, y) = 1 Else ng(x, y) = 0 + Else 'birth? + If InStr("34", r$) Then ng(x, y) = 1 Else ng(x, y) = 0 + End If + Next + Next + Line (1, 1)-(Block, Block), 15, BF + For y = 1 To CellsPerSide + For x = 1 To CellsPerSide + If a(x, y) Then + Line ((x - 1) * pixPerSide + 1, (y - 1) * pixPerSide + 1)-Step(pixPerSide, pixPerSide), 0, BF + Else + lc = ls(x, y) + Select Case lc + Case 0: cl = 15 'br white + Case 1: cl = 11 'cyan + Case 2: cl = 7 'low white, br gray + Case 3: cl = 10 'light green + Case 4: cl = 9 'blue + Case 5: cl = 13 'violet + Case 6: cl = 12 'br red + Case 7: cl = 4 'dark red + Case 8: cl = 1 'indigo + End Select + Line ((x - 1) * pixPerSide + 1, (y - 1) * pixPerSide + 1)-Step(pixPerSide, pixPerSide), cl, BF + End If + Next + Next + _Display + _Limit 2 + For y = 1 To CellsPerSide + For x = 1 To CellsPerSide + a(x, y) = ng(x, y) + Next + Next +Wend +Sub makeSeed + Dim As Long i, r + Dim d + d = Rnd + For i = 1 To Int(CellsPerSide / 2 + .5) + If Rnd < d Then r = 1 Else r = 0 + Seed(i) = r: Seed(CellsPerSide - i + 1) = r + Next +End Sub \ No newline at end of file diff --git a/code/bplus/quick_life/quick_conway_life.bas b/code/bplus/quick_life/quick_conway_life.bas new file mode 100644 index 0000000..6e87092 --- /dev/null +++ b/code/bplus/quick_life/quick_conway_life.bas @@ -0,0 +1,36 @@ +_Title "Quick Conway Life" ' b+ 2023-1-15 +Screen _NewImage(710, 710, 32) +DefLng A-Z +Dim g(69, 69) + +For y = 1 To 68 'seed g() + For x = 1 To 68 + If Rnd < .33 Then g(x, y) = 1 + Next +Next + +While _KeyDown(27) = 0 + ReDim ng(69, 69) + Cls + gen = gen + 1 + Print "Gen"; gen + For y = 1 To 68 + For x = 1 To 68 + nc = g(x - 1, y - 1) + g(x, y - 1) + g(x + 1, y - 1) + g(x - 1, y) + g(x + 1, y) + g(x - 1, y + 1) + g(x, y + 1) + g(x + 1, y + 1) + If g(x, y) Then + Line (x * 10, y * 10)-Step(10, 10), &HFFFFFFFF, BF + Line (x * 10, y * 10)-Step(10, 10), &HFF000000, B + If nc = 2 Or nc = 3 Then ng(x, y) = 1 + Else + If nc = 3 Then ng(x, y) = 1 + End If + Next + Next + For y = 1 To 68 'transfer ng to g and erase + For x = 1 To 68 + g(x, y) = ng(x, y) + Next + Next + ReDim ng(69, 69) + _Limit 10 +Wend \ No newline at end of file diff --git a/code/bplus/rotozoom/Test Different RotoZooms.zip b/code/bplus/rotozoom/Test Different RotoZooms.zip new file mode 100644 index 0000000..6d33af3 Binary files /dev/null and b/code/bplus/rotozoom/Test Different RotoZooms.zip differ diff --git a/code/bplus/rotozoom/rotozoom2_fixed.bas b/code/bplus/rotozoom/rotozoom2_fixed.bas new file mode 100644 index 0000000..1fe5a85 --- /dev/null +++ b/code/bplus/rotozoom/rotozoom2_fixed.bas @@ -0,0 +1,129 @@ +_Title "Different Rotozooms test with grid" 'b+ 2023-01-18 + +' with original tests of Rotozoom2 with independent scales for x and y axis + +Const xmax = 800 +Const ymax = 600 +Dim Shared pi As _Float +pi = _Pi + +Screen _NewImage(xmax, ymax, 32) +_ScreenMove 360, 60 + +Dim As Long imgD, imgR +imgD = _NewImage(801, 801, 32) +_Dest imgD +Color &HFF0000FF +drawGrid 0, 0, 20, 40, 40 +imgR = _NewImage(801, 801, 32) +_Dest imgR +Color &HFFFF0000 +drawGrid 0, 0, 20, 40, 40 + +_Dest 0 +Dim r As _Float +Do + Cls + Color &HFF0000FF: Print d + Color &HFFFF0000: Print Int(_R2D(r)) + 'Color &HFFFFFFFF + RotoZoom23 400, 300, imgD, .5, 1, d + RotoZoom2 400, 300, imgR, .5, 1, d + 'RotoZoom3 400, 300, imgR, .5, 1, r + d = d + 1 + r = _D2R(d) + _Display + _Limit 5 +Loop Until _KeyDown(27) + +' ==================== Test Code when orininally tested scaling Rotozooms ================================= + +' Rotozoom23 works fine here too! + +backImage& = _LoadImage("Stars.png") +myImage& = _LoadImage("Starship.png") +xscale = .2: yscale = 1.4 + +''test shrink x expand x +For lc = 1 To 800 Step 5 + _PutImage , backImage& + RotoZoom23 xmax / 2, ymax / 2, myImage&, (200 - lc) / 200 + .5, 1, 0 + _Display + _Limit 20 +Next +''test shrink and expand y +For lc = 1 To 800 Step 5 + _PutImage , backImage& + RotoZoom23 xmax / 2, ymax / 2, myImage&, 1, (200 - lc) / 200 + .5, 0 + _Display + _Limit 20 +Next +''test rotation +For a = 0 To 360 + _PutImage , backImage& + RotoZoom23 xmax / 2, ymax / 2, myImage&, 1, 1, a + _Display + _Limit 20 +Next +'test warp drive +_PutImage , backImage& +For x = 10 To xmax + RotoZoom23 x, ymax / 2, myImage&, (1 + x / xmax) ^ 2, 1, 0 + _Display + _Limit 2000 +Next + +Sub drawGrid (x, y, sq, xn, yn) ' top left x, y, x side, y side, number of x, nmber of y + Dim As Long i, dx, dy + dx = sq * xn: dy = sq * yn + For i = 0 To xn + Line (x + sq * i, y)-(x + sq * i, y + dy) + Next + For i = 0 To yn + Line (x, y + sq * i)-(x + dx, y + sq * i) + Next +End Sub + +Sub RotoZoom2 (X As Long, Y As Long, Image As Long, xScale As Single, yScale, Rotation As Single) + Dim px(3) As Single: Dim py(3) As Single + W& = _Width(Image&): H& = _Height(Image&) + px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2 + px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2 + sinr! = Sin(-Rotation / 57.2957795131): cosr! = Cos(-Rotation / 57.2957795131) + For i& = 0 To 3 + x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + Y + px(i&) = x2&: py(i&) = y2& + Next + _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2)) + _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2)) +End Sub + +Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y + Dim px(3) As Single: Dim py(3) As Single + Dim W&, H&, sinr!, cosr!, i&, x2&, y2& + W& = _Width(Image&): H& = _Height(Image&) + px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2 + px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2 + sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation) + For i& = 0 To 3 + x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y + px(i&) = x2&: py(i&) = y2& + Next + _MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2)) + _MapTriangle _Seamless(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2)) +End Sub + +Sub RotoZoom23 (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single) + Dim px(3) As Single: Dim py(3) As Single + W& = _Width(Image&): H& = _Height(Image&) + px(0) = -W& / 2 * xScale: py(0) = -H& / 2 * yScale: px(1) = -W& / 2 * xScale: py(1) = H& / 2 * yScale + px(2) = W& / 2 * xScale: py(2) = H& / 2 * yScale: px(3) = W& / 2 * xScale: py(3) = -H& / 2 * yScale + sinr! = Sin(-0.01745329 * Rotation): cosr! = Cos(-0.01745329 * Rotation) + For i& = 0 To 3 + ' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY + x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY + px(i&) = x2&: py(i&) = y2& + Next + _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2)) + _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2)) +End Sub diff --git a/code/bplus/spiral/spiral.bas b/code/bplus/spiral/spiral.bas new file mode 100644 index 0000000..a62760d --- /dev/null +++ b/code/bplus/spiral/spiral.bas @@ -0,0 +1,74 @@ + +_Title "sb spiral of chatGPT - fixed by kay63 trans and mod by me, b+ 2023-01-04" +Const xmax = 600, ymax = 600 +Dim Shared pi +pi = _Pi +Dim clr As _Unsigned Long +Screen _NewImage(xmax, ymax, 32) + +' Set the starting position and radius of the spiral +x = ymax / 2 - .5 * ymax / pi +y = ymax / 2 - .5 * ymax / pi +r = 1 + +' Set the angle increment for each loop iteration +angle_inc = 5 + +' Set the maximum radius of the spiral +max_r = ymax / 2 + +' Set the maximum number of loops +max_loops = ymax + +' Set the spiral rotation direction +direction = 1 + +' Draw the spiral +For i = 1 To max_loops + ' Set the color for this loop iteration + 'Color i Mod 14 + ' Draw the spiral segment + Select Case i Mod 3 + Case 0: clr = _RGB32(0, 255 * (i / 600), 128 - (i * 127 / 600)) + Case 1: clr = _RGB32(0, 100 * i / 600 + 55, 100 * i / 600 + 55) + Case 2: clr = _RGB32(0, 255 * (i / 600), 128 - (i * 127 / 600)) + End Select + arc x, y, r, angle_inc * i / 180 * pi, angle_inc * (i + 30) / 180 * pi, clr + ' Increase the radius for the next loop iteration + r = r + direction + cnt = cnt + 1 + ' Check if the radius has reached the maximum + If r > max_r Then + ' Reverse the growing of the spiral + direction = -direction + ' Reset the radius + r = max_r + End If + ' move the spiral: + x = x + 1 / pi + y = y + 1 / pi + _Limit 60 +Next +Sleep + + +Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long) ' this does not check raStart and raStop like arcC does + 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 + PSet (x + r * Cos(a), y + r * Sin(a)), c + Next + End If +End Sub + diff --git a/code/bplus/xmas/tree.bas b/code/bplus/xmas/tree.bas new file mode 100644 index 0000000..3119972 --- /dev/null +++ b/code/bplus/xmas/tree.bas @@ -0,0 +1,231 @@ +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 diff --git a/code/dbox/pipecom/pipecom.bas b/code/dbox/pipecom/pipecom.bas new file mode 100644 index 0000000..91a1bd8 --- /dev/null +++ b/code/dbox/pipecom/pipecom.bas @@ -0,0 +1,135 @@ +Option _Explicit +$Console:Only +Const False = 0 +Const True = Not False + +ReDim items(0) As String +Dim count As Integer +Dim i As Integer + +count = FS_DirList("C:\", True, items()) +Print "Child folders:" +For i = 1 To count + Print "-> " + items(i) +Next i + +count = FS_DirList("C:\", False, items()) +Print "Child files:" +For i = 1 To count + Print "-> " + items(i) +Next i + +count = FS_DriveList(items()) +Print "Drives:" +For i = 1 To count + Print "-> " + items(i) +Next i + + + +Function FS_DirList (path As String, dirmode As Integer, filenames() As String) + Dim cmd As String + + ' Determine the OS-specific directory command + $If WINDOWS Then + If dirmode Then + cmd = "dir /b /ad " + Chr$(34) + path + Chr$(34) + Else + cmd = "dir /b /a-d " + Chr$(34) + path + Chr$(34) + End If + $Else + IF dirmode THEN + cmd = "find " + CHR$(34) + path + CHR$(34) + " -maxdepth 1 -type d | sed '1d' | sed 's/.*\///g'" + ELSE + cmd = "ls -p " + CHR$(34) + path + CHR$(34) + " | grep -v / " + END IF + $End If + + Dim fcount As Integer + If cmd <> "" Then + Dim cmdResult As Integer, stdout As String, stderr As String + cmdResult = pipecom(cmd, stdout, stderr) + + fcount = STR_Split(stdout, Chr$(10), filenames()) + fcount = fcount - 1 'Last line is blank + End If + + ' Return the number of items in the result array + FS_DirList = fcount +End Function + +Function FS_DriveList (drives() As String) + $If WINDOWS Then + Dim cmdResult As Integer + Dim stderr As String + Dim text As String + Dim count As Integer + count = 0 + + ' Get the drive list + cmdResult = pipecom("cmd /c " + Chr$(34) + "fsutil fsinfo drives" + Chr$(34), text, stderr) + text = GXSTR_Replace(text, "Drives: ", "") + text = GXSTR_Replace(text, Chr$(10), "") + text = GXSTR_Replace(text, "\", "") + count = STR_Split(text, " ", drives()) + + FS_DriveList = count + $Else + FS_DriveList = 0 + $End If +End Function + +Function GXSTR_Replace$ (s As String, searchString As String, newString As String) + Dim ns As String + Dim i As Integer + + Dim slen As Integer + slen = Len(searchString) + + For i = 1 To Len(s) '- slen + 1 + If Mid$(s, i, slen) = searchString Then + ns = ns + newString + i = i + slen - 1 + Else + ns = ns + Mid$(s, i, 1) + End If + Next i + + GXSTR_Replace = ns +End Function + +Function STR_Split (sourceString As String, delimiter As String, results() As String) + ' Modified version of: + ' https://www.qb64.org/forum/index.php?topic=1073.msg102711#msg102711 + Dim cstr As String, p As Long, curpos As Long, arrpos As Long, dpos As Long + + ' Make a copy of the source string + cstr = sourceString + + ' Special case if the delimiter is space, remove all excess space + If delimiter = " " Then + cstr = RTrim$(LTrim$(cstr)) + p = InStr(cstr, " ") + While p > 0 + cstr = Mid$(cstr, 1, p - 1) + Mid$(cstr, p + 1) + p = InStr(cstr, " ") + Wend + End If + curpos = 1 + arrpos = 0 + dpos = InStr(curpos, cstr, delimiter) + Do Until dpos = 0 + arrpos = arrpos + 1 + ReDim _Preserve results(arrpos) As String + results(arrpos) = Mid$(cstr, curpos, dpos - curpos) + curpos = dpos + Len(delimiter) + dpos = InStr(curpos, cstr, delimiter) + Loop + arrpos = arrpos + 1 + ReDim _Preserve results(arrpos) As String + results(arrpos) = Mid$(cstr, curpos) + + STR_Split = arrpos +End Function + +'$Include: 'pipecom.bm' diff --git a/code/dbox/pipecom/pipecom.bm b/code/dbox/pipecom/pipecom.bm new file mode 100644 index 0000000..850431b --- /dev/null +++ b/code/dbox/pipecom/pipecom.bm @@ -0,0 +1,218 @@ +' Source: Spriggy's API Collection +' https://github.com/SpriggsySpriggs/Spriggsys-API-Collection/blob/master/Cross-Platform%20(Windows%2C%20Macintosh%2C%20Linux)/pipecomqb64.bas +' ---------------------------------------------------------------------------- +Function pipecom& (cmd As String, stdout As String, stderr As String) + $If WIN Then + Type SECURITY_ATTRIBUTES + nLength As Long + $If 64BIT Then + padding As Long + $End If + lpSecurityDescriptor As _Offset + bInheritHandle As Long + $If 64BIT Then + padding2 As Long + $End If + End Type + + Type STARTUPINFO + cb As Long + $If 64BIT Then + padding As Long + $End If + lpReserved As _Offset + lpDesktop As _Offset + lpTitle As _Offset + dwX As Long + dwY As Long + dwXSize As Long + dwYSize As Long + dwXCountChars As Long + dwYCountChars As Long + dwFillAttribute As Long + dwFlags As Long + wShowWindow As Integer + cbReserved2 As Integer + $If 64BIT Then + padding2 As Long + $End If + lpReserved2 As _Offset + hStdInput As _Offset + hStdOutput As _Offset + hStdError As _Offset + End Type + + Type PROCESS_INFORMATION + hProcess As _Offset + hThread As _Offset + dwProcessId As Long + $If 64BIT Then + padding2 As Long + $End If + End Type + + Const STARTF_USESTDHANDLES = &H00000100 + Const CREATE_NO_WINDOW = &H8000000 + + Const INFINITE = 4294967295 + Const WAIT_FAILED = &HFFFFFFFF + + Declare Dynamic Library "Kernel32" + Function CreatePipe% (ByVal hReadPipe As _Offset, Byval hWritePipe As _Offset, Byval lpPipeAttributes As _Offset, Byval nSize As Long) + Function CreateProcess% Alias CreateProcessA (ByVal lpApplicationName As _Offset, Byval lpCommandLine As _Offset, Byval lpProcessAttributes As _Offset, Byval lpThreadAttributes As _Offset, Byval bInheritHandles As Integer, Byval dwCreationFlags As Long, Byval lpEnvironment As _Offset, Byval lpCurrentDirectory As _Offset, Byval lpStartupInfor As _Offset, Byval lpProcessInformation As _Offset) + Function CloseHandle% (ByVal hObject As _Offset) + Function ReadFile% (ByVal hFile As _Offset, Byval lpBuffer As _Offset, Byval nNumberOfBytesToRead As Long, Byval lpNumberOfBytesRead As _Offset, Byval lpOverlapped As _Offset) + Function GetExitCodeProcess% (ByVal hProcess As _Offset, Byval lpExitCode As _Offset) + Function WaitForSingleObject& (ByVal hHandle As _Offset, Byval dwMilliseconds As Long) + End Declare + + Dim ok As Integer: ok = 1 + Dim hStdOutPipeRead As _Offset + Dim hStdOutPipeWrite As _Offset + Dim hStdReadPipeError As _Offset + Dim hStdOutPipeError As _Offset + Dim sa As SECURITY_ATTRIBUTES: sa.nLength = Len(sa): sa.lpSecurityDescriptor = 0: sa.bInheritHandle = 1 + + If CreatePipe(_Offset(hStdOutPipeRead), _Offset(hStdOutPipeWrite), _Offset(sa), 0) = 0 Then + pipecom = -1 + Exit Function + End If + + If CreatePipe(_Offset(hStdReadPipeError), _Offset(hStdOutPipeError), _Offset(sa), 0) = 0 Then + pipecom = -1 + Exit Function + End If + + Dim si As STARTUPINFO + si.cb = Len(si) + si.dwFlags = STARTF_USESTDHANDLES + si.hStdError = hStdOutPipeError + si.hStdOutput = hStdOutPipeWrite + si.hStdInput = 0 + Dim pi As PROCESS_INFORMATION + Dim lpApplicationName As _Offset + Dim fullcmd As String: fullcmd = "cmd /c " + cmd + Chr$(0) + Dim lpCommandLine As String: lpCommandLine = fullcmd + Dim lpProcessAttributes As _Offset + Dim lpThreadAttributes As _Offset + Dim bInheritHandles As Integer: bInheritHandles = 1 + Dim dwCreationFlags As Long: dwCreationFlags = CREATE_NO_WINDOW + Dim lpEnvironment As _Offset + Dim lpCurrentDirectory As _Offset + ok = CreateProcess(lpApplicationName,_ + _Offset(lpCommandLine),_ + lpProcessAttributes,_ + lpThreadAttributes,_ + bInheritHandles,_ + dwCreationFlags,_ + lpEnvironment,_ + lpCurrentDirectory,_ + _Offset(si),_ + _Offset(pi)) + If ok = 0 Then + pipecom = -1 + Exit Function + End If + + ok = CloseHandle(hStdOutPipeWrite) + ok = CloseHandle(hStdOutPipeError) + + Dim buf As String: buf = Space$(4096 + 1) + Dim dwRead As Long + While ReadFile(hStdOutPipeRead, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0 + buf = Mid$(buf, 1, dwRead) + GoSub RemoveChr13 + stdout = stdout + buf + buf = Space$(4096 + 1) + Wend + + While ReadFile(hStdReadPipeError, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0 + buf = Mid$(buf, 1, dwRead) + GoSub RemoveChr13 + stderr = stderr + buf + buf = Space$(4096 + 1) + Wend + + Dim exit_code As Long + Dim ex_stat As Long + If WaitForSingleObject(pi.hProcess, INFINITE) <> WAIT_FAILED Then + If GetExitCodeProcess(pi.hProcess, _Offset(exit_code)) Then + ex_stat = 1 + End If + End If + + ok = CloseHandle(hStdOutPipeRead) + ok = CloseHandle(hStdReadPipeError) + If ex_stat = 1 Then + pipecom = exit_code + Else + pipecom = -1 + End If + + Exit Function + + RemoveChr13: + Dim j As Long + j = InStr(buf, Chr$(13)) + Do While j + buf = Left$(buf, j - 1) + Mid$(buf, j + 1) + j = InStr(buf, Chr$(13)) + Loop + Return + $Else + Declare CustomType Library + Function popen%& (cmd As String, readtype As String) + Function feof& (ByVal stream As _Offset) + Function fgets$ (str As String, Byval n As Long, Byval stream As _Offset) + Function pclose& (ByVal stream As _Offset) + Function fclose& (ByVal stream As _Offset) + End Declare + + Declare Library + Function WEXITSTATUS& (ByVal stat_val As Long) + End Declare + + Dim pipecom_buffer As String + Dim stream As _Offset + + Dim buffer As String * 4096 + If _FileExists("pipestderr") Then + Kill "pipestderr" + End If + + stream = popen(cmd + " 2>pipestderr" + Chr$(0), "r") + + If stream Then + While feof(stream) = 0 + If fgets(buffer, 4096, stream) <> "" And feof(stream) = 0 Then + stdout = stdout + Mid$(buffer, 1, InStr(buffer, Chr$(0)) - 1) + End If + Wend + Dim status As Long + Dim exit_code As Long + status = pclose(stream) + exit_code = WEXITSTATUS(status) + If _FileExists("pipestderr") Then + Dim errfile As Integer + errfile = FreeFile + Open "pipestderr" For Binary As #errfile + If LOF(1) > 0 Then + stderr = Space$(LOF(1)) + Get #errfile, , stderr + End If + Close #errfile + Kill "pipestderr" + End If + pipecom = exit_code + Else + pipecom = -1 + End If + $End If +End Function + +Function pipecom_lite$ (cmd As String) + Dim a As Long + Dim stdout As String, stderr As String + a = pipecom(cmd, stdout, stderr) + pipecom_lite$ = stdout +End Function diff --git a/code/dbox/pipecom/pipecom.h b/code/dbox/pipecom/pipecom.h new file mode 100644 index 0000000..e81b05a --- /dev/null +++ b/code/dbox/pipecom/pipecom.h @@ -0,0 +1,21 @@ +const char* pipecom (char* cmd){ +string data; +FILE * stream; +const int max_buffer = 256; +char buffer[max_buffer]; + + stream = popen(cmd, "r"); + if (stream) { + while (!feof(stream)) { + if (fgets(buffer, max_buffer, stream) != NULL) { + data.append(buffer); + } + } + pclose(stream); + } + // + //cout << data; + const char* dataout; + dataout = strdup(data.c_str()); + return dataout; +} \ No newline at end of file diff --git a/code/dcromley/quaternion_rotation/quaternion_rotation.bas b/code/dcromley/quaternion_rotation/quaternion_rotation.bas new file mode 100644 index 0000000..2a9ef31 --- /dev/null +++ b/code/dcromley/quaternion_rotation/quaternion_rotation.bas @@ -0,0 +1,281 @@ +' https://qb64.boards.net/thread/42/rotating-tetraeder +_Title "Quaternion Rotation" ' dcromley +Option _Explicit +DefSng A-Z: DefLng I-N: DefStr S +Const TRUE = -1, FALSE = 0 +Dim Shared mx, my, m1Clk, m1Rpt, m1Dn, m1End, m2Clk, m2Dn ' for MouseCk +Dim Shared Img1, Img2 +Img1 = _NewImage(1024, 768, 256) +Img2 = _NewImage(1024, 768, 256) +_Dest Img2: Color 0, 15: Cls +_Dest Img1: Color 0, 15: Cls + +' == MAIN start == + +Type type4f ' 4 floats for quaternions, points, triangles + w As Single ' 0 for points; color for triangles + x As Single ' pt1 for triangles + y As Single ' pt2 for triangles + z As Single ' pt3 for triangles +End Type + +Const x0 = 384, y0 = 384, kxy = 200, z0 = 200 ' center, scale +Dim Shared As type4f T, aPts(5), aPts0(5), aTris(4), QMain, QSlew, va, vb +Dim Shared nPts, nTris ' # of Points, Triangles +Dim Shared aMatrix(2, 2) +Dim As type4f Qxp, Qxm, Qyp, Qym, Qzp, Qzm ' +- 1 deg Q's +Dim i, x, y, z, s, p1, p2, p3, icolor, nloop +Dim EuAngX, EuAngY, EuAngZ, fcos, fsin ' Euler angles +Dim az(4), ndx(4), time0, iSlew, xa, ya + +' -- Points - x,y,z,/ (# ends) +Data 0,1,0,/,-1,-1,-1,/,-1,-1,1,/,1,-1,1,/,1,-1,-1,# +' -- Triangles - p1,p2,p3,color,/ (# ends) +Data 1,2,3,9,/,1,3,4,10,/,1,4,5,12,/,1,5,2,14,# + +Do ' -- load aPoints + nPts = nPts + 1 ' read point x,y,z + Read aPts0(nPts).x, aPts0(nPts).y, aPts0(nPts).z, s ' s is / or # to end +Loop Until s = "#" +Do ' -- load aTriangles + nTris = nTris + 1 ' read triangle p1,p2,p3,color + Read aTris(nTris).x, aTris(nTris).y, aTris(nTris).z, aTris(nTris).w, s +Loop Until s = "#" +' -- load 1 deg quaternions +fcos = Cos(1 * _Pi / 360): fsin = Sin(1 * _Pi / 360) ' half angle +Qxp.w = fcos: Qxp.x = fsin: Qxm.w = fcos: Qxm.x = -fsin +Qyp.w = fcos: Qyp.y = fsin: Qym.w = fcos: Qym.y = -fsin +Qzp.w = fcos: Qzp.z = fsin: Qzm.w = fcos: Qzm.z = -fsin +QMain.w = 1 ' start with null rotation +QSlew = QMain + +time0 = Timer - 1 ' prevent div by 0 +Do ' ======== MAIN LOOP ======== + nloop = nloop + 1 ' nloop + 1 and print + If nloop Mod 2 = 1 Then _Dest Img1: screen img1 _ + Else _Dest Img2: Screen Img2 ' swap screens + Cls ' simplicity, not performance + Line (768, 0)-(768, 752), _RGB(192, 192, 192) ' vertical + MouseCk ' get mouse data + ' -- check controls + If iBox(110, 12, " Up") Then Qmult Qxm, QMain, QMain ' nudge orientation + If iBox(106, 13, "Lft") Then Qmult Qym, QMain, QMain + If iBox(114, 13, "Rht") Then Qmult Qyp, QMain, QMain + If iBox(110, 14, " Dn") Then Qmult Qxp, QMain, QMain + If iBox(106, 15, "CCW") Then Qmult Qzp, QMain, QMain + If iBox(114, 15, " CW") Then Qmult Qzm, QMain, QMain + ' -- check for random quaternion + If iBox(110, 16, "Random") Then QRandom + ' -- check for mouse dragging (slewing) + vb.x = mx - x0: vb.y = y0 - my: vb.z = z0 ' new mouse data + If m1Dn And isIn(mx, 0, 767) And isIn(my, 0, 767) Then ' yes + QVtoV va, vb, T ' need to smooth out the mouse data + QSlew.x = QSlew.x * .9 + T.x * .1: QSlew.y = QSlew.y * .9 + T.y * .1: QSlew.z = QSlew.z * .9 + T.z * .1 + Qnorm QSlew ' this is what slews + Else + Const k = .99 ' make the slewing decay + QSlew.x = QSlew.x * k: QSlew.y = QSlew.y * k: QSlew.z = QSlew.z * k + QSlew.w = Sqr(1 - QSlew.x * QSlew.x - QSlew.y * QSlew.y - QSlew.z * QSlew.z) + End If + Qmult QSlew, QMain, QMain ' add slew to QMain + va = vb ' new becomes old mouse data + ' -- quaternion to Matrix + QtoMatrix + ' -- quaternion to Euler + EuAngX = _Atan2(2 * QMain.x * QMain.w - 2 * QMain.y * QMain.z, 1 - 2 * QMain.x * QMain.x - 2 * QMain.z * QMain.z) + EuAngY = _Atan2(2 * QMain.y * QMain.w - 2 * QMain.x * QMain.z, 1 - 2 * QMain.y * QMain.y - 2 * QMain.z * QMain.z) + EuAngZ = _Asin(2 * QMain.x * QMain.y + 2 * QMain.z * QMain.w) + ' -- rotate points + For i = 1 To nPts + aPts(i) = aPts0(i) ' reset to original + T = QMain + T.x = -T.x: T.y = -T.y: T.z = -T.z: ' << Q' >> conjugate + Qmult aPts(i), T, T ' << PQ' >> + Qmult QMain, T, aPts(i) ' << QPQ' >> + Next i + For i = 1 To 4 ' get center Z's into a(4) + T = aTris(i) + az(i) = aPts(T.x).z + aPts(T.y).z + aPts(T.z).z ' p1.z+p2.z+p3.z + Next i + zSortIndexF az(), ndx() ' getting z-order + For i = 1 To nTris ' this draws the triangles + drawTri (ndx(i)) ' in z-order + Next i + ' -- print stuff + Locate 2, 101: Print Using "nloops:#,###,###,###"; nloop + Locate , 101: Print Using "fps: ####.#"; nloop / (Timer - time0) + Locate , 104: Print + Locate , 104: Print "-- To rotate --" + Locate , 104: Print "1) Click boxes" + Locate , 104: Print "2) Press boxes" + Locate , 104: Print "3) Drag mouse" + Locate , 104: Print "ESC to end" + Locate 19, 102: Print " -- Quaternion --" + Locate , 99: Print Using " ##.#####"; QMain.w + Locate , 99: Print Using " ##.#####"; QMain.x; QMain.y; QMain.z + ' Locate , 99: Print Using " ##.#####"; QSlew.w + ' Locate , 99: Print Using " ##.#####"; QSlew.x; QSlew.y; QSlew.z + Locate , 100: Print "" + Locate , 102: Print " -- Matrix --" + Locate , 99: Print Using " ##.#####"; aMatrix(0, 0); aMatrix(0, 1); aMatrix(0, 2) + Locate , 99: Print Using " ##.#####"; aMatrix(1, 0); aMatrix(1, 1); aMatrix(1, 2) + Locate , 99: Print Using " ##.#####"; aMatrix(2, 0); aMatrix(2, 1); aMatrix(2, 2) + Locate , 99: Print Using " k(w)= ##.#####"; 1.0 + aMatrix(0, 0) + aMatrix(1, 1) + aMatrix(2, 2) + Locate , 100: Print "" + + Locate , 102: Print " -- Points --" + For i = 1 To nPts + Locate , 99: Print Using " ##.#####"; aPts(i).x; aPts(i).y; aPts(i).z + Next i + Locate , 100: Print "" + Locate , 102: Print " -- Euler Angles --" + Locate , 100: Print Using "EuAngX: ###"; (EuAngX * 180 / _Pi + 360) Mod 360 + Locate , 100: Print Using "EuAngY: ###"; (EuAngY * 180 / _Pi + 360) Mod 360 + Locate , 100: Print Using "EuAngZ: ###"; (EuAngZ * 180 / _Pi + 360) Mod 360 + _Display +Loop Until InKey$ = Chr$(27) +System + +' == ROUTINES start == + +Function iBox (iCol, iRow, s3) ' simple control + Dim ix, iy + Locate iRow, iCol: Color 0, 14: Print s3;: Color 0, 15 + ix = iCol * 8 - 11 + iy = iRow * 16 - 1 + Line (ix, iy)-(ix + 3 * 8 + 4, iy - 16), , B ' rectangle + If m1Rpt And isIn(mx, ix, ix + 28) And isIn(my, iy - 16, iy) Then iBox = TRUE +End Function + +Sub Qmult (qa As type4f, qb As type4f, qab As type4f) ' Q multiplication + Dim w, x, y, z + w = qa.w * qb.w - qa.x * qb.x - qa.y * qb.y - qa.z * qb.z + x = qa.w * qb.x + qa.x * qb.w + qa.y * qb.z - qa.z * qb.y + y = qa.w * qb.y - qa.x * qb.z + qa.y * qb.w + qa.z * qb.x + z = qa.w * qb.z + qa.x * qb.y - qa.y * qb.x + qa.z * qb.w + qab.w = w: qab.x = x: qab.y = y: qab.z = z +End Sub + +Sub QVtoV (v1 As type4f, v2 As type4f, Q As type4f) ' get Q from v1 to v2 + Dim v1dv2, v1xv2 As type4f ' dot, cross + v1dv2 = VdotV(v1, v2) ' dot + VcrossV v1, v2, Q ' cross + Q.w = v1dv2 + Sqr(v1dv2 * v1dv2 + VdotV(Q, Q)) ' from the book + Qnorm Q +End Sub + +Function VdotV (v1 As type4f, v2 As type4f) ' dot product + VdotV = v1.x * v2.x + v1.y * v2.y + v1.z * v2.z +End Function + +Sub VcrossV (v1 As type4f, v2 As type4f, v As type4f) ' cross product + v.x = v1.y * v2.z - v1.z * v2.y + v.y = v1.z * v2.x - v1.x * v2.z + v.z = v1.x * v2.y - v1.y * v2.x +End Sub + +Sub Qnorm (q As type4f) ' normalize + Dim d + d = Sqr(q.w * q.w + q.x * q.x + q.y * q.y + q.z * q.z) + q.w = q.w / d: q.x = q.x / d: q.y = q.y / d: q.z = q.z / d +End Sub + +Sub drawTri (iTri) ' draw Triangle + Dim ip1, ip2, ip3, icolor + Dim ixc, iyc, x1, y1, x2, y2, x3, y3 + T = aTris(iTri) ' the triangle + ip1 = T.x: ip2 = T.y: ip3 = T.z: icolor = T.w ' the points, color + x1 = 386 + kxy * aPts(ip1).x: y1 = 386 - kxy * aPts(ip1).y + x2 = 386 + kxy * aPts(ip2).x: y2 = 386 - kxy * aPts(ip2).y + x3 = 386 + kxy * aPts(ip3).x: y3 = 386 - kxy * aPts(ip3).y + Line (x1, y1)-(x2, y2), icolor + Line (x2, y2)-(x3, y3), icolor + Line (x3, y3)-(x1, y1), icolor + ' don't paint if points are colinear + If Abs(x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2)) < 1000 Then Exit Sub + ixc = (x1 + x2 + x3) / 3: iyc = (y1 + y2 + y3) / 3 ' center + Paint (ixc, iyc), icolor ' paint +End Sub + +' -- LIBRARY ROUTINES -- + +' -- need Dim Shared mx,my,m1Clk,m1Rpt,m1Dn,m1End,m2Clk,m2Dn +Sub MouseCk () ' get mouse info + Static m1Prev, m2Prev, m1Time ' for getting edges (Clk,End) and Repeating + m1Clk = 0: m1Rpt = 0: m1End = 0: m2Clk = 0 + While _MouseInput: Wend ' bplus + mx = _MouseX: my = _MouseY: m1Dn = _MouseButton(1): m2Dn = _MouseButton(2) + If m1Dn Then ' Btn 1 down + If Not m1Prev Then ' got a Clk (& Rpt), now look for repeats + m1Clk = TRUE: m1Rpt = TRUE: m1Time = iMsecs + 250 ' delay 1/4 sec for repeats + Else ' has been down, ck for repeat + If iMsecs > m1Time Then m1Rpt = TRUE: m1Time = iMsecs + 50 ' repeat 20/sec + End If + m1Prev = TRUE + Else ' Btn 1 up + If m1Prev Then m1End = TRUE ' end of downtime (upedge) + m1Prev = FALSE ' for next time + End If + If m2Dn Then ' Btn 2 down + If Not m2Prev Then m2Clk = TRUE ' click (downedge) + m2Prev = TRUE + Else + m2Prev = FALSE + End If +End Sub + +Function isIn (x, a, b) ' ck between + If x >= a And x <= b Then isIn = TRUE +End Function + +Sub zSortIndexF (a(), ndx()) ' make index to a() + Dim i, j, t + For i = 1 To UBound(a) ' add one at a time + t = a(i) ' to be added + For j = i To 2 Step -1 ' merge in + If a(ndx(j - 1)) <= t Then Exit For + ndx(j) = ndx(j - 1) + Next j + ndx(j) = i + Next i +End Sub + +Function iMsecs () ' milliseconds since midnight UTC + iMsecs = Int(Timer(.001) * 1000 + .5) +End Function + +Function zRandAB (a, b) + zRandAB = a + Rnd * (b - a) +End Function + +Sub QtoMatrix () ' quaternion to matrix + ' https://www.euclideanspace.com/maths/geometry/rotations/conversions/ + Dim w, x, y, z, wx, wy, wz, xx, xy, xz, yy, yz, zz + w = QMain.w: x = QMain.x: y = QMain.y: z = QMain.z + wx = w * x + wy = w * y + wz = w * z + xx = x * x + xy = x * y + xz = x * z + yy = y * y + yz = y * z + zz = z * z + aMatrix(0, 0) = 1 - 2 * (yy + zz) + aMatrix(1, 1) = 1 - 2 * (xx + zz) + aMatrix(2, 2) = 1 - 2 * (xx + yy) + aMatrix(0, 1) = 2 * (xy - wz) + aMatrix(1, 0) = 2 * (xy + wz) + aMatrix(0, 2) = 2 * (xz + wy) + aMatrix(2, 0) = 2 * (xz - wy) + aMatrix(1, 2) = 2 * (yz - wx) + aMatrix(2, 1) = 2 * (yz + wx) +End Sub + +Sub QRandom () ' random (unit) quaternion + Dim w, x, y, z, d + w = zRandAB(-1, 1): x = zRandAB(-1, 1): y = zRandAB(-1, 1): z = zRandAB(-1, 1) + d = Sqr(w * w + x * x + y * y + z * z) + QMain.w = w / d: QMain.x = x / d: QMain.y = y / d: QMain.z = z / d +End Sub + diff --git a/code/petr/music1/bb.mp3 b/code/petr/music1/bb.mp3 new file mode 100644 index 0000000..5de4402 Binary files /dev/null and b/code/petr/music1/bb.mp3 differ diff --git a/code/petr/music1/bb.wav b/code/petr/music1/bb.wav new file mode 100644 index 0000000..9683e76 Binary files /dev/null and b/code/petr/music1/bb.wav differ diff --git a/code/petr/music1/bootie.mp3 b/code/petr/music1/bootie.mp3 new file mode 100644 index 0000000..7badbb1 Binary files /dev/null and b/code/petr/music1/bootie.mp3 differ diff --git a/code/petr/music1/empire.mp3 b/code/petr/music1/empire.mp3 new file mode 100644 index 0000000..581f42a Binary files /dev/null and b/code/petr/music1/empire.mp3 differ diff --git a/code/petr/music1/visual.bas b/code/petr/music1/visual.bas new file mode 100644 index 0000000..92403f1 --- /dev/null +++ b/code/petr/music1/visual.bas @@ -0,0 +1,718 @@ +which = 0 + +DIM sampleData AS _MEM + +IF which = 0 THEN + + CONST N = 512 + + 'dim shared pi as double + PI = 4 * ATN(1) + + DIM x_r(N - 1), x_i(N - 1) + DIM xx_r(N - 1), xx_i(N - 1) + + 'create signal + FOR i = 0 TO N - 1 + x_r(i) = 100 * SIN(2 * PI * 62.27 * i / N) + 25 * COS(2 * PI * 132.27 * i / N) + x_i(i) = 0 + NEXT + + fft xx_r(), xx_i(), x_r(), x_i(), N + + FOR i = 0 TO N - 1 + PRINT xx_r(i), xx_i(i), x_r(i), x_i(i) + NEXT + +END IF + +IF which = 1 THEN + + 'defdbl a-z + + sw = 1024 + sh = 600 + + DIM SHARED PI AS DOUBLE + 'pi = 2*asin(1) + PI = 4 * ATN(1) + + DECLARE SUB rfft(xx_r(), xx_i(), x_r(), N) + DECLARE SUB fft(xx_r(), xx_i(), x_r(), x_i(), N) + DECLARE SUB dft(xx_r(), xx_i(), x_r(), x_i(), N) + + + DIM x_r(sw - 1), x_i(sw - 1) + DIM xx_r(sw - 1), xx_i(sw - 1) + DIM t AS DOUBLE + + FOR i = 0 TO sw - 1 + x_r(i) = 100 * SIN(2 * PI * 62.27 * i / sw) + 25 * COS(2 * PI * 132.27 * i / sw) + x_i(i) = 0 + NEXT + + 'screenres sw, sh, 32 + SCREEN _NEWIMAGE(sw, sh, 32) + + PSET(0, sh / 4 - x_r(0)) + FOR i = 0 TO sw - 1 + LINE - (i, sh / 4 - x_r(i)), _RGB(100, 100, 100) + NEXT + + dft xx_r(), xx_i(), x_r(), x_i(), sw + PSET(0, 3 * sh / 4 - 0.1 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(0, 255, 0) + FOR i = 0 TO sw - 1 + LINE - (i, 3 * sh / 4 - 0.1 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(0, 255, 0) + NEXT + LINE(0, 3 * sh / 4) - STEP(sw, 0), _RGB(0, 255, 0), , &h5555 + + t = TIMER + FOR i = 0 TO 50 + fft xx_r(), xx_i(), x_r(), x_i(), sw + NEXT + LOCATE 1, 1 + PRINT "50x fft ";timer - t + + PSET(0, 50 + 3 * sh / 4 - 0.1 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(255, 0, 0) + FOR i = 0 TO sw - 1 + LINE - (i, 50 + 3 * sh / 4 - 0.1 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(255, 0, 0) + NEXT + LINE(0, 50 + 3 * sh / 4) - STEP(sw, 0), _RGB(255, 0, 0), , &h5555 + + + FOR i = 0 TO sw - 1 + xx_r(i) = 0 + xx_i(i) = 0 + NEXT + + t = TIMER + FOR i = 0 TO 50 + rfft xx_r(), xx_i(), x_r(), sw + NEXT + LOCATE 2, 1 + PRINT "50x rfft ";timer - t + + PSET(0, 100 + 3 * sh / 4 - 0.1 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(255, 255, 0) + FOR i = 0 TO sw - 1 + LINE - (i, 100 + 3 * sh / 4 - 0.1 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(255, 255, 0) + NEXT + LINE(0, 100 + 3 * sh / 4) - STEP(sw, 0), _RGB(255, 255, 0), , &h5555 + + SLEEP + SYSTEM + +END IF + +IF which = 2 THEN + + 'defdbl a-z + + sw = 512 + sh = 600 + + 'dim shared pi as double + 'pi = 2*asin(1) + PI = 4 * ATN(1) + + DECLARE SUB fft(xx_r(), xx_i(), x_r(), x_i(), N) + + DIM x_r(sw - 1), x_i(sw - 1) + DIM xx_r(sw - 1), xx_i(sw - 1) + 'dim t as double + + FOR i = 0 TO sw - 1 + 'x_r(i) = 100*sin(2*pi*62.27*i/sw) + 25*cos(2*pi*132.27*i/sw) + x_r(i) = 100 * SIN(0.08 * i) + 25 * COS(i) + x_i(i) = 0 + NEXT + + 'screenres sw, sh, 32 + SCREEN _NEWIMAGE(sw * 2, sh, 32) + + 'plot input signal + PSET(0, sh / 4 - x_r(0)) + FOR i = 0 TO sw - 1 + LINE - (i, sh / 4 - x_r(i)), _RGB(255, 0, 0) + NEXT + LINE(0, sh / 4) - STEP(sw, 0), _RGB(255, 0, 0), , &h5555 + COLOR _RGB(255, 0, 0) + _PRINTSTRING(0, 0), "input signal" + + fft xx_r(), xx_i(), x_r(), x_i(), sw + + 'plot its fft + PSET(0, 50 + 3 * sh / 4 - 0.01 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(255, 255, 0) + FOR i = 0 TO sw / 2 + LINE - (i * 2, 50 + 3 * sh / 4 - 0.01 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(255, 255, 0) + NEXT + LINE(0, 50 + 3 * sh / 4) - STEP(sw, 0), _RGB(255, 255, 0), , &h5555 + + 'set unwanted frequencies to zero + FOR i = 50 TO sw / 2 + xx_r(i) = 0 + xx_i(i) = 0 + xx_r(sw - i) = 0 + xx_i(sw - i) = 0 + NEXT + + 'plot fft of filtered signal + PSET(sw, 50 + 3 * sh / 4 - 0.01 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(255, 255, 0) + FOR i = 0 TO sw / 2 + LINE - (sw + i * 2, 50 + 3 * sh / 4 - 0.01 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(0, 155, 255) + NEXT + LINE(sw, 50 + 3 * sh / 4) - STEP(sw, 0), _RGB(0, 155, 255), , &h5555 + + 'take inverse fft + FOR i = 0 TO sw - 1 + xx_i(i) = - xx_i(i) + NEXT + + fft x_r(), x_i(), xx_r(), xx_i(), sw + + FOR i = 0 TO sw - 1 + x_r(i) = x_r(i) / sw + x_i(i) = x_i(i) / sw + NEXT + + 'plot filtered signal + PSET(sw, sh / 4 - x_r(0)) + FOR i = 0 TO sw - 1 + LINE - (sw + i, sh / 4 - x_r(i)), _RGB(0, 255, 0) + NEXT + LINE(sw, sh / 4) - STEP(sw, 0), _RGB(0, 255, 0), , &h5555 + + COLOR _RGB(0, 255, 0) + _PRINTSTRING(sw, 0), "filtered signal" + + SLEEP + SYSTEM + +END IF + +IF which = 3 THEN + + 'defdbl a-z + + sw = 1024 + sh = 600 + + 'dim shared pi as double + 'pi = 2*asin(1) + PI = 4 * ATN(1) + + DECLARE SUB rfft(xx_r(), xx_i(), x_r(), N) + + DIM x_r(sw - 1), x_i(sw - 1) + DIM xx_r(sw - 1), xx_i(sw - 1) + 'dim t as double + + FOR i = 0 TO sw - 1 + x_r(i) = 100 * SIN(2 * PI * (sw * 2000 / 44000) * i / sw) + (100 * RND - 50) + NEXT + + 'screenres sw, sh, 32 + SCREEN _NEWIMAGE(sw, sh, 32) + + 'plot signal + PSET(0, sh / 4 - x_r(0)) + FOR i = 0 TO sw - 1 + LINE - (i, sh / 4 - x_r(i)), _RGB(255, 0, 0) + NEXT + LINE(0, sh / 4) - STEP(sw, 0), _RGB(255, 0, 0), , &h5555 + + _PRINTSTRING(0, 0), "2000 kHz signal with RND noise sampled at 44 kHz in 1024 samples" + + rfft xx_r(), xx_i(), x_r(), sw + + 'plot its fft + PSET(0, 50 + 3 * sh / 4 - 0.005 * SQR(xx_r(0) * xx_r(0) + xx_i(0) * xx_i(0))), _RGB(255, 255, 0) + FOR i = 0 TO sw / 2 + LINE - (i * 2, 50 + 3 * sh / 4 - 0.005 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i))), _RGB(255, 255, 0) + NEXT + LINE(0, 50 + 3 * sh / 4) - STEP(sw, 0), _RGB(255, 255, 0), , &h5555 + + 'find peak + 'dim max as double, d as double + max1 = 0 + m = 0 + FOR i = 0 TO sw / 2 + d = 0.01 * SQR(xx_r(i) * xx_r(i) + xx_i(i) * xx_i(i)) + IF d > max1 THEN + max1 = d + m = i + END IF + NEXT + + _PRINTSTRING(0, sh / 2), "m_peak ="+str$(m) + _PRINTSTRING(0, sh / 2 + 16), "f_peak = m_peak * 44 kHz / 1024 samples = "+str$(m*44000/1024)+" Hz" + + 'apply frequency correction, only works for some signals + DIM c AS DOUBLE + DIM u_r AS double, u_i AS DOUBLE + DIM v_r AS double, v_i AS DOUBLE + + u_r = xx_r(m - 1) -xx_r(m + 1) + u_i = xx_i(m - 1) -xx_i(m + 1) + v_r = 2 * xx_r(m) - xx_r(m - 1) -xx_r(m + 1) + v_i = 2 * xx_i(m) - xx_i(m - 1) -xx_i(m + 1) + c = (u_r * v_r + u_i * v_i) /(v_r * v_r + v_i * v_i) + + _PRINTSTRING(0, sh / 2 + 2 * 16), "f_corrected = "+str$((m+c)*44000/1024)+" Hz" + + SLEEP + SYSTEM + +END IF + +IF which = 10 THEN + + song& = _SNDOPEN("empire.mp3") + IF song& = 0 THEN + PRINT "Failed to load song!" + END + END IF + + _SNDPLAY song& + + sampleData = _MEMSOUND(song&, 1) + IF sampleData.SIZE = 0 THEN + PRINT "Failed to access sound sample data." + END + END IF + + 'DIM i AS _UNSIGNED _INTEGER64 + 'DIM si AS INTEGER + 'DIM sz AS _UNSIGNED _INTEGER64 + + 'DIM rf AS SINGLE, lf AS SINGLE + + sz = _CV(_UNSIGNED _INTEGER64, _MK$(_OFFSET, sampleData.ELEMENTSIZE)) ' sz is the total size of the SOUND in bytes + + DO UNTIL _KEYHIT = 27 OR NOT _SNDPLAYING(song&) OR i + (_WIDTH * sz) > sampleData.SIZE + + CLS : PRINT i; "/"; sampleData.SIZE, "Frame Size ="; sz, "Data Type ="; sampleData.TYPE + + $Checking:OFF + IF SampleData.TYPE = 4 THEN ' Floating POINT stereo OR mono + total = 0 + min1 = 0 + max1 = 0 + FOR x& = 0 TO _WIDTH - 1 + lf = _MEMGET(SampleData, SampleData.OFFSET + i + x& * sz, SINGLE) ' GET SOUND DATA + total = total + ABS(lf) + IF lf < min1 THEN min1 = lf + IF lf > max1 THEN max1 = lf + rf = _MEMGET(SampleData, SampleData.OFFSET + 4 + i + x& * sz, SINGLE) ' GET SOUND DATA + 'LINE (x&, _HEIGHT / 2)-STEP(0, rf * 300), _RGB32(0, 111, 0) ' Plot wave + NEXT + LOCATE 2, 1 : PRINT INT(min1 * 100), INT(max1 * 100), INT(ABS(total / _WIDTH) * 100) + DIM vu AS INTEGER : vu = INT(ABS(total / _WIDTH) * 40) + DIM pk AS INTEGER : pk = INT(max1 * 40) : IF pk < 1 THEN pk = 1 + LOCATE 3, 1 : PRINT STRING$(vu, "=") + SPACE$(40 - vu) + LOCATE 3, pk : PRINT "|" + END IF + $Checking:ON + + i = FIX(_SNDGETPOS(song&) * _SNDRATE) * sz ' Calculate the new sample frame position + + LOOP + + _SNDCLOSE song& ' Closing the SOUND releases the MEM blocks + _AUTODISPLAY + + END + +END IF + +IF which = 20 THEN + + SCREEN _NEWIMAGE(800, 327, 32) + + PRINT "Loading..."; + song& = _SNDOPEN("empire.mp3") + IF song& = 0 THEN + PRINT "Failed to load song!" + END + END IF + PRINT "Done!" + + _SNDPLAY song& + + sampleData = _MEMSOUND(song&, 1) + IF sampleData.SIZE = 0 THEN + PRINT "Failed to access sound sample data." + END + END IF + + 'DIM i AS _UNSIGNED _INTEGER64 + 'DIM sf AS SINGLE + 'DIM si AS INTEGER + 'DIM sz AS _UNSIGNED _INTEGER64 + + 'DIM rf AS SINGLE, lf AS SINGLE + + sz = _CV(_UNSIGNED _INTEGER64, _MK$(_OFFSET, sampleData.ELEMENTSIZE)) ' sz is the total size of the SOUND in bytes + + DO UNTIL _KEYHIT = 27 OR NOT _SNDPLAYING(song&) OR i + (_WIDTH * sz) > sampleData.SIZE + + CLS : PRINT i; "/"; sampleData.SIZE, "Frame Size ="; sz, "Data Type ="; sampleData.TYPE + + $Checking:OFF + IF SampleData.TYPE = 130 THEN ' INTEGER stereo OR mono + FOR x& = 0 TO _WIDTH - 1 + si = _MEMGET(SampleData, SampleData.OFFSET + i + x& * sz, INTEGER) ' GET SOUND DATA + LINE(x&, _HEIGHT / 2) - STEP(0, 300 * si / 32768), _RGB32(0, 111, 0) ' Plot wave + NEXT + ELSEIF SampleData.TYPE = 4 THEN ' Floating POINT stereo OR mono + ' DIM total AS DOUBLE: total = 0 + ' DIM min1 AS SINGLE: min1 = 0 + ' DIM max1 AS SINGLE: max1 = 0 + FOR x& = 0 TO _WIDTH - 1 + lf = _MEMGET(SampleData, SampleData.OFFSET + i + x& * sz, SINGLE) ' GET SOUND DATA + ' total = total + ABS(lf) + ' IF lf < min1 THEN min1 = lf + ' IF lf > max1 THEN max1 = lf + rf = _MEMGET(SampleData, SampleData.OFFSET + 4 + i + x& * sz, SINGLE) ' GET SOUND DATA + LINE(x&, _HEIGHT / 2) - STEP(0, rf * 300), _RGB32(0, 111, 0) ' Plot wave + NEXT + ' LOCATE 2, 1: PRINT INT(min1 * 100), INT(max1 * 100), INT(ABS(total / _WIDTH) * 100) + ' DIM vu AS INTEGER: vu = INT(ABS(total / _WIDTH) * 40) + ' Dim pk AS INTEGER: pk = INT(max1 * 40): IF pk < 1 THEN pk = 1 + ' LOCATE 3, 1: PRINT STRING$(vu, "=") + SPACE$(40 - vu) + ' LOCATE 3, pk: PRINT "|" + ELSEIF sz = 2 AND SampleData.TYPE = 0 THEN ' INTEGER mono(QB64 OpenAL stuff) + FOR x& = 0 TO _WIDTH - 1 + si = _MEMGET(SampleData, SampleData.OFFSET + i + x& * sz, INTEGER) ' GET SOUND DATA + LINE(x&, _HEIGHT / 2) - STEP(0, 300 * si / 32768), _RGB32(0, 111, 0) ' Plot wave + NEXT + END IF + $Checking:ON + + _DISPLAY + _LIMIT 60 + + i = FIX(_SNDGETPOS(song&) * _SNDRATE) * sz ' Calculate the new sample frame position + + LOOP + + _SNDCLOSE song& ' Closing the SOUND releases the MEM blocks + _AUTODISPLAY + + END + +END IF + +IF which = 30 THEN + + DIM Texture AS SINGLE + DIM diY AS SINGLE + DIM VOL AS SINGLE + DIM DW AS SINGLE + DIM DH AS SINGLE + DIM ShiftIt AS SINGLE + DIM rows AS SINGLE + DIM Depth AS SINGLE + DIM ra AS SINGLE + DIM Z AS SINGLE + DIM X AS SINGLE + DIM HX AS SINGLE + DIM HX2 AS SINGLE + DIM HZ AS SINGLE + DIM HZ2 AS SINGLE + DIM HY1 AS SINGLE + DIM HY2 AS SINGLE + DIM HY3 AS SINGLE + DIM HY4 AS SINGLE + DIM HY11 AS SINGLE + DIM HY12 AS SINGLE + DIM HY13 AS SINGLE + DIM HY14 AS SINGLE + DIM FillCache AS SINGLE + DIM CLL AS SINGLE + DIM CLR AS SINGLE + DIM DL AS SINGLE + + Texture = _NEWIMAGE(255, 255, 32) + _DEST Texture + CLS, &HFFFF0000 + FOR diY = 0 TO 100 + LINE(diY + 20, diY + 20) -(235 - diY, 235 - diY), _RGB32(diY, 0, 0), B + NEXT + _DEST 0 + DIM SND AS LONG + DIM position AS LONG + 'DIM FillCachem AS Long + DIM HT AS LONG + DIM AS _FLOAT IL, IR, IntensityLeft, IntensityRight + DIM AS _MEM L ', R + DIM AS _UNSIGNED _BYTE Rc, Gc, Bc + REDIM LightsL(10) AS _UNSIGNED _BYTE + REDIM LightsR(10) AS _UNSIGNED _BYTE + DIM M3D(90, 90) AS SINGLE + DIM M2D(90, 90) AS SINGLE + SND = _SNDOPEN("empire.mp3") ' <----------------- insert here your sound file name! + VOL = 10 + _SNDVOL SND, VOL / 20 + L = _MEMSOUND(SND, 1) + IF L.SIZE = 0 THEN PRINT "ERROR1": BEEP: END + ' R = MemSound(SND, 2) + ' IF R.SIZE = 0 THEN PRINT "ERROR2": BEEP: END + DW = _DESKTOPWIDTH + DH = _DESKTOPHEIGHT + HT = _COPYIMAGE(Texture, 33) + _FREEIMAGE Texture + SCREEN _NEWIMAGE(DW, DH, 32) + _FULLSCREEN + _SNDPLAY SND + DO UNTIL position >= L.SIZE - 8192 + ShiftIt = 89 + DO UNTIL ShiftIt < 0 + FOR rows = 0 TO 90 + SWAP M3D(rows, ShiftIt), M3D(rows, ShiftIt + 1) + SWAP M2D(rows, ShiftIt), M2D(rows, ShiftIt + 1) + NEXT + ShiftIt = ShiftIt - 1 + LOOP + Depth = 0 + DO UNTIL Depth = 720 '90000 + IF Depth + position > L.SIZE THEN END + M3D(ra, 0) = _MEMGET(L, L.OFFSET + position + Depth, SINGLE) * 3.7 ' / 32768 * 1.7 + M2D(ra, 0) = _MEMGET(L, L.OFFSET + position + Depth + 4, SINGLE) * 3.7 ' / 32768 * 1.7 + Depth = Depth + 8 '1000 + ra = ra + 1 + LOOP + ra = 0 + FOR Z = 0 TO 89 + FOR X = 0 TO 89 + HX = -45 + X + HX2 = HX + 1 + HZ = -89 + Z + HZ2 = HZ + 1 + HY1 = -3 + M3D(X, Z) : HY2 = -3 + M3D(X + 1, Z) : HY3 = -3 + M3D(X, Z + 1) : HY4 = -3 + M3D(X + 1, Z + 1) + HY11 = 3 - M2D(X, Z) : HY12 = 3 - M2D(X + 1, Z) : HY13 = 3 - M2D(X, Z + 1) : HY14 = 3 - M2D(X + 1, Z + 1) + _MAPTRIANGLE(0, 0) -(255, 0) -(0, 255), HT TO(HX, HY1, HZ) -(HX2, HY2, HZ) -(HX, HY3, HZ2), 0, _Smooth + _MAPTRIANGLE(255, 0) -(0, 255) -(255, 255), HT TO(HX2, HY2, HZ) -(HX, HY3, HZ2) -(HX2, HY4, HZ2), 0, _Smooth + _MAPTRIANGLE(0, 0) -(255, 0) -(0, 255), HT TO(HX, HY11, HZ) -(HX2, HY12, HZ) -(HX, HY13, HZ2), 0, _Smooth + _MAPTRIANGLE(255, 0) -(0, 255) -(255, 255), HT TO(HX2, HY12, HZ) -(HX, HY13, HZ2) -(HX2, HY14, HZ2), 0, _Smooth + NEXT X, Z + + '----------------------------------------------------------------------------------------------------------- CIRCLES -------------------------------------------------------------- + FillCache = 0 + IntensityLeft = 0 + IntensityRight = 0 + DIM count AS INTEGER : count = 0 + DO UNTIL FillCache = 8192 + IntensityLeft = IntensityLeft + ABS(_MEMGET(L, L.OFFSET + position + FillCache, SINGLE)) ' / 32768) + IntensityRight = IntensityRight + ABS(_MEMGET(L, L.OFFSET + position + FillCache + 4, SINGLE)) ' / 32768) + FillCache = FillCache + 8 '2 + count = count + 1 + LOOP + IL = (IntensityLeft / count) * 512 ' / 2 ' recalc values AS decimal + IR = IntensityRight ' / 2 + REDIM LightsL(10) AS _UNSIGNED _BYTE + REDIM LightsR(10) AS _UNSIGNED _BYTE + CLL = 0 + DO UNTIL IL <= 0 + IF IL > 28 THEN LightsL(CLL) = 255 ELSE LightsL(CLL) = IL * 8 + IL = IL - 28 + CLL = CLL + 1 + MAX CLL, 10 + LOOP + CLR = 0 + DO UNTIL IR <= 0 + IF IR > 28 THEN LightsR(CLR) = 255 ELSE LightsR(CLR) = IR * 8 + IR = IR - 28 + CLR = CLR + 1 + MAX CLR, 10 + LOOP + IL = 0 + IR = 0 + FOR DL = 0 TO 10 + SELECT CASE DL + CASE 0 TO 5 + Rc = 0 : Gc = 255 : Bc = 0 + CASE 6 TO 8 + Rc = 255 : Gc = 255 : Bc = 0 + CASE is > 8 + Rc = 255 : Gc = 0 : Bc = 0 + END SELECT + CircleFill WIDTH / 2 - 50 - DL * 80, HEIGHT / 2, 30, &HFF000000 + CircleFill WIDTH / 2 - 50 - DL * 80, HEIGHT / 2, 30, _RGBA32(Rc, Gc, Bc, LightsL(DL)) + CircleFill WIDTH / 2 + 50 + DL * 80, HEIGHT / 2, 30, &HFF000000 + CircleFill WIDTH / 2 + 50 + DL * 80, HEIGHT / 2, 30, _RGBA32(Rc, Gc, Bc, LightsR(DL)) + NEXT + _DISPLAY + _LIMIT 120 + position = _SNDGETPOS(SND) * _SNDRATE * 2 + LOOP + + END + +END IF + +SUB MAX(value, mv) + IF value > mv THEN value = mv +END SUB + +SUB CircleFill(cx AS Integer, cy AS Integer, r AS Integer, c AS _UNSIGNED LONG) + ' CX = center x coordinate + ' CY = center y coordinate + ' R = radius + ' C = fill color + 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, 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 fft(xx_r(), xx_i(), x_r(), x_i(), N) + + DIM w_r AS double, w_i AS double, wm_r AS double, wm_i AS DOUBLE + DIM u_r AS double, u_i AS double, v_r AS double, v_i AS DOUBLE + + log2n = LOG(N) / LOG(2) + + 'bit rev copy + FOR i = 0 TO N - 1 + rev = 0 + FOR j = 0 TO log2n - 1 + IF i AND (2^j) THEN rev = rev + (2^(log2n - 1 - j)) + NEXT + xx_r(i) = x_r(rev) + xx_i(i) = x_i(rev) + NEXT + + FOR i = 1 TO log2n + m = 2^i + wm_r = COS(-2 * PI / m) + wm_i = SIN(-2 * PI / m) + FOR j = 0 TO N - 1 STEP m + w_r = 1 + w_i = 0 + FOR k = 0 TO m / 2 - 1 + p = j + k + q = p + (m \ 2) + u_r = w_r * xx_r(q) - w_i * xx_i(q) + u_i = w_r * xx_i(q) + w_i * xx_r(q) + v_r = xx_r(p) + v_i = xx_i(p) + xx_r(p) = v_r + u_r + xx_i(p) = v_i + u_i + xx_r(q) = v_r - u_r + xx_i(q) = v_i - u_i + u_r = w_r + u_i = w_i + w_r = u_r * wm_r - u_i * wm_i + w_i = u_r * wm_i + u_i * wm_r + NEXT + NEXT + + NEXT + +END SUB + +SUB rfft(xx_r(), xx_i(), x_r(), N) + DIM w_r AS double, w_i AS double, wm_r AS double, wm_i AS DOUBLE + DIM u_r AS double, u_i AS double, v_r AS double, v_i AS DOUBLE + + log2n = LOG(N / 2) / LOG(2) + + FOR i = 0 TO N / 2 - 1 + rev = 0 + FOR j = 0 TO log2n - 1 + IF i AND (2^j) THEN rev = rev + (2^(log2n - 1 - j)) + NEXT + + xx_r(i) = x_r(2 * rev) + xx_i(i) = x_r(2 * rev + 1) + NEXT + + FOR i = 1 TO log2n + m = 2^i + wm_r = COS(-2 * PI / m) + wm_i = SIN(-2 * PI / m) + + FOR j = 0 TO N / 2 - 1 STEP m + w_r = 1 + w_i = 0 + + FOR k = 0 TO m / 2 - 1 + p = j + k + q = p + (m \ 2) + + u_r = w_r * xx_r(q) - w_i * xx_i(q) + u_i = w_r * xx_i(q) + w_i * xx_r(q) + v_r = xx_r(p) + v_i = xx_i(p) + + xx_r(p) = v_r + u_r + xx_i(p) = v_i + u_i + xx_r(q) = v_r - u_r + xx_i(q) = v_i - u_i + + u_r = w_r + u_i = w_i + w_r = u_r * wm_r - u_i * wm_i + w_i = u_r * wm_i + u_i * wm_r + NEXT + NEXT + NEXT + + xx_r(N / 2) = xx_r(0) + xx_i(N / 2) = xx_i(0) + + FOR i = 1 TO N / 2 - 1 + xx_r(N / 2 + i) = xx_r(N / 2 - i) + xx_i(N / 2 + i) = xx_i(N / 2 - i) + NEXT + + DIM xpr AS double, xpi AS DOUBLE + DIM xmr AS double, xmi AS DOUBLE + + FOR i = 0 TO N / 2 - 1 + xpr = (xx_r(i) + xx_r(N / 2 + i)) / 2 + xpi = (xx_i(i) + xx_i(N / 2 + i)) / 2 + + xmr = (xx_r(i) - xx_r(N / 2 + i)) / 2 + xmi = (xx_i(i) - xx_i(N / 2 + i)) / 2 + + xx_r(i) = xpr + xpi * COS(2 * PI * i / N) - xmr * SIN(2 * PI * i / N) + xx_i(i) = xmi - xpi * SIN(2 * PI * i / N) -xmr * COS(2 * PI * i / N) + NEXT + + 'symmetry, complex conj + FOR i = 0 TO N / 2 - 1 + xx_r(N / 2 + i) = xx_r(N / 2 - 1 - i) + xx_i(N / 2 + i) = - xx_i(N / 2 - 1 - i) + NEXT + +END SUB + +SUB dft(xx_r(), xx_i(), x_r(), x_i(), N) + FOR i = 0 TO N - 1 + xx_r(i) = 0 + xx_i(i) = 0 + FOR j = 0 TO N - 1 + xx_r(i) = xx_r(i) + x_r(j) * COS(2 * PI * i * j / N) + x_i(j) * SIN(2 * PI * i * j / N) + xx_i(i) = xx_i(i) - x_r(j) * SIN(2 * PI * i * j / N) + x_i(j) * COS(2 * PI * i * j / N) + NEXT + NEXT +END SUB \ No newline at end of file diff --git a/code/sprezzo/epicycles/epicycles.bas b/code/sprezzo/epicycles/epicycles.bas new file mode 100644 index 0000000..66ceead --- /dev/null +++ b/code/sprezzo/epicycles/epicycles.bas @@ -0,0 +1,1004 @@ +Option _Explicit + + + +Do Until _ScreenExists: Loop + +_Title "Epicycles" + + + +Screen _NewImage(800, 600, 32) + + + +Type Vector + + x As Double + + y As Double + +End Type + + + +Dim RunningMode As Integer ' 0=mouse, 1=lissajoux, 2=etc + +RunningMode = 0 + + + +Dim As Long N, j, kh, i, m + +Dim As Double x0, y0, xp, yp, t + + + +Dim As Vector RawDataPoint(0 To 100000) + + + +Do + + Cls + + Line (0, 0)-(_Width, _Height), _RGB(255, 255, 255, 255), BF + + Color _RGB(0, 0, 0), _RGB(255, 255, 255) + + Locate 1, 1 + + Print "Click & Drag to draw a curve." + + Line (0, _Height / 2)-(_Width, _Height / 2), _RGB32(0, 0, 0, 255) + + Line (_Width / 2, 0)-(_Width / 2, _Height), _RGB32(0, 0, 0, 255) + + _Display + + + + N = 0 + + If (Command$ = "") Then + + If (RunningMode = 0) Then + + If (N = 0) Then + + N = GatherMousePoints&(RawDataPoint(), 5) + + End If + + End If + + If (RunningMode <> 0) Then + + N = 250 + + For j = 0 To N - 1 + + RawDataPoint(j).x = 0 + + RawDataPoint(j).y = 0 + + Next + + End If + + Else + + RunningMode = 0 + + Open Command$ For Input As #1 + + Do While Not EOF(1) + + Input #1, x0, y0 + + RawDataPoint(N).x = x0 + + RawDataPoint(N).y = y0 + + N = N + 1 + + Loop + + Close #1 + + Sleep + + End If + + + + ReDim GivenPoint(0 To N) As Vector + + For j = 0 To N - 1 + + GivenPoint(j) = RawDataPoint(j) + + Next + + + + ReDim As Vector Q(N - 1) + + ReDim As Double rad(N - 1) + + ReDim As Double phase(N - 1) + + ReDim As Long omega(N - 1) + + ReDim As Double urad(N - 1) + + ReDim As Double uphase(N - 1) + + ReDim As Long uomega(N - 1) + + ReDim As Vector CalculatedPath(N) + + ReDim As Vector ProtoPath(N * 60) + + ReDim As Vector PathSegmentsA(N, N) + + ReDim As Vector PathSegmentsB(N, N) + + + + For j = 0 To N - 1 + + omega(j) = j + + If (j > N / 2) Then omega(j) = j - N + + DFT Q(j).x, Q(j).y, GivenPoint(), j + + rad(j) = Sqr(Q(j).x * Q(j).x + Q(j).y * Q(j).y) + + phase(j) = _Atan2(Q(j).y, Q(j).x) + + Next + + + + If (RunningMode = 1) Then + + For j = 0 To (N - 1) + + rad(j) = 0 + + phase(j) = 0 + + Next + + Dim aa + + Dim bb + + ''' + + aa = 1 + + bb = 3 + + ''' + + rad(aa) = 30 + + rad(bb) = 30 + + phase(aa) = -_Pi + + phase(bb) = 3 * _Pi / 4 + + rad(N - aa) = 30 + + rad(N - bb) = 30 + + phase(N - aa) = 0 + + phase(N - bb) = -3 * _Pi / 4 + + End If + + + + If (RunningMode = 2) Then + + For j = 0 To (N - 1) + + rad(j) = 0 + + phase(j) = 0 + + Next + + ''' + + aa = 1 + + bb = 1 + + ''' + + rad(aa) = 50 + + phase(aa) = -_Pi / 2 + + rad(N - bb) = 25 + + phase(N - bb) = _Pi / 2 + + End If + + + + For j = 0 To N - 1 + + uomega(j) = omega(j) + + urad(j) = rad(j) + + uphase(j) = phase(j) + + Next + + + + Call QuickSort(0, N - 1, rad(), phase(), omega()) + + + + '''' + + 'Open "epi-out.txt" For Output As #1 + + 'For j = 0 To N - 1 + + ' Print #1, omega(j), Chr$(9), rad(j), Chr$(9), phase(j) + + 'Next + + 'Close #1 + + '''' + + 'Open "epi-uout.txt" For Output As #1 + + 'For j = 0 To N - 1 + + ' Print #1, uomega(j), Chr$(9), urad(j), Chr$(9), uphase(j) + + 'Next + + 'Close #1 + + '''' + + + + m = 0 + + CalculatedPath(0).x = GivenPoint(0).x + + CalculatedPath(0).y = GivenPoint(0).y + + For t = 0 To 2 * _Pi Step 2 * _Pi / N + + x0 = 0 + + y0 = 0 + + For j = 0 To N - 1 + + PathSegmentsA(m, j).x = x0 + + PathSegmentsA(m, j).y = y0 + + xp = rad(j) * Cos(phase(j) + t * omega(j)) + + yp = -rad(j) * Sin(phase(j) + t * omega(j)) + + x0 = x0 + xp + + y0 = y0 + yp + + PathSegmentsB(m, j).x = x0 + + PathSegmentsB(m, j).y = y0 + + Next + + CalculatedPath(m).x = x0 + + CalculatedPath(m).y = y0 + + m = m + 1 + + Next + + + + i = 0 + + + + _KeyClear + + Do + + + + m = 0 + + For t = 0 To (2 * _Pi) Step (2 * _Pi / (N * 60)) + + x0 = 0 + + y0 = 0 + + For j = 0 To N - 1 + + xp = rad(j) * Cos(phase(j) + t * omega(j)) + + yp = -rad(j) * Sin(phase(j) + t * omega(j)) + + x0 = x0 + xp + + y0 = y0 + yp + + If (j = i) Then + + ProtoPath(m).x = x0 + + ProtoPath(m).y = y0 + + Exit For + + End If + + Next + + m = m + 1 + + Next + + + + For j = 0 To N - 1 + + kh = _KeyHit + + Cls + + Locate 1, 1 + + Print "Approximation "; _Trim$(Str$(i)); " of "; _Trim$(Str$(N - 1)); ". Press any key to restart." + + Line (_Width / 2, _Height - 100)-(_Width / 2, _Height - 40), _RGB32(0, 0, 0, 55) + + For m = 0 To N - 1 + + Call CCircleF(GivenPoint(m).x, GivenPoint(m).y, 3, _RGB(155, 155, 155, 255)) + + Next + + For m = 0 To N - 2 + + Call LineSmooth(CalculatedPath(m).x, CalculatedPath(m).y, CalculatedPath(m + 1).x, CalculatedPath(m + 1).y, _RGB32(0, 0, 0, 75)) + + Next + + For m = 0 To i + + Call CCircle(PathSegmentsA(j, m).x, PathSegmentsA(j, m).y, rad(m), _RGB32(0, 127, 255, 155)) + + Call LineSmooth(PathSegmentsA(j, m).x, PathSegmentsA(j, m).y, PathSegmentsB(j, m).x, PathSegmentsB(j, m).y, _RGB32(28, 28, 255, 155)) + + Next + + For m = 0 To (j - 0) * 60 + + Call CCircleF(ProtoPath(m).x, ProtoPath(m).y, 1, _RGB32(255, 0, 255 * m / j, 255)) + + 'CALL LineSmooth(ProtoPath(m).x, ProtoPath(m).y, ProtoPath(m + 60).x, ProtoPath(m + 60).y, _RGB32(255, 0, 255 * m / j, 255)) + + Next + + Dim nn + + nn = N + + 'IF nn > 100 THEN nn = 100 + + For m = 0 To N - 1 + + y0 = .9 * _Width / nn + + x0 = uomega(m) * y0 - y0 / 2 + + Call CLineBF(x0, -(_Height) / 2 + 40, x0 + y0, -(_Height) / 2 + 40 + 20 * Log(1 + urad(m)), _RGB32(0, 0, 0, 55)) + + If (urad(m) > .001) Then + + Call CLineBF(x0, -(_Height) / 2 + 40, x0 + y0, -(_Height) / 2 + 40 + 10 * (uphase(m)), _RGB32(255, 0, 0, 55)) + + End If + + Next + + For m = 0 To i + + y0 = .9 * _Width / nn + + x0 = omega(m) * y0 - y0 / 2 + + Call CLineBF(x0, -(_Height) / 2 + 40, x0 + y0, -(_Height) / 2 + 40 + 20 * Log(1 + rad(m)), _RGB32(0, 0, 0, 155)) + + If (rad(m) > .001) Then + + Call CLineBF(x0, -(_Height) / 2 + 40, x0 + y0, -(_Height) / 2 + 40 + 10 * (phase(m)), _RGB32(255, 0, 0, 105)) + + End If + + Next + + + + '_DELAY .5 + + _Delay .1 / N + + _Display + + _Limit 60 + + + + If (kh <> 0) Then Exit Do + + Next + + + + If (i = N - 1) Then + + 'i = 0 + + Else + + i = i + 1 + Int(Sqr(i)) + + If (i >= N) Then i = N - 1 + + End If + + + + If (kh <> 0) Then + + kh = 0 + + Exit Do + + End If + + + + 'SLEEP 15 + + _Delay 1 + + + + Loop + +Loop + + + +Sleep + +System + + + +Sub DFT (re As Double, im As Double, arr() As Vector, j0 As Long) + + Dim As Long n, k + + Dim As Double u, v, arg + + n = UBound(arr) + + re = 0 + + im = 0 + + For k = 0 To n + + arg = 2 * _Pi * k * j0 / n + + cmul u, v, Cos(arg), Sin(arg), arr(k).x, arr(k).y + + re = re + u + + im = im - v + + Next + + re = re / n + + im = im / n + +End Sub + + + +Sub cmul (u As Double, v As Double, xx As Double, yy As Double, aa As Double, bb As Double) + + u = xx * aa - yy * bb + + v = xx * bb + yy * aa + +End Sub + + + +Sub CCircle (x0 As Double, y0 As Double, rad As Double, shade As _Unsigned Long) + + Circle (_Width / 2 + x0, -y0 + _Height / 2), rad, shade + +End Sub + + + +Sub CPset (x0 As Double, y0 As Double, shade As _Unsigned Long) + + PSet (_Width / 2 + x0, -y0 + _Height / 2), shade + +End Sub + + + +Sub CLine (x0 As Double, y0 As Double, x1 As Double, y1 As Double, shade As _Unsigned Long) + + Line (_Width / 2 + x0, -y0 + _Height / 2)-(_Width / 2 + x1, -y1 + _Height / 2), shade + +End Sub + + + +Sub CLineBF (x0 As Double, y0 As Double, x1 As Double, y1 As Double, shade As _Unsigned Long) + + Line (_Width / 2 + x0, -y0 + _Height / 2)-(_Width / 2 + x1, -y1 + _Height / 2), shade, BF + +End Sub + + + +Sub CCircleF (x As Long, y As Long, r As Long, c As Long) + + Dim As Long xx, yy, e + + xx = r + + yy = 0 + + e = -r + + Do While (yy < xx) + + If (e <= 0) Then + + yy = yy + 1 + + Call CLineBF(x - xx, y + yy, x + xx, y + yy, c) + + Call CLineBF(x - xx, y - yy, x + xx, y - yy, c) + + e = e + 2 * yy + + Else + + Call CLineBF(x - yy, y - xx, x + yy, y - xx, c) + + Call CLineBF(x - yy, y + xx, x + yy, y + xx, c) + + xx = xx - 1 + + e = e - 2 * xx + + End If + + Loop + + Call CLineBF(x - r, y, x + r, y, c) + +End Sub + + + +Sub LineSmooth (x0 As Single, y0 As Single, x1 As Single, y1 As Single, c As _Unsigned Long) + + ' source: https://en.wikipedia.org/w/index.php?title=Xiaolin_Wu%27s_line_algorithm&oldid=852445548 + + ' translated: FellippeHeitor @ qb64.org + + ' bugfixed for alpha channel + + + + Dim plX As Integer, plY As Integer, plI + + + + Dim steep As _Byte + + steep = Abs(y1 - y0) > Abs(x1 - x0) + + + + If steep Then + + Swap x0, y0 + + Swap x1, y1 + + End If + + + + If x0 > x1 Then + + Swap x0, x1 + + Swap y0, y1 + + End If + + + + Dim dx, dy, gradient + + dx = x1 - x0 + + dy = y1 - y0 + + gradient = dy / dx + + + + If dx = 0 Then + + gradient = 1 + + End If + + + + 'handle first endpoint + + Dim xend, yend, xgap, xpxl1, ypxl1 + + xend = _Round(x0) + + yend = y0 + gradient * (xend - x0) + + xgap = (1 - ((x0 + .5) - Int(x0 + .5))) + + xpxl1 = xend 'this will be used in the main loop + + ypxl1 = Int(yend) + + If steep Then + + plX = ypxl1 + + plY = xpxl1 + + plI = (1 - (yend - Int(yend))) * xgap + + GoSub plot + + + + plX = ypxl1 + 1 + + plY = xpxl1 + + plI = (yend - Int(yend)) * xgap + + GoSub plot + + Else + + plX = xpxl1 + + plY = ypxl1 + + plI = (1 - (yend - Int(yend))) * xgap + + GoSub plot + + + + plX = xpxl1 + + plY = ypxl1 + 1 + + plI = (yend - Int(yend)) * xgap + + GoSub plot + + End If + + + + Dim intery + + intery = yend + gradient 'first y-intersection for the main loop + + + + 'handle second endpoint + + Dim xpxl2, ypxl2 + + xend = _Round(x1) + + yend = y1 + gradient * (xend - x1) + + xgap = ((x1 + .5) - Int(x1 + .5)) + + xpxl2 = xend 'this will be used in the main loop + + ypxl2 = Int(yend) + + If steep Then + + plX = ypxl2 + + plY = xpxl2 + + plI = (1 - (yend - Int(yend))) * xgap + + GoSub plot + + + + plX = ypxl2 + 1 + + plY = xpxl2 + + plI = (yend - Int(yend)) * xgap + + GoSub plot + + Else + + plX = xpxl2 + + plY = ypxl2 + + plI = (1 - (yend - Int(yend))) * xgap + + GoSub plot + + + + plX = xpxl2 + + plY = ypxl2 + 1 + + plI = (yend - Int(yend)) * xgap + + GoSub plot + + End If + + + + 'main loop + + Dim x + + If steep Then + + For x = xpxl1 + 1 To xpxl2 - 1 + + plX = Int(intery) + + plY = x + + plI = (1 - (intery - Int(intery))) + + GoSub plot + + + + plX = Int(intery) + 1 + + plY = x + + plI = (intery - Int(intery)) + + GoSub plot + + + + intery = intery + gradient + + Next + + Else + + For x = xpxl1 + 1 To xpxl2 - 1 + + plX = x + + plY = Int(intery) + + plI = (1 - (intery - Int(intery))) + + GoSub plot + + + + plX = x + + plY = Int(intery) + 1 + + plI = (intery - Int(intery)) + + GoSub plot + + + + intery = intery + gradient + + Next + + End If + + + + Exit Sub + + + + plot: + + ' Change to regular PSET for standard coordinate orientation. + + Call CPset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c))) + + Return + +End Sub + + + +Function GatherMousePoints& (arr() As Vector, res As Double) + + Dim As Long i + + Dim As Double mx, my, xx, yy, delta, xold, yold + + xold = 0 + + yold = 0 + + i = 0 + + Do + + Do While _MouseInput + + mx = _MouseX + + my = _MouseY + + If _MouseButton(1) Then + + xx = mx - (_Width / 2) + + yy = -my + (_Height / 2) + + delta = Sqr((xx - xold) ^ 2 + (yy - yold) ^ 2) + + If (delta > res) Then + + Call CCircleF(xx, yy, 3, _RGB(0, 0, 0)) + + _Display + + arr(i).x = xx + + arr(i).y = yy + + xold = xx + + yold = yy + + i = i + 1 + + End If + + End If + + Loop + + If ((i > 2) And (Not _MouseButton(1))) Then Exit Do + + If (i > 999) Then Exit Do + + Loop + + GatherMousePoints& = i + +End Function + + + +Sub QuickSort (LowLimit As Long, HighLimit As Long, rad() As Double, phase() As Double, omega() As Long) + + Dim As Long piv + + If (LowLimit < HighLimit) Then + + piv = Partition(LowLimit, HighLimit, rad(), phase(), omega()) + + Call QuickSort(LowLimit, piv - 1, rad(), phase(), omega()) + + Call QuickSort(piv + 1, HighLimit, rad(), phase(), omega()) + + End If + +End Sub + + + +Function Partition (LowLimit As Long, HighLimit As Long, rad() As Double, phase() As Double, omega() As Long) + + Dim As Long i, j + + Dim As Double pivot, tmp + + pivot = rad(HighLimit) + + i = LowLimit - 1 + + For j = LowLimit To HighLimit - 1 + + tmp = rad(j) - pivot + + If (tmp >= 0) Then + + i = i + 1 + + Swap rad(i), rad(j) + + Swap phase(i), phase(j) + + Swap omega(i), omega(j) + + End If + + Next + + Swap rad(i + 1), rad(HighLimit) + + Swap phase(i + 1), phase(HighLimit) + + Swap omega(i + 1), omega(HighLimit) + + Partition = i + 1 + +End Function + + + + + diff --git a/code/sprezzo/epicycles/life_on_the_grid/life_on_the_grid.bas b/code/sprezzo/epicycles/life_on_the_grid/life_on_the_grid.bas new file mode 100644 index 0000000..3d6e00b --- /dev/null +++ b/code/sprezzo/epicycles/life_on_the_grid/life_on_the_grid.bas @@ -0,0 +1,246 @@ +Option _Explicit + +Screen _NewImage(800, 800, 32) + +_Title "GridLife - Click & Drag" + + + +Dim Shared GridWidth + +Dim Shared GridHeight + +Dim Shared CellWidth + +Dim Shared CellHeight + +GridWidth = _Width / 8 + +GridHeight = _Height / 8 + +CellWidth = _Width / GridWidth + +CellHeight = _Height / GridHeight + + + +Type Vector + + x As Double + + y As Double + + z As Double + +End Type + + + +Dim Shared MainGrid(GridWidth, GridHeight) As Vector + +Dim Shared AuxiGrid(GridWidth, GridHeight) As Vector + +Dim Shared GridVel(GridWidth, GridHeight) As Double + + + +Dim SelectedCelli + +Dim SelectedCellj + +Do + + + + Do While _MouseInput + + SelectedCelli = Int(_MouseX / CellWidth) + + SelectedCellj = Int(_MouseY / CellHeight) + + If _MouseButton(1) Then + + MainGrid(SelectedCelli, SelectedCellj).x = 8 + + MainGrid(SelectedCelli, SelectedCellj).y = 1 + + MainGrid(SelectedCelli, SelectedCellj).z = 6 + + GridVel(SelectedCelli, SelectedCellj) = 0 + + End If + + If _MouseButton(2) Then + + MainGrid(SelectedCelli, SelectedCellj).x = 0 + + MainGrid(SelectedCelli, SelectedCellj).y = 0 + + MainGrid(SelectedCelli, SelectedCellj).z = 0 + + GridVel(SelectedCelli, SelectedCellj) = 0 + + End If + + Loop + + + + Call UpdateGrid + + Cls + + Call PlotGrid + + _Display + + _Limit 30 + +Loop + + + +End + + + +Sub UpdateGrid + + Dim i As Integer + + Dim j As Integer + + Dim t As Double + + Dim As Vector a1, a2, a3, a4, a5, a6, a7, a8, a9 + + For i = 1 To GridWidth + + For j = 1 To GridHeight + + AuxiGrid(i, j).x = MainGrid(i, j).x + + AuxiGrid(i, j).y = MainGrid(i, j).y + + AuxiGrid(i, j).z = MainGrid(i, j).z + + Next + + Next + + For i = 1 To GridWidth - 1 + + For j = 1 To GridHeight - 1 + + a1 = AuxiGrid(i - 1, j + 1) + + a2 = AuxiGrid(i, j + 1) + + a3 = AuxiGrid(i + 1, j + 1) + + a4 = AuxiGrid(i - 1, j) + + a5 = AuxiGrid(i, j) + + a6 = AuxiGrid(i + 1, j) + + a7 = AuxiGrid(i - 1, j - 1) + + a8 = AuxiGrid(i, j - 1) + + a9 = AuxiGrid(i + 1, j - 1) + + + + ' Diffusion + + MainGrid(i, j).x = (1 / 5) * (a2.x + a4.x + a6.x + a8.x + a5.x) + + + + ' Game of life + + t = a1.y + a2.y + a3.y + a4.y + a6.y + a7.y + a8.y + a9.y + + If (a5.y = 1) Then + + Select Case t + + Case Is < 2 + + MainGrid(i, j).y = 0 + + Case 2 + + MainGrid(i, j).y = 1 + + Case 3 + + MainGrid(i, j).y = 1 + + Case Is > 3 + + MainGrid(i, j).y = 0 + + End Select + + Else + + If (t = 3) Then + + MainGrid(i, j).y = 1 + + End If + + End If + + + + ' Wave propagation + + Dim alpha + + Dim wp1 + + Dim wp2 + + alpha = .25 + + wp1 = alpha * (a6.z + a4.z) + 2 * (1 - alpha) * a5.z - GridVel(i, j) + + wp2 = alpha * (a2.z + a8.z) + 2 * (1 - alpha) * a5.z - GridVel(i, j) + + MainGrid(i, j).z = (0.98) * (1 / 2) * (wp1 + wp2) + + GridVel(i, j) = AuxiGrid(i, j).z + + Next + + Next + +End Sub + + + +Sub PlotGrid + + Dim i As Integer + + Dim j As Integer + + For i = 0 To GridWidth + + For j = 0 To GridHeight + + Line (i * CellWidth, j * CellHeight)-(i * CellWidth + CellWidth, j * CellHeight + CellHeight), _RGB32(255 * MainGrid(i, j).x, 25 + 230 * MainGrid(i, j).y, 255 * Abs(MainGrid(i, j).z)), BF + + Line (i * CellWidth, j * CellHeight)-(i * CellWidth + CellWidth, j * CellHeight + CellHeight), _RGB32(100, 100, 100), B + + Next + + Next + +End Sub + + + diff --git a/code/william33/rotating_tetraeder/rotating_tetraeder.bas b/code/william33/rotating_tetraeder/rotating_tetraeder.bas new file mode 100644 index 0000000..1ba162d --- /dev/null +++ b/code/william33/rotating_tetraeder/rotating_tetraeder.bas @@ -0,0 +1,146 @@ +'based on a YaBASIC example, ported by William33 +'the FillTriangle code is based on a Turbo Pascal example + +' https://qb64.boards.net/thread/42/rotating-tetraeder + +_TITLE "Tetraeder" + +SCREEN _NEWIMAGE(1280, 720, 32) + +DIM opoints(4, 3) +RESTORE points +FOR n = 1 TO 4: FOR p = 1 TO 3: READ opoints(n, p): NEXT p: NEXT n + +DIM triangles(4, 3) +RESTORE triangles +FOR n = 1 TO 4: FOR p = 1 TO 3: READ triangles(n, p): NEXT p: NEXT n + +phi = 0: dphi = 0.1: psi = 0: dpsi = 0.05 +DIM points(4, 3) + +r = 60: g = 20 +dr = 0.5: dg = 1.2: db = 3 +DO + _LIMIT 60 + CLS + phi = phi + dphi + psi = psi + dpsi + FOR n = 1 TO 4 + points(n, 1) = opoints(n, 1) * COS(phi) - opoints(n, 2) * SIN(phi) + points(n, 2) = opoints(n, 2) * COS(phi) + opoints(n, 1) * SIN(phi) + p2 = points(n, 2) * COS(psi) - opoints(n, 3) * SIN(psi) + points(n, 3) = opoints(n, 3) * COS(psi) + points(n, 2) * SIN(psi) + points(n, 2) = p2 + NEXT n + + r = r + dr: IF (r < 0 OR r > 60) THEN dr = -dr + g = g + dg: IF (g < 0 OR g > 60) THEN dg = -dg + b = b + db: IF (b < 0 OR b > 60) THEN db = -db + dm = dm + 0.01 + m = 120 - 80 * SIN(dm) + FOR n = 1 TO 4 + p1 = triangles(n, 1) + p2 = triangles(n, 2) + p3 = triangles(n, 3) + n1 = points(p1, 1) + points(p2, 1) + points(p3, 1) + n2 = points(p1, 2) + points(p2, 2) + points(p3, 2) + n3 = points(p1, 3) + points(p2, 3) + points(p3, 3) + IF (n3 > 0) THEN + sp = n1 * 0.5 - n2 * 0.7 - n3 * 0.6 + COLOR _RGB32(INT(60 + r + 30 * sp) MOD 256, INT(60 + g + 30 * sp) MOD 256, INT(60 + b + 30 * sp) MOD 256) + FillTriangle INT(_WIDTH / 2) + m * points(p1, 1), INT(_HEIGHT / 2) + m * points(p1, 2), INT(_WIDTH / 2) + m * points(p2, 1), INT(_HEIGHT / 2) + m * points(p2, 2), INT(_WIDTH / 2) + m * points(p3, 1), INT(_HEIGHT / 2) + m * points(p3, 2) + END IF + NEXT n + _DISPLAY + +LOOP UNTIL INKEY$ = CHR$(27) + +SYSTEM + +points: +DATA -1,-1,+1,+1,-1,-1,+1,+1,+1,-1,+1,-1 +triangles: +DATA 1,2,4,2,3,4,1,3,4,1,2,3 + + +SUB FillTriangle (xa AS INTEGER, ya AS INTEGER, xb AS INTEGER, yb AS INTEGER, xc AS INTEGER, yc AS INTEGER) + DIM y1 AS LONG, y2 AS LONG, y3 AS LONG, x1 AS LONG, x2 AS LONG, x3 AS LONG + DIM dx12 AS LONG, dx13 AS LONG, dx23 AS LONG + DIM dy12 AS LONG, dy13 AS LONG, dy23 AS LONG, dy AS LONG + DIM a AS LONG, b AS LONG + IF ya = yb THEN + yb = yb + 1 + END IF + IF ya = yc THEN + yc = yc + 1 + END IF + IF yc = yb THEN + yb = yb + 1 + END IF + IF (ya <> yb) AND (ya <> yc) AND (yc <> yb) THEN + IF (ya > yb) AND (ya > yc) THEN + y1 = ya: x1 = xa + IF yb > yc THEN + y2 = yb: x2 = xb + y3 = yc: x3 = xc + ELSE + y2 = yc: x2 = xc + y3 = yb: x3 = xb + END IF + ELSE + IF (yb > ya) AND (yb > yc) THEN + y1 = yb: x1 = xb + IF ya > yc THEN + y2 = ya: x2 = xa + y3 = yc: x3 = xc + ELSE + y2 = yc: x2 = xc + y3 = ya: x3 = xa + END IF + ELSE + IF (yc > yb) AND (yc > ya) THEN + y1 = yc: x1 = xc + IF yb >= ya THEN + y2 = yb: x2 = xb + y3 = ya: x3 = xa + ELSE + y2 = ya: x2 = xa + y3 = yb: x3 = xb + END IF + END IF + END IF + End if + dx12 = x2 - x1: dy12 = y2 - y1 + dx23 = x3 - x2: dy23 = y3 - y2 + dx13 = x3 - x1: dy13 = y3 - y1 + a = x2 - ((y2 - y3 + dy23) * dx23) / dy23 + b = x3 + (-dy23 * dx13) / (dy13) + IF (a < b) THEN + LINE (a, y2)-(b, y2) + FOR dy = 0 TO -dy23 - 1 + a = x2 + ((dy23 + dy) * dx23) / dy23 + b = x3 + (dy * dx13) / (dy13) + LINE (a, dy + y3)-(b, dy + y3) + NEXT + FOR dy = -dy23 + 1 TO -dy13 + a = x2 + ((dy23 + dy) * dx12) / dy12 + b = x3 + (dy * dx13) / (dy13) + LINE (a, dy + y3)-(b, dy + y3) + + NEXT + ELSE + LINE (b, y2)-(a, y2) + FOR dy = 0 TO -dy23 - 1 + a = x2 + ((dy23 + dy) * dx23) / dy23 + b = x3 + (dy * dx13) / (dy13) + LINE (a, dy + y3)-(b, dy + y3) + NEXT + FOR dy = -dy23 + 1 TO -dy13 + a = x2 + ((dy23 + dy) * dx12) / dy12 + b = x3 + (dy * dx13) / (dy13) + LINE (a, dy + y3)-(b, dy + y3) + NEXT + END IF + END IF + +END SUB