Posts: 1,215
Threads: 162
Joined: Apr 2022
Reputation:
34
04-17-2025, 06:58 PM
(This post was last modified: 04-17-2025, 06:58 PM by madscijr.)
Thank you!
I got a bit worried when I saw it was windowed, but it still works when you change
Code: (Select All) _ScreenMove 0, 0
to
Code: (Select All) _FullScreen
Here is the proggie with the code that quits if the user moves the mouse so it can be a screen saver:
Code: (Select All) _Title " Eye Candy #9B Closer (fullscreen)" ' b+ 2022-03-09
'fullscreen mod by Steve. 2025-04-17
Option _Explicit
DefDbl A-Z
Const fps = 80
Dim xmax, ymax As Integer
ReDim colr(0 To 0) As _Unsigned Long
Dim p2 As Single
Dim xc, yc As Single
Dim diag As Single
Dim a As Single
Dim i As Single
Dim r As Single
Dim sx1, sy1, sx2, sy2, sx3, sy3, dx1, dy1, dx2, dy2, dx3, dy3 As Long
Dim toggle As Integer: toggle = 0
Dim source&
Dim Shared cN, pR, pG, pB As Long
Dim ro As Single
Dim s As Single
Dim OldMouseX, OldMouseY As Integer
Dim bFinished As Integer: bFinished = _FALSE
xmax = _DesktopWidth: ymax = _DesktopHeight
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement
xc = xmax / 2
yc = ymax / 2
diag = Sqr(xc * xc + yc * yc)
ReDim colr(-100 To diag + 1000) As _Unsigned Long
p2 = _Pi * 2
While 1
resetPlasma
For i = -100 To diag + 1000
colr(i) = Plasma~&
Next
ro = 950: s = 0
While ro > -50
Cls
For a = 0 To p2 / 64 Step p2 / (16 * 360)
i = 50 * Sin(s) ' 2 * s or just s
For r = 0 To diag
PSet (xc + r * Cos(a), yc + r * Sin(a)), colr(r + i + ro)
Next
s = s + p2 / 180
Next
sx1 = xc: sy1 = yc: sx2 = xc + diag * Cos(.002): sy2 = yc + diag * Sin(.002): sx3 = xc + diag * Cos(p2 / 64 - .002): sy3 = yc + diag * Sin(p2 / 64 - .002)
For a = p2 / 64 To p2 - p2 / 64 Step p2 / 64
dx1 = xc: dy1 = yc: dx2 = xc + diag * Cos(a): dy2 = yc + diag * Sin(a): dx3 = xc + diag * Cos(a + p2 / 64): dy3 = yc + diag * Sin(a + p2 / 64)
_MapTriangle (sx1, sy1)-(sx2, sy2)-(sx3, sy3), source& To(dx1, dy1)-(dx2, dy2)-(dx3, dy3), 0
Next
'Line (0, 0)-(xc - 1.5 * yc, _Height), &HFF000000, BF
'Line (xc + 1.5 * yc, 0)-(_Width, _Height), &HFF000000, BF
_PutImage (0, 0)-(_Width, _Height), , , (xc - 1.5 * yc, 0)-(xc + 1.5 * yc, _Height)
toggle = 1 - toggle
If toggle Then _Display
' If user moves mouse or presses Esc then quit
While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Or _KeyDown(27) Then bFinished = _TRUE: Exit While
_Limit fps
ro = ro - 1
Wend
If bFinished = _TRUE Then Exit While
Wend
System
Function Plasma~& ()
cN = cN + .2
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub
Thanks again!
Posts: 1,215
Threads: 162
Joined: Apr 2022
Reputation:
34
04-18-2025, 03:07 AM
(This post was last modified: 04-18-2025, 01:31 PM by madscijr.
Edit Reason: (Fixed an error where in some cases it wasn't recording the error for the current function or saving the min/max function tried.)
)
Here is an experimental version that lets you try different math functions (SIN / COS / etc.) for Plasma and pset color.
Press arrow up/down to change the function used by Plasma~&
and left/right to change the function used for the pset color.
Some of them cause errors, but the program traps the errors, and at the end reports on which failed.
A couple of them fail in a really spectacular way, where the spin reverses, and everything accelerates and gets sucked into the center lika black hole!
If only we could keep that going for a little longer it would be even neater! 
The math for this stuff is a little beyond my comprehension, I'm just plugging numbers in to see what works.
The result is really cool looking for certain combinations!!
I would love to see any modifications anyone has that change the look in cool ways...
Code: (Select All) ' Eye Candy #9B by bplus, Mini-Mod
' 04-30-2022, 07:55 PM (This post was last modified: 04-30-2022, 08:19 PM by bplus.)
' https://qb64phoenix.com/forum/showthread.php?tid=219&pid=1291#pid1291
_Title "Eye Candy #9B Closer (fullscreen)(debug)" ' b+ 2022-03-09
' fullscreen mod by Steve. 2025-04-17
' mods by madscijr, 2025-04-17:
' - added Steve's mouse check (touch mouse to close, for screen saver)
' - hotkey to try different functions e.g., SIN COS TAN _COT _CSC _SEC etc.
' - catch errors, log & avoid functions which errored out
' - show report detailing which functions worked/failed
' INSTRUCTIONS:
' LEFT/RIGHT...............next/previous function #1
' UP /DOWN ...............next/previous function #2
' SPACE....................show/hide function names/values
' ESC OR MOVE MOUSE........quit
' (any other key)..........restart cycle/new colors
Option _Explicit
DefDbl A-Z
Const fps = 80
Const cSecondsPerFunction = 30 ' # seconds before next function cycles
' KEY CODES FOR _BUTTON
Const KeyCode_Escape = 2
Const KeyCode_Spacebar = 58
Const KeyCode_Enter = 29
Const KeyCode_Up = 329
Const KeyCode_Down = 337
Const KeyCode_Left = 332
Const KeyCode_Right = 334
Type FunctionType
Name As String ' description of the code to try
ErrorMessage As String ' if code has failed contains error message
End Type
Type IndexType
Name As String ' description of current code
Index As Integer ' index of current code
Min As Integer ' minimum index of code array to try
Max As Integer ' maximum index of code array to try
TriedMin As Integer ' lowest index tried
TriedMax As Integer ' highest index tried
End Type
ReDim Shared arrFunction(0 To 50, 0 To 1) As FunctionType
ReDim Shared arrWhich(0 To 1) As IndexType ' index of current function select case checks for
ReDim Shared arrText(1 To 2, 1 To 255) As String ' (column, line)
'redim Shared arrRows(1 to 2) as integer
ReDim Shared colr(0 To 0) As _Unsigned Long
Dim Shared cN, pR, pG, pB
Dim Shared diag As Single
Dim Shared ErrCount As Integer: ErrCount = 0
Dim xmax, ymax As Integer
Dim p2 As Single
Dim xc, yc As Single
Dim a As Single
Dim r As Single
Dim sx1, sy1, sx2, sy2, sx3, sy3, dx1, dy1, dx2, dy2, dx3, dy3 As Long
Dim toggle As Integer: toggle = 0
Dim source&: source& = 0
Dim ro As Single
Dim s As Single
Dim k$
Dim LastKey$: LastKey$ = ""
Dim iLastKeyCode%: iLastKeyCode% = 0
Dim iTo#
Dim iStep#
'Dim Shared iFuncNum% ' index of current function select case checks for
Dim Shared FuncName$ ' name of current function
Dim bShowFuncName%: bShowFuncName% = _TRUE
Dim iFrameCount% ' counts frames
Dim iFramesPerFunction% ' # frames before next function cycles
Dim iValue%, iLoop%, iIndex%, iLine%
Dim message$
Dim MaxCols%, MaxRows% ' for printing text on screen
Dim ColNum, RowNum, FirstRow, LastRow, NoRow, GoodRows, BadRows As Integer
Dim NextLine$
Dim InstColor~&: InstColor~& = _RGB32(0, 0, 0)
Dim OldMouseX, OldMouseY As Integer
Dim Shared LastCode$ ' where in the code we are
Dim Shared LastChangedIndex As Integer ' which set of functions we changed
Dim Shared LastError$: LastError$ = ""
Dim bFinished As Integer: bFinished = _FALSE
' SET ERROR TRAPPING
LastCode$ = ""
LastChangedIndex = -1
LastError$ = ""
On Error GoTo ErrorHandler
' INITIALIZE
iFramesPerFunction% = cSecondsPerFunction * fps
xmax = _DesktopWidth
ymax = _DesktopHeight
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
_Display
_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement
' for printing text
MaxCols% = (xmax / _FontWidth)
MaxRows% = (ymax / _FontHeight)
FirstRow = (MaxRows% / 2) - 2
' Center:
xc = xmax / 2
yc = ymax / 2
diag = Sqr(xc * xc + yc * yc)
ReDim colr(-100 To diag + 1000) As _Unsigned Long
p2 = _Pi * 2
arrWhich(0).Min = 0 ' min value select case checks for in Function Plasma~&
arrWhich(0).Max = 5 ' max value select case checks for in Function Plasma~&
arrWhich(0).Index = arrWhich(0).Min
arrWhich(0).TriedMin = arrWhich(0).Index ' lowest index tried
arrWhich(0).TriedMax = arrWhich(0).Index ' highest index tried
arrWhich(1).Min = LBound(arrFunction, 1)
arrWhich(1).Max = UBound(arrFunction, 1)
arrWhich(1).Index = arrWhich(1).Min
arrWhich(1).TriedMin = arrWhich(1).Index ' lowest index tried
arrWhich(1).TriedMax = arrWhich(1).Index ' highest index tried
iFrameCount% = 0
Randomize Timer
_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement
While 1
LastCode$ = "ReInitPlasma" ' Save code location for error handler
ReInitPlasma
ro = 950
s = 0
While ro > -50
' PROCESS KEYBOARD INPUT
LastCode$ = "KEYBOARD" ' Save code location for error handler
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape) Then
' ESC = QUIT
iLastKeyCode% = KeyCode_Escape
bFinished = _TRUE: Exit While
ElseIf _Button(KeyCode_Up) Then
' TRY NEXT FUNCTION #1
If iLastKeyCode% <> KeyCode_Up Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Up
' Move to the next function that hasn't had an error
Do
arrWhich(0).Index = arrWhich(0).Index + 1
If arrWhich(0).Index > arrWhich(0).Max Then arrWhich(0).Index = arrWhich(0).Min
If arrWhich(0).Index > arrWhich(0).TriedMax Then arrWhich(0).TriedMax = arrWhich(0).Index ' highest index tried
If arrWhich(0).Index < arrWhich(0).TriedMin Then arrWhich(0).TriedMin = arrWhich(0).Index ' lowest index tried
If Len(arrFunction(arrWhich(0).Index, 0).ErrorMessage) = 0 Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 0
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Down) Then
' TRY PREVIOUS FUNCTION #1
If iLastKeyCode% <> KeyCode_Down Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Down
' Move to the next function that hasn't had an error
Do
arrWhich(0).Index = arrWhich(0).Index - 1
If arrWhich(0).Index < arrWhich(0).Min Then arrWhich(0).Index = arrWhich(0).Max
If arrWhich(0).Index > arrWhich(0).TriedMax Then arrWhich(0).TriedMax = arrWhich(0).Index ' highest index tried
If arrWhich(0).Index < arrWhich(0).TriedMin Then arrWhich(0).TriedMin = arrWhich(0).Index ' lowest index tried
If Len(arrFunction(arrWhich(0).Index, 0).ErrorMessage) = 0 Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 0
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Right) Then
' TRY NEXT FUNCTION #2
If iLastKeyCode% <> KeyCode_Right Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Right
' Move to the next function that hasn't had an error
Do
arrWhich(1).Index = arrWhich(1).Index + 1
If arrWhich(1).Index > arrWhich(1).Max Then arrWhich(1).Index = arrWhich(1).Min
If arrWhich(1).Index > arrWhich(1).TriedMax Then arrWhich(1).TriedMax = arrWhich(1).Index ' highest index tried
If arrWhich(1).Index < arrWhich(1).TriedMin Then arrWhich(1).TriedMin = arrWhich(1).Index ' lowest index tried
If Len(arrFunction(arrWhich(1).Index, 1).ErrorMessage) = 0 Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 1
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Left) Then
' TRY PREVIOUS FUNCTION #2
If iLastKeyCode% <> KeyCode_Left Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Left
' Move to the next function that hasn't had an error
Do
arrWhich(1).Index = arrWhich(1).Index - 1
If arrWhich(1).Index < arrWhich(1).Min Then arrWhich(1).Index = arrWhich(1).Max
If arrWhich(1).Index > arrWhich(1).TriedMax Then arrWhich(1).TriedMax = arrWhich(1).Index ' highest index tried
If arrWhich(1).Index < arrWhich(1).TriedMin Then arrWhich(1).TriedMin = arrWhich(1).Index ' lowest index tried
If Len(arrFunction(arrWhich(1).Index, 1).ErrorMessage) = 0 Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 1
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Spacebar) Then
' ENTER = SHOW/HIDE FUNCTION NAME
If iLastKeyCode% <> KeyCode_Spacebar Then
bShowFuncName% = Not (bShowFuncName%)
iLastKeyCode% = KeyCode_Spacebar
End If
Else
' Clear last keycode pressed (since it wasn't any of those)
iLastKeyCode% = 0
' Now detect using InKey$
k$ = InKey$: _KeyClear
If Len(k$) Then
If k$ = "1" Then
If LastKey$ <> "1" Then
' Remember last key pressed to prevent holding it down
LastKey$ = "1"
' Mark current func #1 as "rejected"
arrFunction(arrWhich(0).Index, 0).ErrorMessage = "(rejected by user)"
' Make a noise
Beep
' Move to the next function that hasn't had an error
Do
arrWhich(0).Index = arrWhich(0).Index + 1
If arrWhich(0).Index > arrWhich(0).Max Then arrWhich(0).Index = arrWhich(0).Min
If arrWhich(0).Index > arrWhich(0).TriedMax Then arrWhich(0).TriedMax = arrWhich(0).Index ' highest index tried
If arrWhich(0).Index < arrWhich(0).TriedMin Then arrWhich(0).TriedMin = arrWhich(0).Index ' lowest index tried
If Len(arrFunction(arrWhich(0).Index, 0).ErrorMessage) = 0 Then Exit Do
Loop
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf k$ = "2" Then
If LastKey$ <> "2" Then
' Remember last key pressed to prevent holding it down
LastKey$ = "2"
' Mark current func #2 as "rejected"
arrFunction(arrWhich(1).Index, 1).ErrorMessage = "(rejected by user)"
' Make a noise
Beep
' Move to the next function that hasn't had an error
Do
arrWhich(1).Index = arrWhich(1).Index + 1
If arrWhich(1).Index > arrWhich(1).Max Then arrWhich(1).Index = arrWhich(1).Min
If Len(arrFunction(arrWhich(1).Index, 1).ErrorMessage) = 0 Then Exit Do
Loop
' restart cycle
Exit While
End If
Else
' Clear last InKey$ pressed
LastKey$ = ""
' ANY OTHER KEY = CHANGE COLORS
Exit While
End If
Else
' Clear last key pressed
iLastKeyCode% = 0
LastKey$ = ""
End If
End If
_KeyClear ' CLEAR KEYBOARD BUFFER
' Tie dye!
LastCode$ = "Tie dye!" ' Save code location for error handler
Cls
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
iTo# = p2 / 64
iStep# = p2 / (16 * 360)
' TRY UNTIL WE FIND A FUNCTION #2 THAT WORKS
Do
LastError$ = ""
LastCode$ = "For a = 0 To ..." ' Save code location for error handler
'For a = 0 To p2 / 64 Step p2 / (16 * 360)
For a = 0 To iTo# Step iStep#
LastCode$ = "Select Case arrWhich(1).Index: (Set iValue%)" ' Save code location for error handler
Select Case arrWhich(1).Index:
Case 0:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s)"
iValue% = 50 * Sin(s) ' 2 * s or just s
Case 1:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s * 2)"
iValue% = 50 * Sin(s * 2) ' 2 * s or just s
Case 2:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s * 3)"
iValue% = 50 * Sin(s * 3)
Case 3:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s * 4)"
iValue% = 50 * Sin(s * 4)
Case 4:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s * 5)"
iValue% = 50 * Sin(s * 5)
Case 5:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Cos(s * 1)"
iValue% = 50 * Cos(s * 1)
Case 6:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Cos(s * 2)"
iValue% = 50 * Cos(s * 2)
Case 7:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Cos(s * 3)"
iValue% = 50 * Cos(s * 3)
Case 8:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Cos(s * 4)"
iValue% = 50 * Cos(s * 4)
Case 9:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 25 * Cos(s * 5)"
iValue% = 25 * Cos(s * 5)
Case 10:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * Tan(s * 1)"
iValue% = 1 * Tan(s * 1)
Case 11:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * Tan(s * 2)"
iValue% = 1 * Tan(s * 2)
Case 12:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Sec(s * 2)"
iValue% = 1 * _Sec(s * 2)
Case 13:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acos(s * 1)"
iValue% = 1 * _Acos(s * 1)
Case 14:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acos(s * 2)"
iValue% = 1 * _Acos(s * 2)
Case 15:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acos(s * 3)"
iValue% = 1 * _Acos(s * 3)
Case 16:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acos(s * 4)"
iValue% = 1 * _Acos(s * 4)
Case 17:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acos(s * 5)"
iValue% = 1 * _Acos(s * 5)
Case 18:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Acosh(s * 2)"
iValue% = 1 * _Acosh(s * 2)
Case 19:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Asin(s * 2)"
iValue% = 1 * _Asin(s * 2)
Case 20:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Asinh(s * 2)"
iValue% = 1 * _Asinh(s * 2)
Case 21:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * Atn(s * 2)"
iValue% = 1 * Atn(s * 2)
Case 22:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Tanh(s * 2)"
iValue% = 1 * _Tanh(s * 2)
Case 23:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Atanh(s * 1)"
iValue% = 1 * _Atanh(s * 1)
Case 24:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Atanh(s * 4)"
iValue% = 1 * _Atanh(s * 4)
Case 25:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Arccot(s * 1)"
iValue% = 1 * _Arccot(s * 1)
Case 26:
' STARTED GOING BACKWARDS! BUT CRASHED!
' HOW CAN WE KEEP THESE GOING SO IT SUCKS EVERYTHING IN LIKE A BLACK HOLE?
' THAT WOULD LOOK REALLY COOL! :-D
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .009) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .009)
Case 27:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .008) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .008)
Case 28:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .007) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .007)
Case 29:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .006) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .006)
Case 30:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .005) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .005)
Case 31:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .002) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .002)
Case 32:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Coth(s * .001)"
iValue% = 1 * _Coth(s * .001)
Case 33:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Sech(s * .001)"
iValue% = 1 * _Sech(s * .001)
Case 34:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Sech(s * .005)"
iValue% = 1 * _Sech(s * .005)
Case 35:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Sech(s * .05)"
iValue% = 1 * _Sech(s * .05)
Case 36:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 1 * _Sech(s * .1)"
iValue% = 1 * _Sech(s * .1)
Case 37:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (s / 50) * 25"
iValue% = (s / 50) * 25
Case 38:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (s / 500) * 25"
iValue% = (s / 500) * 25
Case 39:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (s / 500) * p2 ^ .25"
iValue% = (s / 500) * p2 ^ .25
Case 40:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (s / 500) * p2 ^ (a * .25)"
iValue% = (s / 500) * p2 ^ (a * .25)
Case 41:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (s / 500) * p2 ^ a"
iValue% = (s / 500) * p2 ^ a
Case 42:
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = (a / 50000) * s ^ (p2 * .25)"
iValue% = (a / 50000) * s ^ (p2 * .25)
Case Else:
arrWhich(1).Index = 0
arrFunction(arrWhich(1).Index, 1).ErrorMessage = ""
arrFunction(arrWhich(1).Index, 1).Name = "iValue% = 50 * Sin(s)"
iValue% = 50 * Sin(s) ' 2 * s or just s
End Select
' DID IT FAIL?
If Len(LastError$) = 0 Then
' WE MADE IT PAST THE FUNCTION SELECTION
LastCode$ = "For r = 0 To diag"
For r = 0 To diag
LastCode$ = "PSet" ' Save code location for error handler
PSet (xc + r * Cos(a), yc + r * Sin(a)), colr(r + iValue% + ro)
' DID IT FAIL?
If Len(LastError$) > 0 Then Exit For
Next r
End If
' DID IT FAIL?
If Len(LastError$) = 0 Then
LastCode$ = "s = s + p2 / 180" ' Save code location for error handler
s = s + p2 / 180
End If
' DID IT FAIL?
If Len(LastError$) > 0 Then Exit For
Next a
' IT DIDN'T FAIL, WE CAN EXIT
If Len(LastError$) = 0 Then
Exit Do
Else
' Move to the next function that hasn't had an error
Do
arrWhich(1).Index = arrWhich(1).Index + 1
If arrWhich(1).Index > arrWhich(1).Max Then arrWhich(1).Index = arrWhich(1).Min
If arrWhich(1).Index > arrWhich(1).TriedMax Then arrWhich(1).TriedMax = arrWhich(1).Index ' highest index tried
If arrWhich(1).Index < arrWhich(1).TriedMin Then arrWhich(1).TriedMin = arrWhich(1).Index ' lowest index tried
If Len(arrFunction(arrWhich(1).Index, 0).ErrorMessage) = 0 Then Exit Do
Loop
End If
Loop
' MAP TRIANGLES SECTION
LastCode$ = "MAP TRIANGLES SECTION" ' Save code location for error handler
sx1 = xc
sy1 = yc
sx2 = xc + diag * Cos(.002)
sy2 = yc + diag * Sin(.002)
sx3 = xc + diag * Cos(p2 / 64 - .002)
sy3 = yc + diag * Sin(p2 / 64 - .002)
For a = p2 / 64 To p2 - p2 / 64 Step p2 / 64
dx1 = xc
dy1 = yc
dx2 = xc + diag * Cos(a)
dy2 = yc + diag * Sin(a)
dx3 = xc + diag * Cos(a + p2 / 64)
dy3 = yc + diag * Sin(a + p2 / 64)
_MapTriangle (sx1, sy1)-(sx2, sy2)-(sx3, sy3), source& To(dx1, dy1)-(dx2, dy2)-(dx3, dy3), 0
Next a
'Line (0, 0)-(xc - 1.5 * yc, _Height), &HFF000000, BF
'Line (xc + 1.5 * yc, 0)-(_Width, _Height), &HFF000000, BF
' COPY IMAGE TO SCREEN
LastCode$ = "_PutImage" ' Save code location for error handler
_PutImage (0, 0)-(_Width, _Height), , , (xc - 1.5 * yc, 0)-(xc + 1.5 * yc, _Height)
' SHOW THE CURRENT GEOMETRY FUNCTIONS BEING USED + VALUES FOR DEBUGGING
If bShowFuncName% = _TRUE Then
LastCode$ = "If bShowFuncName% = _TRUE Then" ' Save code location for error handler
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
RowNum = 0: ColNum = 1
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "INSTRUCTIONS:";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "LEFT/RIGHT...............next/previous function #1";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "UP /DOWN ...............next/previous function #2";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "SPACE....................show/hide function names/values";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "ESC OR MOVE MOUSE........quit";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "(any other key)..........restart cycle/new colors";
message$ = "Function #1=" + arrFunction(arrWhich(0).Index, 0).Name + _
", " + _
_ToStr$(arrWhich(0).Index) + _
" of " + _
"(" + _
_ToStr$(arrWhich(0).TriedMin) + _
"-" + _
_ToStr$(arrWhich(0).TriedMax) + _
")" + _
" " + _
"[" + _
_ToStr$(lbound(arrFunction,1)) + _
".." + _
_ToStr$(ubound(arrFunction,1)) + _
"]" + _
""
RowNum = FirstRow
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
message$ = "Function #2=" + arrFunction(arrWhich(1).Index, 1).Name + _
", " + _
_ToStr$(arrWhich(1).Index) + _
" of " + _
"(" + _
_ToStr$(arrWhich(1).TriedMin) + _
"-" + _
_ToStr$(arrWhich(1).TriedMax) + _
")" + _
" " + _
"[" + _
_ToStr$(lbound(arrFunction,1)) + _
".." + _
_ToStr$(ubound(arrFunction,1)) + _
"]" + _
""
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW iValue%
message$ = "iValue%=" + _ToStr$(iValue%)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW ro
message$ = "ro=" + _ToStr$(ro)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW error count
message$ = "ErrCount=" + _ToStr$(ErrCount)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
End If
LastCode$ = "toggle" ' Save code location for error handler
toggle = 1 - toggle
If toggle Then
'_Dest 0
'message$ = "TOP LEFT": _PrintString (0, 0), message$
'message$ = "TOP RIGHT": _PrintString (_DesktopWidth - (Len(message$) * _FontWidth), 0), message$
'message$ = "BOTTOM LEFT": _PrintString (0, (_DesktopHeight - _FontWidth)), message$
'message$ = "BOTTOM RIGHT": _PrintString (_DesktopWidth - (Len(message$) * _FontWidth), (_DesktopHeight - _FontWidth)), message$
_Display
End If
' Auto-cycle through functions (SIN, COS, TAN, etc.)
' after iFramesPerFunction% repetitions (# cycles for the given # seconds)
LastCode$ = "Auto-cycle through functions" ' Save code location for error handler
iFrameCount% = iFrameCount% + 1
If iFrameCount% > iFramesPerFunction% Then
iFrameCount% = 0
' Move to the next function that hasn't had an error
Do
arrWhich(0).Index = arrWhich(0).Index + 1
If arrWhich(0).Index > arrWhich(0).Max Then arrWhich(0).Index = arrWhich(0).Min
If arrWhich(0).Index > arrWhich(0).TriedMax Then arrWhich(0).TriedMax = arrWhich(0).Index ' highest index tried
If arrWhich(0).Index < arrWhich(0).TriedMin Then arrWhich(0).TriedMin = arrWhich(0).Index ' lowest index tried
If Len(arrFunction(arrWhich(0).Index, 0).ErrorMessage) = 0 Then Exit Do
Loop
ReInitPlasma
End If
LastCode$ = "mouse, ro, limit" ' Save code location for error handler
' If user moves mouse or presses Esc then quit
While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Or _KeyDown(27) Then bFinished = _TRUE: Exit While
' Count down to color change
ro = ro - 1
_Limit fps
Wend
If bFinished = _TRUE Then Exit While
Wend
' SHOW RESULTS
_FullScreen _Off
Screen _NewImage(1024, 768, 32)
_AutoDisplay
_ScreenMove 0, 0
Cls
' REPORT FINDINGS:
' ReDim Shared arrFunction(0 To 21, 0 To 1) As FunctionType
' ReDim Shared arrWhich(0 To 1) As IndexType ' index of current function select case checks for
' PRINT REPORT
message$ = ""
For iLoop% = LBound(arrWhich) To UBound(arrWhich)
iValue% = iValue% + 1
message$ = message$ + "Function set #" + _ToStr$(iValue%) + ":" + Chr$(13)
For iIndex% = LBound(arrFunction, 1) To UBound(arrFunction, 1)
If Len(arrFunction(iIndex%, iLoop%).Name) > 0 Then
' SHOW NEXT FUNCTION NAME
message$ = message$ + _ToStr$(iIndex%) + ". " + arrFunction(iIndex%, iLoop%).Name + Chr$(13)
' SHOW NEXT FUNCTION ERROR (IF ANY)
If Len(arrFunction(iIndex%, iLoop%).ErrorMessage) > 0 Then
message$ = message$ + String$(len(_ToStr$(iIndex%) + ". "), " ") + _
arrFunction(iIndex%, iLoop%).ErrorMessage + chr$(13)
End If
End If
Next iIndex%
message$ = message$ + Chr$(13)
Next iLoop%
ShowInstructions message$
System
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
' COUNT THE ERROR
ErrCount = ErrCount + 1
' SHOW THE CURRENT ERROR
LastError$ = "Error #" + _ToStr$(Err) + " at line " + _ToStr$(_ErrorLine) + "."
'WHERE IN THE PROGRAM WE WERE WHEN ERROR HAPPENED: LastCode$
'WHICH SET OF FUNCTIONS VALUE LAST CHANGED IN: LastChangedIndex = 0
' WHAT CHANGED BEFORE THE ERROR?
If LastChangedIndex >= LBound(arrWhich) And LastChangedIndex <= UBound(arrWhich) Then
' Log the error for the current function type
arrFunction(arrWhich(LastChangedIndex).Index, LastChangedIndex).ErrorMessage = LastError$
' Move to the next function that hasn't had an error
Do
arrWhich(LastChangedIndex).Index = arrWhich(LastChangedIndex).Index + 1
If arrWhich(LastChangedIndex).Index > arrWhich(LastChangedIndex).Max Then arrWhich(LastChangedIndex).Index = 0
If arrWhich(LastChangedIndex).Index > arrWhich(LastChangedIndex).TriedMax Then arrWhich(LastChangedIndex).TriedMax = arrWhich(LastChangedIndex).Index ' highest index tried
If arrWhich(LastChangedIndex).Index < arrWhich(LastChangedIndex).TriedMin Then arrWhich(LastChangedIndex).TriedMin = arrWhich(LastChangedIndex).Index ' lowest index tried
If Len(arrFunction(arrWhich(LastChangedIndex).Index, LastChangedIndex).ErrorMessage) = 0 Then Exit Do
Loop
End If
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ReInitPlasma
Dim iLoop%
resetPlasma
For iLoop% = -100 To diag + 1000
Do
LastError$ = ""
colr(iLoop%) = Plasma~&(arrWhich(0).Index)
If Len(LastError$) = 0 Then Exit Do
Loop
Next iLoop%
End Sub ' ReInitPlasma
' /////////////////////////////////////////////////////////////////////////////
Function Plasma~& (fn%)
LastCode$ = "Plasma~&" ' Save code location for error handler
cN = cN + .2
Select Case fn%:
Case 0:
FuncName$ = "SIN": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
Case 1:
FuncName$ = "COS": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Cos(pR * cN), 127 + 127 * Cos(pG * cN), 127 + 127 * Cos(pB * cN))
Case 2:
FuncName$ = "TAN": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Tan(pR * cN), 127 + 127 * Tan(pG * cN), 127 + 127 * Tan(pB * cN))
Case 3:
FuncName$ = "_COT": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Cot(pR * cN), 127 + 127 * _Cot(pG * cN), 127 + 127 * _Cot(pB * cN))
Case 4:
FuncName$ = "_CSC": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Csc(pR * cN), 127 + 127 * _Csc(pG * cN), 127 + 127 * _Csc(pB * cN))
Case 5:
FuncName$ = "_SEC": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sec(pR * cN), 127 + 127 * _Sec(pG * cN), 127 + 127 * _Sec(pB * cN))
' ****************************************************************************************************************************************************************
' THESE JUST PRODUCE WHITE ON WHITE OR BLACK ON BLACK:
Case 6:
FuncName$ = "_ARCSEC": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arcsec(pR * cN), 127 + 127 * _Arcsec(pG * cN), 127 + 127 * _Arcsec(pB * cN))
Case 7:
FuncName$ = "_COSH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Cosh(pR * cN), 127 + 127 * _Cosh(pG * cN), 127 + 127 * _Cosh(pB * cN))
Case 8:
FuncName$ = "_SINH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sinh(pR * cN), 127 + 127 * _Sinh(pG * cN), 127 + 127 * _Sinh(pB * cN))
Case 9:
FuncName$ = "_ACOS": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Acos(pR * cN), 127 + 127 * _Acos(pG * cN), 127 + 127 * _Acos(pB * cN))
Case 10:
FuncName$ = "_ACOSH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Acosh(pR * cN), 127 + 127 * _Acosh(pG * cN), 127 + 127 * _Acosh(pB * cN))
Case 11:
FuncName$ = "_ASIN": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Asin(pR * cN), 127 + 127 * _Asin(pG * cN), 127 + 127 * _Asin(pB * cN))
Case 12:
FuncName$ = "_ASINH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Asinh(pR * cN), 127 + 127 * _Asinh(pG * cN), 127 + 127 * _Asinh(pB * cN))
Case 13:
FuncName$ = "_ATANH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Atanh(pR * cN), 127 + 127 * _Atanh(pG * cN), 127 + 127 * _Atanh(pB * cN))
Case 14:
FuncName$ = "_TANH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Tanh(pR * cN), 127 + 127 * _Tanh(pG * cN), 127 + 127 * _Tanh(pB * cN))
Case 15:
FuncName$ = "ATN": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Atn(pR * cN), 127 + 127 * Atn(pG * cN), 127 + 127 * Atn(pB * cN))
Case 16:
FuncName$ = "_ARCCOT": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arccot(pR * cN), 127 + 127 * _Arccot(pG * cN), 127 + 127 * _Arccot(pB * cN))
Case 17:
FuncName$ = "_ARCCSC": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arccsc(pR * cN), 127 + 127 * _Arccsc(pG * cN), 127 + 127 * _Arccsc(pB * cN))
' ****************************************************************************************************************************************************************
' THESE CAUSE PROGRAM TO CRASH:
Case 18:
FuncName$ = "_COTH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Coth(pR * cN), 127 + 127 * _Coth(pG * cN), 127 + 127 * _Coth(pB * cN))
Case 19:
FuncName$ = "_CSCH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Csch(pR * cN), 127 + 127 * _Csch(pG * cN), 127 + 127 * _Csch(pB * cN))
Case 20:
FuncName$ = "_SECH": arrFunction(fn%, 0).Name = FuncName$: arrFunction(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sech(pR * cN), 127 + 127 * _Sech(pG * cN), 127 + 127 * _Sech(pB * cN))
Case Else:
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Select
End Function ' Plasma~&
' /////////////////////////////////////////////////////////////////////////////
' ORIGINAL:
Function Plasma1~& ()
cN = cN + .2
Plasma1~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function
' /////////////////////////////////////////////////////////////////////////////
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub
' /////////////////////////////////////////////////////////////////////////////
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
Sub ShowInstructions (in$)
'Dim in$: in$ = GetInstructions$
Dim iLoop As Integer
Dim iCount As Integer: iCount = 0
Dim iRows As Integer: iRows = _Height(0) \ _FontHeight ' GET # OF AVAILABLE TEXT ROWS
ReDim arrLines(-1) As String
Cls
split in$, Chr$(13), arrLines() ' SPLIT OUTPUT INTO LINES
For iLoop = LBound(arrLines) To UBound(arrLines)
' WHEN MAX LINES ARE DISPLAYED, PAUSE AND WAIT FOR USER TO PRESS <ENTER>
If arrLines(iLoop) <> Chr$(10) Then
Print arrLines(iLoop)
iCount = iCount + 1
If iCount > (iRows - 5) Then
Input "PRESS <ENTER> TO CONTINUE"; in$
iCount = 0
End If
Else
' Chr$(10) MEANS PAUSE, WAIT FOR USER, RESET LINE COUNTER
Input "PRESS <ENTER> TO CONTINUE"; in$
iCount = 0
End If
Next iLoop
Input "PRESS <ENTER> TO CONTINUE"; in$
End Sub ' ShowInstructions
' /////////////////////////////////////////////////////////////////////////////
' Geometry functions we tried with Plasma~&:
' PRODUCE COLORS:
' SIN (function) returns the sine of a radian angle.
' COS (function) returns the cosine of a radian angle value.
' TAN (function) returns the ratio of SINe to COSine or tangent value of an angle measured in radians.
' _COT (function) the mathematical function cotangent defined by 1/TAN.
' _CSC (function) the mathematical function cosecant defined by 1/SIN.
' _SEC (function) the mathematical function secant defined by 1/COS.
' JUST RESULTS IN WHITE ON WHITE OR BLACK ON BLACK:
' _ACOS (function) arccosine function returns the angle in radians based on an input COSine value range from -1 to 1.
' _COSH (function) Returns the hyperbolic cosine of x radians.
' _ACOSH (function) Returns the nonnegative arc hyperbolic cosine of x, expressed in radians.
' _ARCSEC (function) is the inverse function of the secant.
' _ARCCSC (function) is the inverse function of the cosecant.
' _SINH (function) Returns the hyperbolic sine of x radians.
' _ASIN (function) Returns the principal value of the arc sine of x, expressed in radians.
' _ASINH (function) Returns the arc hyperbolic sine of x, expressed in radians.
' ATN (function) or arctangent returns the angle in radians of a numerical tangent value.
' _TANH (function) Returns the hyperbolic tangent of x radians.
' _ATANH (function) Returns the arc hyperbolic tangent of x, expressed in radians.
' _ARCCOT (function) is the inverse function of the cotangent.
' CAUSE ERRORS:
' _COTH (function) Returns the hyperbolic cotangent.
' _CSCH (function) Returns the hyperbolic cosecant.
' _SECH (function) Returns the hyperbolic secant.
' OTHER GEOMETRY FUNCTIONS:
' _ATAN2 (function) Returns the principal value of the arc tangent of y/x, expressed in radians.
' _HYPOT (function) Returns the hypotenuse of a right-angled triangle whose legs are x and y.
' OTHER MATH FUNCTIONS:
' _D2R (function) converts degrees to radian angle values.
' _G2R (function) converts gradient to radian angle values.
' _R2D (function) converts radians to degree angle values.
' _R2G (function) converts radians to gradient angle values.
' _D2G (function) converts degrees to gradient angle values.
' _G2D (function) converts gradient to degree angle values.
' EXP (function) returns the value of e to the exponential power specified.
' LOG (function) returns the natural logarithm of a specified numerical value
' SGN (function) returns -1 for negative, 0 for zero, and 1 for positive numerical values.
' SQR (function) returns the square root of a non-negative number.
Posts: 1,215
Threads: 162
Joined: Apr 2022
Reputation:
34
04-18-2025, 07:55 PM
(This post was last modified: 04-18-2025, 08:00 PM by madscijr.)
Here's the latest, cleaned up, ready to compile & rename scr to make a screensaver.
See instructions for what the hotkeys do.
Code: (Select All) ' Eye Candy #9B by bplus, mod v1.54 by madscijr, steve
' 04-30-2022, 07:55 PM (This post was last modified: 04-30-2022, 08:19 PM by bplus.)
' https://qb64phoenix.com/forum/showthread.php?tid=219&pid=1291#pid1291
_Title "Eye Candy #9B Closer (fullscreen)(multi-function)"
' -----------------------------------------------------------------------------
' WHEN WHO WHAT
' ---------- -------- -----------------------------------------------------
' 2022-03-09 b+ created the program
' 2025-04-17 madscijr added Steve's mouse check (touch mouse to close, for screen saver)
' hotkey to try different functions for Plasma~& and for pset color
' (e.g., SIN, COS, TAN, _COT, _CSC, _SEC, SIN * 2, etc.)
' catch errors, log & avoid functions which errored out
' show report detailing which functions worked/failed
' 2025-04-17 Steve fullscreen mod
' 2025-04-18 madscijr v 1.54 automatically cycles through Plasma~& and pset color functions
' add hotkeys for debug mode, lengthen/shorten timers, debug mode
' hide all the debugging stuff by default (regular screensaver mode)
' hide report at end + values unless debug mode enabled
' -----------------------------------------------------------------------------
' INSTRUCTIONS:
' PG DOWN..................shorten time per function by 10 seconds
' PG UP....................lengthen time per function by 10 seconds
' HOME.....................reset time per function to default (30 seconds)
' MINUS....................decrease color change speed
' PLUS ....................increase color change speed
' END......................reset color change speed
' LEFT/RIGHT...............next/previous function #1 (Plasma)
' UP /DOWN ...............next/previous function #2 (Pset)
' SPACE....................show/hide values
' D........................enable/disable debug mode & error report
' ESC OR MOVE MOUSE........quit
' (any other key)..........restart cycle/new colors
' -----------------------------------------------------------------------------
Option _Explicit
DefDbl A-Z
Const fps = 80
Const cSecondsPerFunction = 30 ' default # seconds before next function cycles
Const cIgnoreErrors = _TRUE ' if _TRUE, and a function fails, program will try it again later
' KEY CODES FOR _BUTTON
Const KeyCode_Escape = 2
Const KeyCode_Spacebar = 58
Const KeyCode_Enter = 29
Const KeyCode_Up = 329
Const KeyCode_Down = 337
Const KeyCode_Left = 332
Const KeyCode_Right = 334
Const KeyCode_Minus = 13
Const KeyCode_Equal = 14
Const KeyCode_Home = 328
Const KeyCode_End = 336
Const KeyCode_PgUp = 330
Const KeyCode_PgDn = 338
Const KeyCode_KeypadMinus = 75
Const KeyCode_KeypadPlus = 79
Const KeyCode_Keypad7Home = 72
Const KeyCode_Keypad1End = 80
Const KeyCode_Keypad3PgDn = 82
Const KeyCode_Keypad9PgUp = 74
Const KeyCode_A = 31
Const KeyCode_B = 49
Const KeyCode_C = 47
Const KeyCode_D = 33
Const KeyCode_1 = 3
Const KeyCode_2 = 4
Type FunctionType
Name As String ' description of the code to try
ErrorMessage As String ' if code has failed contains error message
End Type
Type IndexType
Name As String ' description of current function
Index As Integer ' index of current function
Min As Integer ' minimum index of code array to try
Max As Integer ' maximum index of code array to try
TriedMin As Integer ' lowest index tried
TriedMax As Integer ' highest index tried
'TODO:
'' for timing how long before we switch functions:
'FrameCount As Integer ' counts frames
'FrameMax As Integer ' # frames before next function cycles
End Type
' shared vars for selecting/tracking different functions & errors
ReDim Shared arrFn(0 To 50, 0 To 1) As FunctionType ' where arrFn( {fn number}, {0=Plasma, 1=pset} )
ReDim Shared arrIx(0 To 1) As IndexType ' index of current function select case checks for where arrIx{0} = plasma, arrIx{1} = pset
Dim Shared ErrCount As Integer: ErrCount = 0 ' increments each time error handler fires
' shared vars for drawing
ReDim Shared colr(0 To 0) As _Unsigned Long
Dim Shared cN, pR, pG, pB
Dim Shared diag As Single
' local vars for drawing
Dim xmax, ymax As Integer
Dim p2 As Single
Dim xc, yc As Single
Dim a As Single
Dim r As Single
Dim sx1, sy1, sx2, sy2, sx3, sy3, dx1, dy1, dx2, dy2, dx3, dy3 As Long
Dim toggle As Integer: toggle = 0
Dim source&: source& = 0
Dim ro As Single ' color change seed
Dim rc As Single: rc = 1 ' color change speed
Dim s As Single
Dim iTo#, iStep# ' for calculations
Dim iValue% ' for calculations
Dim fn% ' current function # (index)
'Dim InstColor~&: InstColor~& = _RGB32(0, 0, 0)
' for timing how long before we switch functions
Dim iFrameCount% ' counts frames
Dim iFramesPerFunction% ' # frames before next function cycles
Dim iPitch% ' to beep when function changes
' local vars for selecting different functions/options
Dim k$, LastKey$: LastKey$ = "" ' for reading keys with inkey$
Dim iLastKeyCode%: iLastKeyCode% = 0 ' for reading keys with _BUTTON
Dim bShowText%: bShowText% = _FALSE ' show text mode on/off toggled by user pressing SPACE
Dim bDebugMode%: bDebugMode% = _FALSE ' debug mode on/off toggled by user pressing D
Dim iLoop%, iIndex% ' for report at end
Dim message$ ' for printing text on screen
Dim MaxCols%, MaxRows% ' for printing text on screen
Dim ColNum, RowNum, FirstRow, iLen As Integer ' for printing text on screen
Dim debug$: debug$ = "" ' for debug messages
' For flow control / exiting program
Dim OldMouseX, OldMouseY As Integer ' for detecting mouse
Dim bFinished As Integer: bFinished = _FALSE
' For error trapping
Dim Shared LastCode$ ' where in the code we are
Dim Shared LastChangedIndex As Integer ' which set of functions we changed
Dim Shared LastError$: LastError$ = ""
' SET ERROR TRAPPING
LastCode$ = ""
LastChangedIndex = -1
LastError$ = ""
On Error GoTo ErrorHandler
' INITIALIZE
iFramesPerFunction% = cSecondsPerFunction * fps
xmax = _DesktopWidth
ymax = _DesktopHeight
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
_Display
_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement
' for printing text
MaxCols% = (xmax / _FontWidth)
MaxRows% = (ymax / _FontHeight)
FirstRow = (MaxRows% / 2) - 2
' Center:
xc = xmax / 2
yc = ymax / 2
diag = Sqr(xc * xc + yc * yc)
ReDim colr(-100 To diag + 1000) As _Unsigned Long
p2 = _Pi * 2
fn% = 0
arrIx(fn%).Min = 0 ' min value select case checks for in Function Plasma~&
arrIx(fn%).Max = 5 ' max value select case checks for in Function Plasma~&
arrIx(fn%).Index = arrIx(fn%).Min ' pointer to current function used for Plasma&
arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
fn% = 1
arrIx(fn%).Min = LBound(arrFn, 1) ' min value select case checks for, for pset color
arrIx(fn%).Max = 42 ' max value select case checsk for, for pset color
arrIx(fn%).Index = arrIx(fn%).Min ' pointer for current function used for pset color
arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
iFrameCount% = 0
Randomize Timer
_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement
While 1
LastCode$ = "ReInitPlasma" ' Save code location for error handler
ReInitPlasma
ro = 950
s = 0
While ro > -50
' PROCESS KEYBOARD INPUT
LastCode$ = "KEYBOARD" ' Save code location for error handler
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape) Then
' ESC = QUIT
iLastKeyCode% = KeyCode_Escape
bFinished = _TRUE: Exit While
ElseIf _Button(KeyCode_Up) Then
' TRY NEXT FUNCTION #1
If iLastKeyCode% <> KeyCode_Up Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Up: LastKey$ = ""
' TODO: move this block into a subroutine, since it's repeated like 8x
' Move to the next function that hasn't had an error
Do
fn% = 0
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 0
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Down) Then
' TRY PREVIOUS FUNCTION #1
If iLastKeyCode% <> KeyCode_Down Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Down: LastKey$ = ""
' Move to the next function that hasn't had an error
Do
fn% = 0
arrIx(fn%).Index = arrIx(fn%).Index - 1
If arrIx(fn%).Index < arrIx(fn%).Min Then arrIx(fn%).Index = arrIx(fn%).Max
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 0
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Right) Then
' TRY NEXT FUNCTION #2
If iLastKeyCode% <> KeyCode_Right Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Right: LastKey$ = ""
' Move to the next function that hasn't had an error
Do
fn% = 1
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 1
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Left) Then
' TRY PREVIOUS FUNCTION #2
If iLastKeyCode% <> KeyCode_Left Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Left: LastKey$ = ""
' Move to the next function that hasn't had an error
Do
fn% = 1
arrIx(fn%).Index = arrIx(fn%).Index - 1
If arrIx(fn%).Index < arrIx(fn%).Min Then arrIx(fn%).Index = arrIx(fn%).Max
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' Remember this was the last parameter user changed
LastChangedIndex = 1
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_Spacebar) Then
' SPACE = TOGGLE DISPLAY TEXT
If iLastKeyCode% <> KeyCode_Spacebar Then
bShowText% = Not (bShowText%)
iLastKeyCode% = KeyCode_Spacebar: LastKey$ = ""
End If
ElseIf _Button(KeyCode_PgDn) Or _Button(KeyCode_Keypad3PgDn) Then
' PAGE DOWN = SHORTEN TIME BY 10 SECONDS
If iLastKeyCode% <> KeyCode_Minus Then
iFramesPerFunction% = iFramesPerFunction% - (fps * 10)
If iFramesPerFunction% < fps Then iFramesPerFunction% = fps ' Minimum time 1 second!
iLastKeyCode% = KeyCode_Minus: LastKey$ = ""
End If
ElseIf _Button(KeyCode_PgUp) Or _Button(KeyCode_Keypad9PgUp) Then
' PAGE UP = LENGTHEN TIME BY 10 SECONDS
If iLastKeyCode% <> KeyCode_Equal Then
iFramesPerFunction% = iFramesPerFunction% + (fps * 10)
iLastKeyCode% = KeyCode_Equal: LastKey$ = ""
End If
ElseIf _Button(KeyCode_Home) Or _Button(KeyCode_Keypad7Home) Then
' HOME = RESET TIME TO DEFAULT SECONDS
If iLastKeyCode% <> KeyCode_Home Then
iFramesPerFunction% = cSecondsPerFunction * fps
iLastKeyCode% = KeyCode_Home: LastKey$ = ""
End If
ElseIf _Button(KeyCode_Minus) Or _Button(KeyCode_KeypadMinus) Then
' MINUS = DECREASE COLOR CHANGE
If iLastKeyCode% <> KeyCode_Minus Then
rc = rc - .25: If rc < .25 Then rc = .25
iLastKeyCode% = KeyCode_Minus: LastKey$ = ""
End If
ElseIf _Button(KeyCode_Equal) Or _Button(KeyCode_KeypadPlus) Then
' PLUS = INCREASE COLOR CHANGE
If iLastKeyCode% <> KeyCode_Equal Then
rc = rc + .25: If rc > 10 Then rc = 10
iLastKeyCode% = KeyCode_Equal: LastKey$ = ""
End If
ElseIf _Button(KeyCode_End) Or _Button(KeyCode_Keypad1End) Then
' HOME = RESET COLOR CHANGE SPEED
If iLastKeyCode% <> KeyCode_End Then
rc = 1
iLastKeyCode% = KeyCode_End: LastKey$ = ""
End If
ElseIf _Button(KeyCode_D) Then
' D = TOGGLE DEBUG MODE
If iLastKeyCode% <> KeyCode_D Then
bDebugMode% = Not (bDebugMode%)
iLastKeyCode% = KeyCode_D: LastKey$ = ""
End If
ElseIf _Button(KeyCode_1) Then
If iLastKeyCode% <> KeyCode_1 Then
iLastKeyCode% = KeyCode_1: LastKey$ = ""
' Toggle error status
fn% = 0
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Then
' Mark current func #1 as "rejected"
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = "(rejected by user)"
Sound 200, .75
Else
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
Sound 800, .75
End If
' Move to the next function that hasn't had an error
Do
fn% = 0
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' Update values
ReInitPlasma
' restart cycle
Exit While
End If
ElseIf _Button(KeyCode_2) Then
If iLastKeyCode% <> KeyCode_2 Then
iLastKeyCode% = KeyCode_2: LastKey$ = ""
' Toggle error status
fn% = 1
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Then
' Mark current func #2 as "rejected"
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = "(rejected by user)"
Sound 200, .75
Else
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
Sound 800, .75
End If
' Move to the next function that hasn't had an error
Do
fn% = 1
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
' restart cycle
Exit While
End If
Else
' Clear last keycode pressed (since it wasn't any of those)
iLastKeyCode% = 0
' -----------------------------------------------------------------------------
' SEE IF ANY OTHER KEYS WERE PRESSED USING InKey$
' -----------------------------------------------------------------------------
k$ = InKey$: _KeyClear
If Len(k$) Then
' Remember last InKey$ pressed
LastKey$ = k$
' ANY OTHER KEY = CHANGE COLORS
Exit While
Else
' Clear last key pressed
LastKey$ = ""
End If
End If
_KeyClear ' CLEAR KEYBOARD BUFFER
' Tie dye!
LastCode$ = "Tie dye!" ' Save code location for error handler
Cls
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
iTo# = p2 / 64
iStep# = p2 / (16 * 360)
' TRY UNTIL WE FIND A FUNCTION #2 THAT WORKS
Do
LastError$ = ""
fn% = 1
LastCode$ = "For a = 0 To ..." ' Save code location for error handler
'For a = 0 To p2 / 64 Step p2 / (16 * 360)
For a = 0 To iTo# Step iStep#
LastCode$ = "Select Case arrIx(1).Index: (Set iValue%)" ' Save code location for error handler
Select Case arrIx(fn%).Index:
Case 0:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s)"
iValue% = 50 * Sin(s) ' 2 * s or just s
Case 1:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s * 2)"
iValue% = 50 * Sin(s * 2) ' 2 * s or just s
Case 2:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s * 3)"
iValue% = 50 * Sin(s * 3)
Case 3:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s * 4)"
iValue% = 50 * Sin(s * 4)
Case 4:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s * 5)"
iValue% = 50 * Sin(s * 5)
Case 5:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Cos(s * 1)"
iValue% = 50 * Cos(s * 1)
Case 6:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Cos(s * 2)"
iValue% = 50 * Cos(s * 2)
Case 7:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Cos(s * 3)"
iValue% = 50 * Cos(s * 3)
Case 8:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Cos(s * 4)"
iValue% = 50 * Cos(s * 4)
Case 9:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 25 * Cos(s * 5)"
iValue% = 25 * Cos(s * 5)
Case 10:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * Tan(s * 1)"
iValue% = 1 * Tan(s * 1)
Case 11:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * Tan(s * 2)"
iValue% = 1 * Tan(s * 2)
Case 12:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Sec(s * 2)"
iValue% = 1 * _Sec(s * 2)
Case 13:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acos(s * 1)"
iValue% = 1 * _Acos(s * 1)
Case 14:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acos(s * 2)"
iValue% = 1 * _Acos(s * 2)
Case 15:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acos(s * 3)"
iValue% = 1 * _Acos(s * 3)
Case 16:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acos(s * 4)"
iValue% = 1 * _Acos(s * 4)
Case 17:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acos(s * 5)"
iValue% = 1 * _Acos(s * 5)
Case 18:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Acosh(s * 2)"
iValue% = 1 * _Acosh(s * 2)
Case 19:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Asin(s * 2)"
iValue% = 1 * _Asin(s * 2)
Case 20:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Asinh(s * 2)"
iValue% = 1 * _Asinh(s * 2)
Case 21:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * Atn(s * 2)"
iValue% = 1 * Atn(s * 2)
Case 22:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Tanh(s * 2)"
iValue% = 1 * _Tanh(s * 2)
Case 23:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Atanh(s * 1)"
iValue% = 1 * _Atanh(s * 1)
Case 24:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Atanh(s * 4)"
iValue% = 1 * _Atanh(s * 4)
Case 25:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Arccot(s * 1)"
iValue% = 1 * _Arccot(s * 1)
Case 26:
' STARTED GOING BACKWARDS! BUT CRASHED!
' HOW CAN WE KEEP THESE GOING SO IT SUCKS EVERYTHING IN LIKE A BLACK HOLE?
' THAT WOULD LOOK REALLY COOL! :-D
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .009) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .009)
Case 27:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .008) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .008)
Case 28:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .007) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .007)
Case 29:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .006) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .006)
Case 30:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .005) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .005)
Case 31:
' STARTED GOING BACKWARDS! BUT CRASHED!
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .002) <- GOES BACKWARDS THEN CRASHES"
iValue% = 1 * _Coth(s * .002)
Case 32:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Coth(s * .001)"
iValue% = 1 * _Coth(s * .001)
Case 33:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Sech(s * .001)"
iValue% = 1 * _Sech(s * .001)
Case 34:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Sech(s * .005)"
iValue% = 1 * _Sech(s * .005)
Case 35:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Sech(s * .05)"
iValue% = 1 * _Sech(s * .05)
Case 36:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 1 * _Sech(s * .1)"
iValue% = 1 * _Sech(s * .1)
Case 37:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (s / 50) * 25"
iValue% = (s / 50) * 25
Case 38:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (s / 500) * 25"
iValue% = (s / 500) * 25
Case 39:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (s / 500) * p2 ^ .25"
iValue% = (s / 500) * p2 ^ .25
Case 40:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (s / 500) * p2 ^ (a * .25)"
iValue% = (s / 500) * p2 ^ (a * .25)
Case 41:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (s / 500) * p2 ^ a"
iValue% = (s / 500) * p2 ^ a
Case 42:
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = (a / 50000) * s ^ (p2 * .25)"
iValue% = (a / 50000) * s ^ (p2 * .25)
Case Else:
arrIx(fn%).Index = 0
arrFn(arrIx(fn%).Index, fn%).ErrorMessage = ""
arrFn(arrIx(fn%).Index, fn%).Name = "iValue% = 50 * Sin(s)"
iValue% = 50 * Sin(s) ' 2 * s or just s
End Select
' DID IT FAIL?
If Len(LastError$) = 0 Then
' WE MADE IT PAST THE FUNCTION SELECTION
LastCode$ = "For r = 0 To diag"
For r = 0 To diag
LastCode$ = "PSet" ' Save code location for error handler
PSet (xc + r * Cos(a), yc + r * Sin(a)), colr(r + iValue% + ro)
' DID IT FAIL?
If Len(LastError$) > 0 Then Exit For
Next r
End If
' DID IT FAIL?
If Len(LastError$) = 0 Then
LastCode$ = "s = s + p2 / 180" ' Save code location for error handler
s = s + p2 / 180
End If
' DID IT FAIL?
If Len(LastError$) > 0 Then Exit For
Next a
' IT DIDN'T FAIL, WE CAN EXIT
If Len(LastError$) = 0 Then
Exit Do
Else
' Move to the next function that hasn't had an error
Do
fn% = 1
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
End If
Loop
' MAP TRIANGLES SECTION
LastCode$ = "MAP TRIANGLES SECTION" ' Save code location for error handler
sx1 = xc
sy1 = yc
sx2 = xc + diag * Cos(.002)
sy2 = yc + diag * Sin(.002)
sx3 = xc + diag * Cos(p2 / 64 - .002)
sy3 = yc + diag * Sin(p2 / 64 - .002)
For a = p2 / 64 To p2 - p2 / 64 Step p2 / 64
dx1 = xc
dy1 = yc
dx2 = xc + diag * Cos(a)
dy2 = yc + diag * Sin(a)
dx3 = xc + diag * Cos(a + p2 / 64)
dy3 = yc + diag * Sin(a + p2 / 64)
_MapTriangle (sx1, sy1)-(sx2, sy2)-(sx3, sy3), source& To(dx1, dy1)-(dx2, dy2)-(dx3, dy3), 0
Next a
'Line (0, 0)-(xc - 1.5 * yc, _Height), &HFF000000, BF
'Line (xc + 1.5 * yc, 0)-(_Width, _Height), &HFF000000, BF
' COPY IMAGE TO SCREEN
LastCode$ = "_PutImage" ' Save code location for error handler
_PutImage (0, 0)-(_Width, _Height), , , (xc - 1.5 * yc, 0)-(xc + 1.5 * yc, _Height)
' SHOW THE CURRENT GEOMETRY FUNCTIONS BEING USED + VALUES FOR DEBUGGING
If bShowText% = _TRUE Then
LastCode$ = "If bShowText% = _TRUE Then" ' Save code location for error handler
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
' -----------------------------------------------------------------------------
' SHOW INSTRUCTIONS
' -----------------------------------------------------------------------------
RowNum = 0: ColNum = 1
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "INSTRUCTIONS:";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "PG DOWN..................shorten time per function by 10 seconds";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "PG UP....................lengthen time per function by 10 seconds";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "HOME.....................reset time per function to default (30 seconds)";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "MINUS....................decrease color change speed";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "PLUS ....................increase color change speed";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "END......................reset color change speed";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "LEFT/RIGHT...............next/previous function #1 (plasma)";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "UP /DOWN ...............next/previous function #2 (pset)";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "SPACE....................show/hide function names/values";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "D........................enable/disable debug mode & error report";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "ESC OR MOVE MOUSE........quit";
RowNum = RowNum + 1: Locate RowNum, ColNum: Print "(any other key)..........restart cycle/new colors";
' -----------------------------------------------------------------------------
' SHOW NORMAL SETTINGS
' -----------------------------------------------------------------------------
' SHOW LENGTH PER FUNCTION
message$ = "Time per function=" + Right$(String$(3, " ") + _ToStr$(iFramesPerFunction% / fps), 3)
RowNum = FirstRow
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW COLOR SEED ro
message$ = "Color seed =" + Right$(String$(6, " ") + FormatSingle2$(ro, 2), 6)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW COLOR SPEED rc
message$ = "Color speed =" + Right$(String$(6, " ") + FormatSingle2$(rc, 2), 6)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' -----------------------------------------------------------------------------
' BEGIN SHOW DEBUG MODE INFO
' -----------------------------------------------------------------------------
If bDebugMode% Then
fn% = 0
message$ = "Function #1:" + _
" CURRENT: " + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).Index), 3) + _
", " + _
"tried: (" + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).TriedMin), 3) + _
"-" + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).TriedMax), 3) + _
")" + _
" " + _
"total: (" + _
right$( string$(3, " ") + _ToStr$(lbound(arrFn,1)), 3) + _
"-" + _
right$( string$(3, " ") + _ToStr$(ubound(arrFn,1)), 3) + _
")" + _
" = " + _
arrFn(arrIx(fn%).Index, fn%).Name + _
""
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
'iLen = len(message$)
fn% = 1
message$ = "Function #2:" + _
" CURRENT: " + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).Index), 3) + _
", " + _
"tried: (" + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).TriedMin), 3) + _
"-" + _
right$( string$(3, " ") + _ToStr$(arrIx(fn%).TriedMax), 3) + _
")" + _
" " + _
"total: (" + _
right$( string$(3, " ") + _ToStr$(lbound(arrFn,1)), 3) + _
"-" + _
right$( string$(3, " ") + _ToStr$(ubound(arrFn,1)), 3) + _
")" + _
" = " + _
arrFn(arrIx(fn%).Index, fn%).Name + _
""
RowNum = RowNum + 1
'ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW iValue%
message$ = "iValue%=" + _ToStr$(iValue%)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW error count
message$ = "ErrCount=" + _ToStr$(ErrCount)
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
' SHOW debug message
message$ = "DEBUG"
If Len(debug$) > 0 Then message$ = message$ + ": " + debug$
RowNum = RowNum + 1
ColNum = (MaxCols% / 2) - (Len(message$) / 2)
Locate RowNum, ColNum
Print message$;
End If
' -----------------------------------------------------------------------------
' BEGIN SHOW DEBUG MODE INFO
' -----------------------------------------------------------------------------
End If
LastCode$ = "toggle" ' Save code location for error handler
toggle = 1 - toggle
If toggle Then
'_Dest 0
'message$ = "TOP LEFT": _PrintString (0, 0), message$
'message$ = "TOP RIGHT": _PrintString (_DesktopWidth - (Len(message$) * _FontWidth), 0), message$
'message$ = "BOTTOM LEFT": _PrintString (0, (_DesktopHeight - _FontWidth)), message$
'message$ = "BOTTOM RIGHT": _PrintString (_DesktopWidth - (Len(message$) * _FontWidth), (_DesktopHeight - _FontWidth)), message$
_Display
End If
' Auto-cycle through functions (SIN, COS, TAN, etc.)
' after iFramesPerFunction% repetitions (# cycles for the given # seconds)
LastCode$ = "Auto-cycle through functions" ' Save code location for error handler
iFrameCount% = iFrameCount% + 1
If iFrameCount% > iFramesPerFunction% Then
iFrameCount% = 0
' Cycle function #2 (pset color)
' Move to the next function #2 that hasn't had an error
iPitch% = 800
Do
fn% = 1
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min: iPitch% = 400 ' function #2 rolled over, so cycle function #1
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
If iPitch% = 400 Then
' Move to the next function #1 that hasn't had an error
Do
fn% = 0
arrIx(fn%).Index = arrIx(fn%).Index + 1
If arrIx(fn%).Index > arrIx(fn%).Max Then arrIx(fn%).Index = arrIx(fn%).Min
If arrIx(fn%).Index > arrIx(fn%).TriedMax Then arrIx(fn%).TriedMax = arrIx(fn%).Index ' highest index tried
If arrIx(fn%).Index < arrIx(fn%).TriedMin Then arrIx(fn%).TriedMin = arrIx(fn%).Index ' lowest index tried
If Len(arrFn(arrIx(fn%).Index, fn%).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
End If
'If bShowText% = _TRUE Then Sound iPitch%, .75
If bDebugMode% = _TRUE Then Sound iPitch%, .75
' Reset colors
ro = 950
' Reset
ReInitPlasma
End If
LastCode$ = "mouse, ro, limit" ' Save code location for error handler
' If user moves mouse or presses Esc then quit
While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Or _KeyDown(27) Then bFinished = _TRUE: Exit While
' Update color seed value
ro = ro - rc
_Limit fps
Wend
If bFinished = _TRUE Then Exit While
Wend
' SHOW RESULTS IF DEBUG MODE IS ON
If bDebugMode% = _TRUE Then
' REPORT FINDINGS FROM:
' ReDim Shared arrFn(0 To 21, 0 To 1) As FunctionType
' ReDim Shared arrIx(0 To 1) As IndexType ' index of current function select case checks for
' CHANGE TO PLAIN TEXT SCREEN
_FullScreen _Off
Screen _NewImage(1024, 768, 32)
_AutoDisplay
_ScreenMove 0, 0
' GENERATE REPORT
Cls
message$ = ""
For iLoop% = LBound(arrIx) To UBound(arrIx)
iValue% = iValue% + 1
message$ = message$ + "Function set #" + _ToStr$(iValue%) + ":" + Chr$(13)
For iIndex% = LBound(arrFn, 1) To UBound(arrFn, 1)
If Len(arrFn(iIndex%, iLoop%).Name) > 0 Then
' SHOW NEXT FUNCTION NAME
message$ = message$ + _ToStr$(iIndex%) + ". " + arrFn(iIndex%, iLoop%).Name + Chr$(13)
' SHOW NEXT FUNCTION ERROR (IF ANY)
If Len(arrFn(iIndex%, iLoop%).ErrorMessage) > 0 Then
message$ = message$ + String$(len(_ToStr$(iIndex%) + ". "), " ") + _
arrFn(iIndex%, iLoop%).ErrorMessage + chr$(13)
End If
End If
Next iIndex%
message$ = message$ + Chr$(13)
Next iLoop%
' SHOW PAGED REPORT
ShowInstructions message$
End If
' EXIT
System
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
' COUNT THE ERROR
ErrCount = ErrCount + 1
' SHOW THE CURRENT ERROR
LastError$ = "Error #" + _ToStr$(Err) + " at line " + _ToStr$(_ErrorLine) + "."
'WHERE IN THE PROGRAM WE WERE WHEN ERROR HAPPENED: LastCode$
'WHICH SET OF FUNCTIONS VALUE LAST CHANGED IN: LastChangedIndex = 0
' WHAT CHANGED BEFORE THE ERROR?
If LastChangedIndex >= LBound(arrIx) And LastChangedIndex <= UBound(arrIx) Then
' Log the error for the current function type
arrFn(arrIx(LastChangedIndex).Index, LastChangedIndex).ErrorMessage = LastError$
' Move to the next function that hasn't had an error
Do
fn% = LastChangedIndex
arrIx(LastChangedIndex).Index = arrIx(LastChangedIndex).Index + 1
If arrIx(LastChangedIndex).Index > arrIx(LastChangedIndex).Max Then arrIx(LastChangedIndex).Index = 0
If arrIx(LastChangedIndex).Index > arrIx(LastChangedIndex).TriedMax Then arrIx(LastChangedIndex).TriedMax = arrIx(LastChangedIndex).Index ' highest index tried
If arrIx(LastChangedIndex).Index < arrIx(LastChangedIndex).TriedMin Then arrIx(LastChangedIndex).TriedMin = arrIx(LastChangedIndex).Index ' lowest index tried
If Len(arrFn(arrIx(LastChangedIndex).Index, LastChangedIndex).ErrorMessage) = 0 Or cIgnoreErrors = _TRUE Then Exit Do
Loop
End If
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ReInitPlasma
Dim iIndex%
Dim fn%
fn% = 0
resetPlasma
For iIndex% = -100 To diag + 1000
Do
LastError$ = ""
colr(iIndex%) = Plasma~&(arrIx(fn%).Index)
If Len(LastError$) = 0 Then Exit Do
Loop
Next iIndex%
End Sub ' ReInitPlasma
' /////////////////////////////////////////////////////////////////////////////
Function Plasma~& (fn%)
Dim FuncName$
LastCode$ = "Plasma~&" ' Save code location for error handler
cN = cN + .2
Select Case fn%:
Case 0:
FuncName$ = "SIN": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
Case 1:
FuncName$ = "COS": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Cos(pR * cN), 127 + 127 * Cos(pG * cN), 127 + 127 * Cos(pB * cN))
Case 2:
FuncName$ = "TAN": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Tan(pR * cN), 127 + 127 * Tan(pG * cN), 127 + 127 * Tan(pB * cN))
Case 3:
FuncName$ = "_COT": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Cot(pR * cN), 127 + 127 * _Cot(pG * cN), 127 + 127 * _Cot(pB * cN))
Case 4:
FuncName$ = "_CSC": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Csc(pR * cN), 127 + 127 * _Csc(pG * cN), 127 + 127 * _Csc(pB * cN))
Case 5:
FuncName$ = "_SEC": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sec(pR * cN), 127 + 127 * _Sec(pG * cN), 127 + 127 * _Sec(pB * cN))
' ****************************************************************************************************************************************************************
' THESE JUST PRODUCE WHITE ON WHITE OR BLACK ON BLACK:
Case 6:
FuncName$ = "_ARCSEC": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arcsec(pR * cN), 127 + 127 * _Arcsec(pG * cN), 127 + 127 * _Arcsec(pB * cN))
Case 7:
FuncName$ = "_COSH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Cosh(pR * cN), 127 + 127 * _Cosh(pG * cN), 127 + 127 * _Cosh(pB * cN))
Case 8:
FuncName$ = "_SINH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sinh(pR * cN), 127 + 127 * _Sinh(pG * cN), 127 + 127 * _Sinh(pB * cN))
Case 9:
FuncName$ = "_ACOS": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Acos(pR * cN), 127 + 127 * _Acos(pG * cN), 127 + 127 * _Acos(pB * cN))
Case 10:
FuncName$ = "_ACOSH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Acosh(pR * cN), 127 + 127 * _Acosh(pG * cN), 127 + 127 * _Acosh(pB * cN))
Case 11:
FuncName$ = "_ASIN": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Asin(pR * cN), 127 + 127 * _Asin(pG * cN), 127 + 127 * _Asin(pB * cN))
Case 12:
FuncName$ = "_ASINH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Asinh(pR * cN), 127 + 127 * _Asinh(pG * cN), 127 + 127 * _Asinh(pB * cN))
Case 13:
FuncName$ = "_ATANH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Atanh(pR * cN), 127 + 127 * _Atanh(pG * cN), 127 + 127 * _Atanh(pB * cN))
Case 14:
FuncName$ = "_TANH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Tanh(pR * cN), 127 + 127 * _Tanh(pG * cN), 127 + 127 * _Tanh(pB * cN))
Case 15:
FuncName$ = "ATN": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * Atn(pR * cN), 127 + 127 * Atn(pG * cN), 127 + 127 * Atn(pB * cN))
Case 16:
FuncName$ = "_ARCCOT": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arccot(pR * cN), 127 + 127 * _Arccot(pG * cN), 127 + 127 * _Arccot(pB * cN))
Case 17:
FuncName$ = "_ARCCSC": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Arccsc(pR * cN), 127 + 127 * _Arccsc(pG * cN), 127 + 127 * _Arccsc(pB * cN))
' ****************************************************************************************************************************************************************
' THESE CAUSE PROGRAM TO CRASH:
Case 18:
FuncName$ = "_COTH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Coth(pR * cN), 127 + 127 * _Coth(pG * cN), 127 + 127 * _Coth(pB * cN))
Case 19:
FuncName$ = "_CSCH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Csch(pR * cN), 127 + 127 * _Csch(pG * cN), 127 + 127 * _Csch(pB * cN))
Case 20:
FuncName$ = "_SECH": arrFn(fn%, 0).Name = FuncName$: arrFn(fn%, 0).ErrorMessage = ""
Plasma~& = _RGB32(127 + 127 * _Sech(pR * cN), 127 + 127 * _Sech(pG * cN), 127 + 127 * _Sech(pB * cN))
Case Else:
Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Select
End Function ' Plasma~&
' /////////////////////////////////////////////////////////////////////////////
' ORIGINAL:
Function Plasma1~& ()
cN = cN + .2
Plasma1~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function
' /////////////////////////////////////////////////////////////////////////////
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub
' /////////////////////////////////////////////////////////////////////////////
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
Function FormatSingle2$ (sngVal As Single, iPlaces As Integer)
Dim sResult$, sVal$: Dim iPos%
sVal$ = _ToStr$(sngVal)
iPos% = InStr(1, sVal$, ".")
If iPos% = 0 Then
sResult$ = sVal$
If iPlaces > 0 Then sResult$ = sResult$ + "." + String$(iPlaces, "0")
Else
sResult$ = Left$(sVal$, iPos% - 1)
If iPlaces > 0 Then sResult$ = sResult$ + "." + Left$(Mid$(sVal$, iPos% + 1, iPlaces) + String$(iPlaces, "0"), iPlaces)
End If
FormatSingle2$ = sResult$
End Function ' FormatSingle2$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
Sub ShowInstructions (in$)
'Dim in$: in$ = GetInstructions$
Dim iLoop As Integer
Dim iCount As Integer: iCount = 0
Dim iRows As Integer: iRows = _Height(0) \ _FontHeight ' GET # OF AVAILABLE TEXT ROWS
ReDim arrLines(-1) As String
Cls
split in$, Chr$(13), arrLines() ' SPLIT OUTPUT INTO LINES
For iLoop = LBound(arrLines) To UBound(arrLines)
' WHEN MAX LINES ARE DISPLAYED, PAUSE AND WAIT FOR USER TO PRESS <ENTER>
If arrLines(iLoop) <> Chr$(10) Then
Print arrLines(iLoop)
iCount = iCount + 1
If iCount > (iRows - 5) Then
Input "PRESS <ENTER> TO CONTINUE"; in$
iCount = 0
End If
Else
' Chr$(10) MEANS PAUSE, WAIT FOR USER, RESET LINE COUNTER
Input "PRESS <ENTER> TO CONTINUE"; in$
iCount = 0
End If
Next iLoop
Input "PRESS <ENTER> TO CONTINUE"; in$
End Sub ' ShowInstructions
' /////////////////////////////////////////////////////////////////////////////
' Geometry functions we tried with Plasma~&:
' PRODUCE COLORS:
' SIN (function) returns the sine of a radian angle.
' COS (function) returns the cosine of a radian angle value.
' TAN (function) returns the ratio of SINe to COSine or tangent value of an angle measured in radians.
' _COT (function) the mathematical function cotangent defined by 1/TAN.
' _CSC (function) the mathematical function cosecant defined by 1/SIN.
' _SEC (function) the mathematical function secant defined by 1/COS.
' JUST RESULTS IN WHITE ON WHITE OR BLACK ON BLACK:
' _ACOS (function) arccosine function returns the angle in radians based on an input COSine value range from -1 to 1.
' _COSH (function) Returns the hyperbolic cosine of x radians.
' _ACOSH (function) Returns the nonnegative arc hyperbolic cosine of x, expressed in radians.
' _ARCSEC (function) is the inverse function of the secant.
' _ARCCSC (function) is the inverse function of the cosecant.
' _SINH (function) Returns the hyperbolic sine of x radians.
' _ASIN (function) Returns the principal value of the arc sine of x, expressed in radians.
' _ASINH (function) Returns the arc hyperbolic sine of x, expressed in radians.
' ATN (function) or arctangent returns the angle in radians of a numerical tangent value.
' _TANH (function) Returns the hyperbolic tangent of x radians.
' _ATANH (function) Returns the arc hyperbolic tangent of x, expressed in radians.
' _ARCCOT (function) is the inverse function of the cotangent.
' CAUSE ERRORS:
' _COTH (function) Returns the hyperbolic cotangent.
' _CSCH (function) Returns the hyperbolic cosecant.
' _SECH (function) Returns the hyperbolic secant.
' OTHER GEOMETRY FUNCTIONS:
' _ATAN2 (function) Returns the principal value of the arc tangent of y/x, expressed in radians.
' _HYPOT (function) Returns the hypotenuse of a right-angled triangle whose legs are x and y.
' OTHER MATH FUNCTIONS:
' _D2R (function) converts degrees to radian angle values.
' _G2R (function) converts gradient to radian angle values.
' _R2D (function) converts radians to degree angle values.
' _R2G (function) converts radians to gradient angle values.
' _D2G (function) converts degrees to gradient angle values.
' _G2D (function) converts gradient to degree angle values.
' EXP (function) returns the value of e to the exponential power specified.
' LOG (function) returns the natural logarithm of a specified numerical value
' SGN (function) returns -1 for negative, 0 for zero, and 1 for positive numerical values.
' SQR (function) returns the square root of a non-negative number.
Posts: 101
Threads: 13
Joined: Jul 2024
Reputation:
15
10-31-2025, 10:15 AM
(This post was last modified: 10-31-2025, 12:43 PM by aadityap0901.)
I made a screensaver, inspired from the windows pipes screensaver and linux pipes.sh:
Code: (Select All)
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_MouseHide
Randomize Timer
_FullScreen _SquarePixels
_Font 8
DefLng A-Z
TW = _Width / _FontWidth
TH = _Height / _FontHeight
X = Rnd * TW
Y = Rnd * TH
D = 0
nD = 0
oD = 0
Dim As _Unsigned _Byte R, G, B
R = 128 + Rnd * 127
G = 128 + Rnd * 127
B = 128 + Rnd * 127
Color _RGB32(R, G, B), &HFF000000
Do
_Limit 60
If Rnd < 0.1 And Rnd < 0.5 Then nD = Int(Rnd * 3) + 1 Else nD = 2
nD = ClampCycle(0, D - nD + 2, 3)
Select Case D
Case 0: X = X + 1
Case 1: Y = Y + 1
Case 2: X = X - 1
Case 3: Y = Y - 1
End Select
If X < 0 Or X >= TW Or H < 0 Or H >= TH Then
R = 128 + Rnd * 127
G = 128 + Rnd * 127
B = 128 + Rnd * 127
Color _RGB32(R, G, B), &HFF000000
End If
X = ClampCycle(0, X, TW - 1)
Y = ClampCycle(0, Y, TH - 1)
Select Case _SHL(nD, 2) Or oD
Case 0, 10: C = 196
Case 5, 15: C = 179
Case 1, 14: C = 192
Case 4, 11: C = 191
Case 3, 6: C = 218
Case 9, 12: C = 217
Case Else: Print _SHL(D, 2) Or oD: End
End Select
_PrintString (X * _FontWidth, Y * _FontHeight), Chr$(C)
D = nD
oD = D
_Display
Loop Until (_MouseInput And (_MouseButton(1) Or _MouseButton(2) Or _MouseButton(3))) Or InKey$ <> ""
System
Function Clamp (A, B, C)
Clamp = B - (A - B) * (B < A) - (C - B) * (C < B)
End Function
Function ClampCycle (A, B, C)
ClampCycle = B - (C - B) * (B < A) - (A - B) * (C < B)
End Function
Posts: 346
Threads: 45
Joined: Jun 2024
Reputation:
32
11-01-2025, 01:41 AM
(This post was last modified: 11-01-2025, 01:42 AM by Unseen Machine.)
(10-31-2025, 10:15 AM)aadityap0901 Wrote: I made a screensaver, inspired from the windows pipes screensaver and linux pipes.sh:
Code: (Select All)
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_MouseHide
Randomize Timer
_FullScreen _SquarePixels
_Font 8
DefLng A-Z
TW = _Width / _FontWidth
TH = _Height / _FontHeight
X = Rnd * TW
Y = Rnd * TH
D = 0
nD = 0
oD = 0
Dim As _Unsigned _Byte R, G, B
R = 128 + Rnd * 127
G = 128 + Rnd * 127
B = 128 + Rnd * 127
Color _RGB32(R, G, B), &HFF000000
Do
_Limit 60
If Rnd < 0.1 And Rnd < 0.5 Then nD = Int(Rnd * 3) + 1 Else nD = 2
nD = ClampCycle(0, D - nD + 2, 3)
Select Case D
Case 0: X = X + 1
Case 1: Y = Y + 1
Case 2: X = X - 1
Case 3: Y = Y - 1
End Select
If X < 0 Or X >= TW Or H < 0 Or H >= TH Then
R = 128 + Rnd * 127
G = 128 + Rnd * 127
B = 128 + Rnd * 127
Color _RGB32(R, G, B), &HFF000000
End If
X = ClampCycle(0, X, TW - 1)
Y = ClampCycle(0, Y, TH - 1)
Select Case _SHL(nD, 2) Or oD
Case 0, 10: C = 196
Case 5, 15: C = 179
Case 1, 14: C = 192
Case 4, 11: C = 191
Case 3, 6: C = 218
Case 9, 12: C = 217
Case Else: Print _SHL(D, 2) Or oD: End
End Select
_PrintString (X * _FontWidth, Y * _FontHeight), Chr$(C)
D = nD
oD = D
_Display
Loop Until (_MouseInput And (_MouseButton(1) Or _MouseButton(2) Or _MouseButton(3))) Or InKey$ <> ""
System
Function Clamp (A, B, C)
Clamp = B - (A - B) * (B < A) - (C - B) * (C < B)
End Function
Function ClampCycle (A, B, C)
ClampCycle = B - (C - B) * (B < A) - (A - B) * (C < B)
End Function
Nostalgic to say the least! I'd like to see more than one pipe be generated at once though and as it's YOU, the exploding sphere from Windows 95! Thats DEFO in your wheelhouse!
John
Posts: 101
Threads: 13
Joined: Jul 2024
Reputation:
15
Thanks. Appreciate it.
Here is the multi-pipe one, fixed a bug too
Code: (Select All)
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_MouseHide
Randomize Timer
_FullScreen _SquarePixels
_Font 8
DefLng A-Z
TW = _Width / _FontWidth
TH = _Height / _FontHeight
Type PipeHead
As _Unsigned _Byte R, G, B
As Integer X, Y
As _Unsigned _Byte D, nD, oD
End Type
Dim As PipeHead Pipes(1 To 16)
For I = 1 To UBound(Pipes)
Pipes(I).X = Rnd * TW
Pipes(I).Y = Rnd * TH
Pipes(I).D = Int(Rnd * 4)
Pipes(I).nD = 0
Pipes(I).oD = Pipes(I).D
Pipes(I).R = 128 + Rnd * 127
Pipes(I).G = 128 + Rnd * 127
Pipes(I).B = 128 + Rnd * 127
Next I
Do
T~%% = (T~%% + 1) Mod 60
If T~%% = 0 Then Line (0, 0)-(_Width - 1, _Height - 1), &H0F000000, BF
_Limit 60
For I = 1 To UBound(Pipes)
If Rnd < 0.1 And Rnd < 0.5 Then Pipes(I).nD = Int(Rnd * 3) + 1 Else Pipes(I).nD = 2
Pipes(I).nD = ClampCycle(0, Pipes(I).D - Pipes(I).nD + 2, 3)
Select Case Pipes(I).D
Case 0: Pipes(I).X = Pipes(I).X + 1
Case 1: Pipes(I).Y = Pipes(I).Y + 1
Case 2: Pipes(I).X = Pipes(I).X - 1
Case 3: Pipes(I).Y = Pipes(I).Y - 1
End Select
If Pipes(I).X < 0 Or Pipes(I).X >= TW Or Pipes(I).Y < 0 Or Pipes(I).Y >= TH Then
Pipes(I).R = 128 + Rnd * 127
Pipes(I).G = 128 + Rnd * 127
Pipes(I).B = 128 + Rnd * 127
End If
Color _RGB32(Pipes(I).R, Pipes(I).G, Pipes(I).B), &HFF000000
Pipes(I).X = ClampCycle(0, Pipes(I).X, TW - 1)
Pipes(I).Y = ClampCycle(0, Pipes(I).Y, TH - 1)
Select Case _SHL(Pipes(I).nD, 2) Or Pipes(I).oD
Case 0, 10: C = 196
Case 5, 15: C = 179
Case 1, 14: C = 192
Case 4, 11: C = 191
Case 3, 6: C = 218
Case 9, 12: C = 217
End Select
_PrintString (Pipes(I).X * _FontWidth, Pipes(I).Y * _FontHeight), Chr$(C)
Pipes(I).D = Pipes(I).nD
Pipes(I).oD = Pipes(I).D
Next I
_Display
Loop Until (_MouseInput And (_MouseButton(1) Or _MouseButton(2) Or _MouseButton(3))) Or InKey$ <> ""
System
Function Clamp (A, B, C)
Clamp = B - (A - B) * (B < A) - (C - B) * (C < B)
End Function
Function ClampCycle (A, B, C)
ClampCycle = B - (C - B) * (B < A) - (A - B) * (C < B)
End Function]
Posts: 4,693
Threads: 222
Joined: Apr 2022
Reputation:
322
Living Spaghetti
Code: (Select All) Option _Explicit
_Title "Living Spaghetti 2 faster" 'bplus mod 2026-01-03 from:
'_Title "Living Spaghetti and Meatballs" 'bplus mod 2026-01-01 from:
'_Title "From DrawWorm to Living Spaghetti 2" 'bplus mod 2026-01-01 from:
'_Title "From DrawWorm to Living Spaghetti" 'bplus mod 2026-01-01 from:
'_Title "DrawWorms Test and Demo, worms should avoid Yellow and White" 'b+ 2021-10-06
' This is intended for Crypt-O-Gram Puzzle but may use else where also.
' 2026-01-01 attempting to make living spaghetti from this worm program
' 1. no more black background where worm crawls
' 2. no more black ouline of segmented worm
' 3. color greasy spaghetti on very light brown pasta
' 4. makeover drawWorms to DrawStrand
' 5. no worm Yard
' 2026-01-01 Living Spaghetti 2 color strands in Fake 3D
' 2026-01-01 add meatballs
' 2026-01-03 add code to make worm drawing faster! hopefully
' 2026-01-09 still working spaghetti as screen saver
' Use general Object
Type Object
X As Single ' usu top left corner could be center depending on object
Y As Single ' ditto
W As Single ' width or maybe radius
H As Single ' height or length
DX As Single ' moving opjects
DY As Single ' ditto
DIR As Single ' short for direction or heading usu a radian angle
S As Single ' perhaps a scaling factor, speed or size
Act As Integer ' lives countdown or just plain ACTive TF
C1 As _Unsigned Long ' a foreground color
C2 As _Unsigned Long ' a background or 2nd color OR C1 to c2 Range?
End Type
Const nStrand = 50
Const xmax = 1380, ymax = 760
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Dim Shared Strand(1 To nStrand) As Object
Dim Shared maxStrandLength: maxStrandLength = 150 ' max strand(i).H
Dim Shared XX(1 To nStrand, 1 To maxStrandLength), YY(1 To nStrand, 1 To maxStrandLength)
Dim Shared Head(1 To nStrand, 1 To maxStrandLength)
Dim Shared segImg&
Dim As Long i
'init
segImg& = MakeColorSegmentImg&(_RGB32(180, 180, 32), _RGB32(255, 255, 185))
For i = 1 To nStrand
NewStrand i
Next
Color , _RGB32(140, 20, 0) ' background red
Do
Cls
For i = 1 To nStrand
DrawStrand i
Next
_Display
Loop Until _KeyDown(27)
Function MakeColorSegmentImg& (OutsideC1~&, InsideC2~&)
' needs Sub cAnalysis(c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
' needs Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim cs&, y, c~&
cs& = _NewImage(100, 100, 32)
_Dest cs&
For y = 0 To 49
c~& = Ink~&(OutsideC1~&, InsideC2~&, y / 49)
Line (0, y)-(99, y), c~&
Line (0, 99 - y)-(99, 99 - y), c~&
Next
MakeColorSegmentImg& = cs&
_Dest 0
End Function
' best rev 2023-01-20 Jarvis with Steve change for eff might need _Seamless next to _MapTriangle calls
Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)
'uses radians
Dim As Long W, H, Wp, Hp, i, x2, y2
Dim sinr!, cosr!
Dim px(3) As Single: Dim py(3) As Single
W& = _Width(Image&): H& = _Height(Image&)
Wp& = W& / 2 * xScale
Hp& = H& / 2 * yScale
px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&
px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&
sinr! = Sin(-radRotation): cosr! = Cos(radRotation)
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 ' _Seamless? below
_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 cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim R1, G1, B1, A1, R2, G2, B2, A2
cAnalysis c1, R1, G1, B1, A1
cAnalysis c2, R2, G2, B2, A2
Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function
Sub DrawStrand (i) ' one frame in main loop
Dim x, y, dir
Dim As Long j, r
'If Strand(i).Act > 0 Then ' to turn or not to turn
Strand(i).Act = 0 ' turn!
Strand(i).DIR = Strand(i).DIR + _Pi(.04 * Rnd - .02)
Strand(i).DX = Cos(Strand(i).DIR)
Strand(i).DY = Sin(Strand(i).DIR)
'Else
'Strand(i).Act = Strand(i).Act + 1
'End If
x = Strand(i).X + Strand(i).DX * Strand(i).S
y = Strand(i).Y + Strand(i).DY * Strand(i).S
If x < -100 Or x > _Width + 100 Or y < -100 Or y > _Height + 100 Then 'stay inbounds of screen
Strand(i).DIR = Strand(i).DIR + _Pi
Strand(i).DX = Cos(Strand(i).DIR)
Strand(i).DY = Sin(Strand(i).DIR)
x = x + Strand(i).S * 2 * Strand(i).DX ' double back
y = y + Strand(i).S * 2 * Strand(i).DY ' double back
End If
dir = _Atan2(y - Strand(i).Y, x - Strand(i).X)
For r = Strand(i).W To 1 Step -2
For j = Strand(i).H To 2 Step -1
XX(i, j) = XX(i, j - 1): YY(i, j) = YY(i, j - 1) ' crawl towards head
Head(i, j) = Head(i, j - 1)
If XX(i, j) <> 0 And YY(i, j) <> 0 Then RotoZoom23r XX(i, j), YY(i, j), segImg&, .2, .15, Head(i, j)
Next
Next
XX(i, 1) = x: YY(i, 1) = y: Head(i, 1) = dir ' update head
RotoZoom23r XX(i, 1), YY(i, 1), segImg&, .2, .15, Head(i, 1)
Strand(i).X = x: Strand(i).Y = y
End Sub
Sub NewStrand (i)
Strand(i).X = _Width * Rnd
Strand(i).Y = _Height * Rnd
Strand(i).DIR = _Pi(2 * Rnd)
Strand(i).DX = Cos(Strand(i).DIR)
Strand(i).DY = Sin(Strand(i).DIR)
Strand(i).W = 6 ' radius
Strand(i).H = maxStrandLength - Rnd * .2 * maxStrandLength ' length
Strand(i).S = 12 + Rnd * 8 ' speed
Strand(i).Act = 1
'Strand(i).C1 = _RGB32(255 - 60 * Rnd, 195 - 60 * Rnd, 105 - 60 * Rnd)
End Sub
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 243
Threads: 15
Joined: Apr 2024
Reputation:
30
01-09-2026, 06:36 PM
(This post was last modified: 01-09-2026, 06:38 PM by ahenry3068.)
MYSTIFY Clone with a little customizable twist:
Also using a _MEM pointer so that I can have an array attached to a User Defined type
Code: (Select All)
Option _Explicit
Type PointType
X As Long
Y As Long
XInc As Integer
YInc As Integer
End Type
Dim Shared Pt As PointType
Type BOXTYPE
POINTS As _MEM
NUMPOINTS As Integer
bCOLOR As _Unsigned Long
End Type
Dim Shared X_ColorChange As Integer
Dim Shared Y_ColorChange As Integer
Dim Shared XLimit As Long
Dim Shared YLimit As Long
Dim Shared NumPoints As Long
Dim Shared NumBoxes As Long
Dim Shared NumLines As Long
Dim FrameSpeed As Long
Dim Shared TrailPointer As Long
Dim Shared CurTrail As Long
Dim Shared DrawPointer As Long
Dim I As Long
Dim J As Long
Randomize Timer
Width 60, 50
_Title "SET UP MYSTIFY"
GoSub SPEEDMESSAGE
Dim x$
Locate 3, 2
Print "USE DEFAULT VALUES --> : ";
Line Input x$
x$ = _Trim$(UCase$(x$))
If x$ = "" Then
Print
Print "ERROR"
GoTo GETYBOUNCE
End If
If (Left$(x$, 1) = "Y") Then
NumBoxes = 2
NumPoints = 4
NumLines = 30
X_ColorChange = _TRUE
Y_ColorChange = _FALSE
FrameSpeed = 60
GoTo start_me_up
End If
Cls
FrameSpeed = 60
GETNUMBOX:
GoSub SPEEDMESSAGE
Locate 2, 2
Print "NUMBER OF BOXES (1 to 10) --> : ";
Line Input x$
If Val(x$) < 1 Or Val(x$) > 10 Then
Print
Print "ERROR -->"; x$; " Is not Valid !"
GoTo GETNUMBOX
End If
NumBoxes = Val(x$)
Cls
GETNUMCORNERS:
GoSub SPEEDMESSAGE
Locate 3, 2
Print "NUMBER OF BOX CORNERS (3 to 10) --> : ";
Line Input x$
If Val(x$) < 3 Or Val(x$) > 10 Then
Print
Print "ERROR -->"; x$; " Is not Valid !"
GoTo GETNUMCORNERS
End If
NumPoints = Val(x$)
Cls
gettraillines:
GoSub SPEEDMESSAGE
Locate 2, 2
Print "NUMBER OF TRAILING BOXES (8 to 100) --> : ";
Line Input x$
If Val(x$) < 8 Or Val(x$) > 100 Then
Print
Print "ERROR -->"; x$; " Is not Valid !"
GoTo gettraillines
End If
NumLines = Val(x$)
Cls
GETXBOUNCE:
GoSub SPEEDMESSAGE
Locate 3, 2
Print "Change Color on X Bounce (Y/N) --> : ";
Line Input x$
x$ = _Trim$(UCase$(x$))
If x$ = "" Then
Print
Print "ERROR"
GoTo GETXBOUNCE
End If
X_ColorChange = (Left$(x$, 1) = "Y")
Cls
GETYBOUNCE:
GoSub SPEEDMESSAGE
Locate 3, 2
Print "Change Color on Y Bounce (Y/N) --> : ";
Line Input x$
x$ = _Trim$(UCase$(x$))
If x$ = "" Then
Print
Print "ERROR"
GoTo GETYBOUNCE
End If
Y_ColorChange = (Left$(x$, 1) = "Y")
start_me_up:
TrailPointer = 0
XLimit = 1152
YLimit = 864
Dim Shared DRAW_TRAIL As Integer
DRAW_TRAIL = _FALSE
ReDim BOXS(0 To NumBoxes - 1) As BOXTYPE
ReDim TrailBoxes(NumBoxes, NumLines) As BOXTYPE
For I = 0 To NumBoxes - 1
INIT_BOX BOXS(I)
For J = 0 To NumLines - 1
INIT_BOX TrailBoxes(I, J)
TrailBoxes(I, J).bCOLOR = _RGB32(0, 0, 0, 255)
Next
Next
Screen _NewImage(XLimit, YLimit, 32)
Line (0, 0)-(XLimit - 2, YLimit - 1), _RGB32(0, 0, 0, 255), BF
_FullScreen , _Smooth
Dim C As Long
DrawPointer = 0
CurTrail = 0
TrailPointer = 0
DRAW_TRAIL = _FALSE
Do
For I = 0 To NumBoxes - 1
If DRAW_TRAIL Then DrawBox TrailBoxes(I, CurTrail)
DrawBox BOXS(I)
CopyBox BOXS(I), TrailBoxes(I, TrailPointer)
MoveBox BOXS(I)
Next
If DRAW_TRAIL Then
CurTrail = CurTrail + 1
If CurTrail = NumLines Then CurTrail = 0
End If
TrailPointer = TrailPointer + 1
If TrailPointer = NumLines Then
DRAW_TRAIL = _TRUE
TrailPointer = 0
End If
C = _KeyHit
If C = _KEY_UP Then
If FrameSpeed < 200 Then FrameSpeed = FrameSpeed + 1
End If
If C = _KEY_DOWN Then
If FrameSpeed > 20 Then FrameSpeed = FrameSpeed - 1
End If
_Limit FrameSpeed
Loop Until C = 27
System
SPEEDMESSAGE:
Locate 20, 10
Color 10
Print "ARROW KEYS WILL CONTROL ANIMATION SPEED."
Color 15
Return
Sub CopyBox (Box1 As BOXTYPE, Box2 As BOXTYPE)
Dim DPoints(0 To NumPoints - 1) As PointType
_MemGet Box1.POINTS, Box1.POINTS.OFFSET, DPoints()
_MemPut Box2.POINTS, Box2.POINTS.OFFSET, DPoints()
End Sub
Function RandomColor&&
Static R As Integer
Static G As Integer
Static B As Integer
Static Total As Integer
GETCOLORS:
R = Int(Rnd * 255) + 1
G = Int(Rnd * 255) + 1
B = Int(Rnd * 255) + 1
Total = R + G + B
If Total < 100 GoTo GETCOLORS
RandomColor = _RGB32(R, G, B, 255)
End Function
Sub INIT_BOX (BOX As BOXTYPE)
Dim DPoints(0 To NumPoints - 1) As PointType
Dim I As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
BOX.POINTS = _MemNew(Len(Pt) * NumPoints)
For I = 0 To NumPoints - 1
DPoints(I).X = Int(Rnd * XLimit)
DPoints(I).Y = Int(Rnd * YLimit)
DPoints(I).XInc = Int(Rnd * 5) + 1
DPoints(I).YInc = Int(Rnd * 5) + 1
If Int(Rnd * 11) < 5 Then
DPoints(I).XInc = DPoints(I).XInc * -1
End If
If Int(Rnd * 11) < 5 Then
DPoints(I).YInc = DPoints(I).YInc * -1
End If
Next
_MemPut BOX.POINTS, BOX.POINTS.OFFSET, DPoints()
BOX.bCOLOR = RandomColor
End Sub
Sub DrawBox (Box As BOXTYPE)
Dim I As Long
Dim X As Long
Dim Y As Long
Dim X2 As Long
Dim Y2 As Long
Dim DestIndx As Long
Dim Dest As Long
Dim DPoints(0 To NumPoints - 1) As PointType
_MemGet Box.POINTS, Box.POINTS.OFFSET, DPoints()
Dest = NumPoints - 1
For I = 0 To Dest
If I = Dest Then DestIndx = 0 Else DestIndx = I + 1
X = DPoints(I).X
Y = DPoints(I).Y
X2 = DPoints(DestIndx).X
Y2 = DPoints(DestIndx).Y
Line (X, Y)-(X2, Y2), Box.bCOLOR
Next
End Sub
Sub MoveBox (Box As BOXTYPE)
Dim I As Long
Dim X As Long
Dim Y As Long
Dim X2 As Long
Dim Y2 As Long
Dim DestIndx As Long
Dim Dest As Long
Dim DPoints(0 To NumPoints - 1) As PointType
_MemGet Box.POINTS, Box.POINTS.OFFSET, DPoints()
Dest = NumPoints - 1
For I = 0 To Dest
DPoints(I).X = DPoints(I).X + DPoints(I).XInc
DPoints(I).Y = DPoints(I).Y + DPoints(I).YInc
If DPoints(I).X >= XLimit Then
DPoints(I).X = XLimit
DPoints(I).XInc = (Int(Rnd * 5) + 1) * -1
If X_ColorChange Then
Box.bCOLOR = RandomColor
End If
End If
If DPoints(I).X <= 0 Then
DPoints(I).X = 0
DPoints(I).XInc = (Int(Rnd * 5) + 1)
End If
If DPoints(I).Y >= YLimit Then
DPoints(I).Y = YLimit
DPoints(I).YInc = (Int(Rnd * 5) + 1) * -1
If Y_ColorChange Then
Box.bCOLOR = RandomColor
End If
End If
If DPoints(I).Y <= 0 Then
DPoints(I).Y = 0
DPoints(I).YInc = (Int(Rnd * 5) + 1)
End If
Next
_MemPut Box.POINTS, Box.POINTS.OFFSET, DPoints()
End Sub
Posts: 4,693
Threads: 222
Joined: Apr 2022
Reputation:
322
01-09-2026, 08:33 PM
(This post was last modified: 01-09-2026, 08:35 PM by bplus.)
Yeah Mystic is the very first post I made in this Thread! check it out here:
https://qb64phoenix.com/forum/showthread...898#pid898
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,693
Threads: 222
Joined: Apr 2022
Reputation:
322
01-11-2026, 03:28 AM
(This post was last modified: 01-11-2026, 03:38 AM by bplus.)
Updated Mystic with alternate technique of fades
Sharing some ideas with @ahenry3068 tonight, I realized Mystic or Mystify Clone could be done by drawing a single triangle at each screen refresh and just use fade with alpha's to "track" already drawn triangles! A simpler way to have nearly the same effect!
My original could show 2 symmetric sets of triangles using d to double or undouble, NOW there is q to show 4 sets of symmetric triangles or NOT like d, q toggles quad mode on and off.
PLUS now you can speed up the screen updates and slow down, f for faster, s for slower.
Oh and if you get tired of the one set of triangles press n for a new set!
Code: (Select All) t$ = "Simpler Mystic d = double, q = 4 on/off, space resets color, m = more, l = less, n = new triangle"
t$ = t$ + ", f = faster, s = slower"
_Title t$
' 2026-01-10 attempt to do Mystic with only one triangle and fades
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! KEY Instructions !!!!!!!!!!!!!!!!!!!
' d = double ie 2 sets of triangles
' q = quad ie 4 sets of triangles
' spacebar resets pallet coloring
' m = more triagles by decreasing alpha screen fades
' l = less triangles by increasing alpha in screen fades
' f = faster
' s = slower
' n = new triangle
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Randomize Timer
Const xmax = 1280
Const ymax = 720
Dim Shared pR, pG, pB, cN
Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 0, 0
' 3 point of triangle
Dim Shared X(2), Y(2), DX(2), DY(2), dMode, qMode
dMode = 0: alpha = 35: lim = 10
resetPlasma: newTriangle
While _KeyDown(27) = 0
Line (0, 0)-(xmax, ymax), _RGB32(0, 0, 0, alpha), BF
For i = 0 To 2
updateTriangle
Next
Color &HFFFFFFFF ' checking alpha
Locate 1, 1: Print Space$(20)
Locate 1, 1: Print "alpha ="; alpha, "speed ="; lim
_Display
'The following commented code worked (works) like a charm
k$ = InKey$
If k$ = " " Then
resetPlasma
ElseIf k$ = "d" Then
dMode = Not dMode: qMode = 0
ElseIf k$ = "m" Then ' less aplha shows more triantgles
alpha = alpha - 1: If alpha < 1 Then alpha = 1
ElseIf k$ = "l" Then ' more alpha shows less triangles
alpha = alpha + 1: If alpha > 255 Then alpha = 255 ' one triangle
ElseIf k$ = "q" Then
qMode = Not qMode: dMode = 0
ElseIf k$ = "f" Then
lim = lim + 5: If lim > 250 Then lim = 250
ElseIf k$ = "s" Then
lim = lim - 5: If lim < 5 Then lim = 5
ElseIf k$ = "n" Then
Cls: newTriangle
End If
_Limit lim
Wend
Sub newTriangle
For i = 0 To 2
X(i) = Rnd * xmax: Y(i) = Rnd * ymax: DX(i) = (Rnd * 10 + 1) * rdir: DY(i) = (Rnd * 6 + 1) * rdir
Next
End Sub
Sub updateTriangle
changePlasma
For i = 0 To 2
If X(i) + DX(i) < 0 Or X(i) + DX(i) >= xmax Then DX(i) = DX(i) * -1
If Y(i) + DY(i) < 0 Or Y(i) + DY(i) >= ymax Then DY(i) = DY(i) * -1
X(i) = X(i) + DX(i): Y(i) = Y(i) + DY(i)
If i > 0 Then
Line (X(i - 1), Y(i - 1))-(X(i), Y(i))
If dMode Then
Line (xmax - X(i - 1), ymax - Y(i - 1))-(xmax - X(i), ymax - Y(i))
ElseIf qMode Then
Line (xmax - X(i - 1), ymax - Y(i - 1))-(xmax - X(i), ymax - Y(i))
Line (X(i - 1), ymax - Y(i - 1))-(X(i), ymax - Y(i))
Line (xmax - X(i - 1), Y(i - 1))-(xmax - X(i), Y(i))
End If
End If
Next
Line (X(2), Y(2))-(X(0), Y(0))
If dMode Then
Line (xmax - X(2), ymax - Y(2))-(xmax - X(0), ymax - Y(0))
ElseIf qMode Then
Line (xmax - X(2), ymax - Y(2))-(xmax - X(0), ymax - Y(0))
Line (X(2), ymax - Y(2))-(X(0), ymax - Y(0))
Line (xmax - X(2), Y(2))-(xmax - X(0), Y(0))
End If
If dMode Then Line (xmax - X(2), ymax - Y(2))-(xmax - X(0), ymax - Y(0))
End Sub
Sub changePlasma
cN = cN + 1
Color _RGB(127 + 127 * Sin(pR * .5 * cN), 127 + 127 * Sin(pG * .5 * cN), 127 + 127 * Sin(pB * .5 * cN))
End Sub
Sub resetPlasma ()
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub
Function rdir% ()
If Rnd < .5 Then rdir% = -1 Else rdir% = 1
End Function
< 100 LOC without comments!
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
|
