Posts: 993
Threads: 134
Joined: Apr 2022
Reputation:
22
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: 993
Threads: 134
Joined: Apr 2022
Reputation:
22
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: 993
Threads: 134
Joined: Apr 2022
Reputation:
22
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.
|
