+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Help Me! (https://staging.qb64phoenix.com/forumdisplay.php?fid=10)
+---- Thread: neat _SndRaw example, but how do you stop _SndRaw from playing? (/showthread.php?tid=774)
Pages:
1
2
RE: neat _SndRaw example, but how do you stop _SndRaw from playing? - madscijr - 08-17-2022
(08-17-2022, 03:06 PM)mnrvovrfc Wrote: Setting "sngSoundRaw" variable to -1 or 1 just hard-clips the sound. You have to check the "Waveform" and "Amplitude" variables how they're being changed and find a way to reduce the absolute value of that multiplication. Try dividing "Amplitude" by 2 to see what happens.
"Hard-clip" is just rounding off a sound so that if the input sound is very very loud, it is transformed to be like silence, but it's annoying because when the audio was played back and then stopped, it causes a loud pop into headphones or speakers. It's not better cleaning DC offset. That's why sound engineers look to prevent it.
I took another look at the code. The problem with one of the functions is that "Modulator" is always going at full blast while "Waveform" has to experience some reduction. "Amplitude" is already being set very small, to one-over-million, so the culprit might be the modulation depth. Both "Modulator" and "Waveform" have to experience some sort of reduction.
Thanks...
I added some debugging code to dump the values of all variables to a log file
(I killed the program as soon as I started hearing the noise)
and here are the minimum and maximum values for each variable during the execution:
Code: (Select All)
Variable Min Max
--------------------- ----------------------------- -----------------------------
dblAmplitude 0.000001 0.000001
dblCEnvelopeDecD 0.574680864810943 0.574680864810943
dblCEnvelopeDecR 0.00116099242586642 0.00116099242586642
dblCEnvelopeInc 25600 25600
dblMEnvelopeDecD 0.000340128346579149 0.000340128346579149
dblMEnvelopeDecR 5.66891285416204E-05 5.66891285416204E-05
dblMEnvelopeInc 30 30
dblModulator -179772.761704753 181062.049552671
dblModulatorAmplitude 18.855014467641 181278.855014467
dblPi 6.28318530717958 6.28318530717958
dblVolume 6769.43210273981 154681969.432102
dblWaveform -152732846.530367 154573207.79132
lngSamples 441000 441000
sngCarrierDecay 0.1 0.1
sngCarrierRelease 1 1
sngCS 0.4 0.5
sngMS 0.3 0.3999999
sngSoundDecay 0.1 0.1
sngSoundRaw -152.7328 154.5732
sngSoundRelease 1 1Other than sngSoundRaw needing to be between -1 and 1,
what other threshold values do we need to look out for,
and which variables are exceeding their threshold?
(If you want to see all the values, see the attached ZIP file.)
Any help appreciated!
Here is the code modified to write the values to a log:
Code: (Select All)
' NOTE: This version just writes output to a log file named the same as the .BAS but .TXT
' FM (Frequency modulation) sound with _SNDRAW
' http://www.qb64.net/forum/index.php?topic=11395.0
Option _Explicit
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
Dim Shared m_iDebugCount As Long: m_iDebugCount = 0
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_DebugFile$: m_DebugFile$ = m_ProgramPath$ + Left$(m_ProgramName$, Len(m_ProgramName$) - 4) + ".txt"
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' INITIALIZE DEBUGGING LOG
If m_bDebug = TRUE Then
InitDebugFile
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
'FM_Sound_Test1
FM_Sound_Test2
' =============================================================================
' FINISH
Screen 0
Print m_ProgramName$ + " finished."
'Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
' Plays 2 sounds based on angros47's parameters:
'
' 1. sounds okay for about a second, then just plays harsh noise without
' stopping - how do you turn it off without killing the program?
'
' 2. sounds pretty cool! But it goes on forever, does it ever stop?
' (how do you stop _SNDRAW sounds once they start playing?)
' TODO: check the value of _SNDRAWLEN and make sure it doesn't exceed
' 3 seconds, and don't add any more sounds until the value
' falls below that threshold.
Sub FM_Sound_Test2
Dim iSoundFrequency As Integer
Dim iSoundDuration As Integer
Dim iSoundMaxVolume As Integer
Dim sngCarrierAttack As Single
Dim sngCarrierDecay As Single
Dim sngCarrierSustain As Single
Dim sngCarrierRelease As Single
Dim iModulatorFrequency As Integer
Dim sngModulatorPhase As Single
Dim iModulatorMaxLevel As Integer
Dim sngSoundAttack As Single
Dim sngSoundDecay As Single
Dim sngSoundSustain As Single
Dim sngSoundRelease As Single
Dim in$
Do
Input "Press ENTER to play sound #1, 's' to skip, or 'q' to quit"; in$
If in$ = "q" Then Exit Do
If in$ <> "s" Then
iSoundFrequency = 500
iSoundDuration = 182
iSoundMaxVolume = 256
sngCarrierAttack = 0
sngCarrierDecay = 0.1
sngCarrierSustain = 0.01
sngCarrierRelease = 0.5
iModulatorFrequency = 500
sngModulatorPhase = 0.5
iModulatorMaxLevel = 30
sngSoundAttack = 0
sngSoundDecay = 0.1
sngSoundSustain = 0.5
sngSoundRelease = 0.6
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
End If
Do
_Limit 3000
Loop While _SndRawLen > 0
Input "Press ENTER to play sound #2, 's' to skip, or 'q' to quit"; in$
If in$ = "q" Then Exit Do
If in$ <> "s" Then
iSoundFrequency = 3000
iSoundDuration = 182
iSoundMaxVolume = 256
sngCarrierAttack = 0.5
sngCarrierDecay = 0.2
sngCarrierSustain = 1
sngCarrierRelease = 0.1
iModulatorFrequency = 10
sngModulatorPhase = 0.5
iModulatorMaxLevel = 1000
sngSoundAttack = 0.6
sngSoundDecay = 0.2
sngSoundSustain = 0.7
sngSoundRelease = 0.2
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
End If
Do
_Limit 3000
Loop While _SndRawLen > 0
Loop
End Sub ' FM_Sound_Test2
' /////////////////////////////////////////////////////////////////////////////
' This version prompts for parameters.
' TODO: simple mouse or keyboard interface for realtime input?
Sub FM_Sound_Test1
Dim iSoundFrequency As Integer
Dim iSoundDuration As Integer
Dim iSoundMaxVolume As Integer
Dim sngCarrierAttack As Single
Dim sngCarrierDecay As Single
Dim sngCarrierSustain As Single
Dim sngCarrierRelease As Single
Dim iModulatorFrequency As Integer
Dim sngModulatorPhase As Single
Dim iModulatorMaxLevel As Integer
Dim sngSoundAttack As Single
Dim sngSoundDecay As Single
Dim sngSoundSustain As Single
Dim sngSoundRelease As Single
Dim in$
Do
Print "--- Sound ---"
Input "Frequency"; iSoundFrequency
Input "Duration"; iSoundDuration
Input "Maximum Volume"; iSoundMaxVolume
Print "--- Carrier ---"
Input "Attack"; sngCarrierAttack
Input "Decay"; sngCarrierDecay
Input "Sustain"; sngCarrierSustain
Input "Release"; sngCarrierRelease
Print "--- Modulator ---"
Input "Frequency"; iModulatorFrequency
Input "Phase"; sngModulatorPhase
Input "Maximum level"; iModulatorMaxLevel
Print "--- ADSR ---"
Input "Attack"; sngSoundAttack
Input "Decay"; sngSoundDecay
Input "Sustain"; sngSoundSustain
Input "Release"; sngSoundRelease
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
Input "Type 'q' to quit or any key to continue"; in$
If in$ = "q" Then Exit Do
Loop
End Sub ' FM_Sound_Test1
' /////////////////////////////////////////////////////////////////////////////
' Version 2 of angros47's function, modified by madscijr:
' - more descriptive variable names,
' - user can press ESC to quit.
' TODO: check the value of _SNDRAWLEN and make sure it doesn't exceed
' 3 seconds, and don't add any more sounds until the value
' falls below that threshold.
' https://github.com/QB64Official/qb64/wiki/_SNDRAWLEN
' TODO: if user presses ESC, stop playing the sound. How??
Sub FM_Sound( _
iSoundFrequency as integer, _
iSoundDuration as integer, _
iSoundMaxVolume as integer, _
sngCarrierAttack as single, _
sngCarrierDecay as single, _
sngCarrierSustain as single, _
sngCarrierRelease as single, _
iModulatorFrequency as integer, _
sngModulatorPhase as single, _
iModulatorMaxLevel as integer, _
sngSoundAttack as single, _
sngSoundDecay as single, _
sngSoundSustain as single, _
sngSoundRelease as single)
Dim lngSamples As Long
Dim sngCS As Single
Dim sngMS As Single
Dim dblCEnvelopeInc As Double
Dim dblCEnvelopeDecD As Double
Dim dblCEnvelopeDecR As Double
Dim dblMEnvelopeInc As Double
Dim dblMEnvelopeDecD As Double
Dim dblMEnvelopeDecR As Double
Dim iLoop As Integer
Dim sngSoundRaw As Single
Dim dblPi As Double
Dim dblAmplitude As Double
Dim dblModulator As Double
Dim dblWaveform As Double
Dim dblModulatorAmplitude As Double
Dim dblVolume As Double
lngSamples = _SndRate * Int(iSoundDuration / 18.2) ' seconds
DebugFileVarLng 1, "lngSamples", lngSamples
sngCS = 1 - sngCarrierAttack - sngCarrierDecay - sngCarrierRelease
DebugFileVarSng 2, "sngCS", sngCS
sngMS = 1 - sngSoundAttack - sngSoundDecay - sngSoundRelease
DebugFileVarSng 3, "sngMS", sngMS
dblCEnvelopeInc = 100 * iSoundMaxVolume / (lngSamples * sngCarrierAttack + 1)
DebugFileVarDbl 4, "dblCEnvelopeInc", dblCEnvelopeInc
dblCEnvelopeDecD = 100 * iSoundMaxVolume * (1 - sngCarrierSustain) / (lngSamples * sngCarrierDecay + 1)
DebugFileVarDbl 5, "dblCEnvelopeDecD", dblCEnvelopeDecD
dblCEnvelopeDecR = 100 * iSoundMaxVolume * sngCarrierSustain / (lngSamples * sngCarrierRelease + 1)
DebugFileVarDbl 6, "dblCEnvelopeDecR", dblCEnvelopeDecR
sngCarrierDecay = sngCarrierDecay + sngCarrierAttack
DebugFileVarSng 7, "sngCarrierDecay", sngCarrierDecay
sngCS = sngCS + sngCarrierDecay
DebugFileVarSng 8, "sngCS", sngCS
sngCarrierRelease = sngCarrierRelease + sngCS
DebugFileVarSng 9, "sngCarrierRelease", sngCarrierRelease
dblMEnvelopeInc = iModulatorMaxLevel / (lngSamples * sngSoundAttack + 1)
DebugFileVarDbl 10, "dblMEnvelopeInc", dblMEnvelopeInc
dblMEnvelopeDecD = iModulatorMaxLevel * (1 - sngSoundSustain) / (lngSamples * sngSoundDecay + 1)
DebugFileVarDbl 11, "dblMEnvelopeDecD", dblMEnvelopeDecD
dblMEnvelopeDecR = iModulatorMaxLevel * sngSoundSustain / (lngSamples * sngSoundRelease + 1)
DebugFileVarDbl 12, "dblMEnvelopeDecR", dblMEnvelopeDecR
sngSoundDecay = sngSoundDecay + sngSoundAttack
DebugFileVarSng 13, "sngSoundDecay", sngSoundDecay
sngMS = sngMS + sngSoundDecay
DebugFileVarSng 14, "sngMS", sngMS
sngSoundRelease = sngSoundRelease + sngMS
DebugFileVarSng 15, "sngSoundRelease", sngSoundRelease
dblPi = 8 * Atn(1) '2 * pi
DebugFileVarDbl 16, "dblPi", dblPi
dblAmplitude = .000001
DebugFileVarDbl 17, "dblAmplitude", dblAmplitude
For iLoop = 0 To lngSamples
Do While _SndRawLen > 3.0
_Limit 3000
If _KeyDown(27) Then Exit Do
Loop
If iLoop <= sngCarrierAttack * lngSamples Then
dblVolume = dblVolume + dblCEnvelopeInc
DebugFileVarDbl 18, "dblVolume", dblVolume
ElseIf iLoop < sngCarrierDecay * lngSamples Then
dblVolume = dblVolume - dblCEnvelopeDecD
DebugFileVarDbl 19, "dblVolume", dblVolume
ElseIf iLoop < sngCS * lngSamples Then
DebugFileVarDbl 20, "dblVolume", dblVolume
ElseIf iLoop < sngCarrierRelease * lngSamples Then
dblVolume = dblVolume - dblCEnvelopeDecR
DebugFileVarDbl 21, "dblVolume", dblVolume
End If
If iLoop <= sngSoundAttack * lngSamples Then
dblModulatorAmplitude = dblModulatorAmplitude + dblMEnvelopeInc
DebugFileVarDbl 22, "dblModulatorAmplitude", dblModulatorAmplitude
ElseIf iLoop < sngSoundDecay * lngSamples Then
dblModulatorAmplitude = dblModulatorAmplitude - dblMEnvelopeDecD
DebugFileVarDbl 23, "dblModulatorAmplitude", dblModulatorAmplitude
ElseIf iLoop < sngMS * lngSamples Then
DebugFileVarDbl 24, "dblModulatorAmplitude", dblModulatorAmplitude
ElseIf iLoop < sngSoundRelease * lngSamples Then
dblModulatorAmplitude = dblModulatorAmplitude - dblMEnvelopeDecR
DebugFileVarDbl 25, "dblModulatorAmplitude", dblModulatorAmplitude
End If
dblModulator = Cos(dblPi / _SndRate * iLoop * iModulatorFrequency + sngModulatorPhase) * dblModulatorAmplitude
DebugFileVarDbl 26, "dblModulator", dblModulator
dblWaveform = Sin(dblPi / _SndRate * iLoop * iSoundFrequency + dblModulator) * dblVolume
DebugFileVarDbl 27, "dblWaveform", dblWaveform
sngSoundRaw = dblAmplitude * dblWaveform
DebugFileVarSng 28, "sngSoundRaw", sngSoundRaw
If sngSoundRaw < -1 Then
sngSoundRaw = -1
DebugFileVarSng 29, "sngSoundRaw", sngSoundRaw
ElseIf sngSoundRaw > 1 Then
sngSoundRaw = 1
DebugFileVarSng 30, "sngSoundRaw", sngSoundRaw
End If
_SndRaw sngSoundRaw
If InKey$ = Chr$(27) Then Exit For ' GIVE THE USER A WAY TO EXIT
Next iLoop
Do
If InKey$ = Chr$(27) Then Exit Do ' GIVE THE USER A WAY TO EXIT
Loop While _SndRawLen
End Sub ' FM_Sound
' /////////////////////////////////////////////////////////////////////////////
' Original version of the code by angros47
' -----------------------------------------------------------------------------
' angros47
' « on: September 15, 2013, 12:19:04 pm »
' http://www.qb64.net/forum/index.php?topic=11395.0
'
' Years ago, I made a program to generate sound effects in FreeBasic...
' just for fun, I tried to port it to QB64, too (the _SNDRAW helped, of course).
' Have fun!
' -----------------------------------------------------------------------------
' LeChuck
' « Reply #1 on: September 15, 2013, 02:27:54 pm »
' http://www.qb64.net/forum/index.php?topic=11395.msg97452#msg97452
'
' Hey angros47,
' Can you add some demo values as well because I can't seem to generate any
' sound.
' Thanks
' No disaster occurs for any single reason.
' -----------------------------------------------------------------------------
' angros47
' « Reply #2 on: September 16, 2013, 08:03:22 am »
' http://www.qb64.net/forum/index.php?topic=11395.msg97464#msg97464
'
' Frequency 500
' Duration 182
' Maximum Volume 256
'
' Carrier
' Attack 0
' Decay 0.1
' Sustain 0.01
' Release 0.5
'
' Modulator
' Frequency 500
' Phase 0.5
' Maximum level 30
'
' Attack 0
' Decay 0.1
' Sustain 0.5
' Release 0.6
'
' Or
'
' Frequency 3000
' Duration 182
' Maximum Volume 256
'
' Carrier
' Attack 0.5
' Decay 0.2
' Sustain 1
' Release 0.1
'
' Modulator
' Frequency 10
' Phase 0.5
' Maximum level 1000
'
' Attack 0.6
' Decay 0.2
' Sustain 0.7
' Release 0.2
' -----------------------------------------------------------------------------
' OlDosLover
' « Reply #3 on: September 16, 2013, 06:54:06 pm »
' http://www.qb64.net/forum/index.php?topic=11395.msg97469#msg97469
'
' Hi all,
' Wow! Very impressive. I think this might be QB64's first sound generator.
' Thank you for sharing this valuable tool.
' OlDosLover.
' -----------------------------------------------------------------------------
'Sub FM_Sound_v1
' Input "Frequency"; Frequency
' Input "Duration"; Duration
' Input "Maximum Volume"; MaxVol
' Print "--- Carrier ---"
' Input "Attack"; ca
' Input "Decay"; cd
' Input "Sustain"; csl
' Input "Release"; cr
'
' Print "--- Modulator ---"
' Input "Frequency"; MFrequency
' Input "Phase"; ModStart
' Input "Maximum level"; MaxModulator
'
' Input "Attack"; Ma
' Input "Decay"; md
' Input "Sustain"; msl
' Input "Release"; mr
'
' Dim nSamples As Long
'
' Dim CS As Single, MS As Single
'
' nSamples = _SndRate * Int(Duration / 18.2) ' seconds
'
' CS = 1 - ca - cd - cr
' MS = 1 - Ma - md - mr
'
' Dim CEnvelopeInc As Double, CEnvelopeDecD As Double, CEnvelopeDecR As Double
' CEnvelopeInc = 100 * MaxVol / (nSamples * ca + 1)
' CEnvelopeDecD = 100 * MaxVol * (1 - csl) / (nSamples * cd + 1)
' CEnvelopeDecR = 100 * MaxVol * csl / (nSamples * cr + 1)
'
' cd = cd + ca
' CS = CS + cd
' cr = cr + CS
'
' Dim MEnvelopeInc As Double, MEnvelopeDecD As Double, MEnvelopeDecR As Double
' MEnvelopeInc = MaxModulator / (nSamples * Ma + 1)
' MEnvelopeDecD = MaxModulator * (1 - msl) / (nSamples * md + 1)
' MEnvelopeDecR = MaxModulator * msl / (nSamples * mr + 1)
'
' md = md + Ma
' MS = MS + md
' mr = mr + MS
'
' Pi2 = 8 * Atn(1) '2 * pi
' Amplitude = .000001
'
' For i = 0 To nSamples
'
' If i <= ca * nSamples Then
' Volume = Volume + CEnvelopeInc
' ElseIf i < cd * nSamples Then
' Volume = Volume - CEnvelopeDecD
' ElseIf i < CS * nSamples Then
' ElseIf i < cr * nSamples Then
' Volume = Volume - CEnvelopeDecR
' End If
'
' If i <= Ma * nSamples Then
' Mamp = Mamp + MEnvelopeInc
' ElseIf i < md * nSamples Then
' Mamp = Mamp - MEnvelopeDecD
' ElseIf i < MS * nSamples Then
' ElseIf i < mr * nSamples Then
' Mamp = Mamp - MEnvelopeDecR
' End If
'
' Modulator = Cos(Pi2 / _SndRate * i * MFrequency + ModStart) * Mamp
' Waveform = Sin(Pi2 / _SndRate * i * Frequency + Modulator) * Volume
'
' _SndRaw Amplitude * Waveform
' Next
' Do: Loop While _SndRawLen
'End Sub ' FM_Sound_v1
'
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n As Integer
Dim num$
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
Function IsNum% (text$)
Dim a$
Dim b$
a$ = _Trim$(text$)
b$ = _Trim$(Str$(Val(text$)))
If a$ = b$ Then
IsNum% = TRUE
Else
IsNum% = FALSE
End If
End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
' iRow% and iCol% are 0-based in this version
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
'x = 1: y = 2: z$ = "Three"
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
'PRINT "File created with data. Press a key!"
'K$ = INPUT$(1) 'press a key
'OPEN sFileName FOR INPUT AS #2 ' opens a file to read it
'INPUT #2, a, b, c$
'CLOSE #2
'PRINT a, b, c$
'WRITE a, b, c$
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
Function SingleABS! (sngValue As Single)
If Sgn(sngValue) = -1 Then
SingleABS! = 0 - sngValue
Else
SingleABS! = sngValue
End If
End Function ' SingleABS!
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub DebugPrint (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
Sub DebugPrintString (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
m_iDebugCount = m_iDebugCount + 1
_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrintString
Sub DebugDumpVarInt (iLineNum As Integer, sVarName As String, myFinalValue As Integer)
If m_bDebug = TRUE Then
m_iDebugCount = m_iDebugCount + 1
_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + _
"{t}" + _
_Trim$(Str$(iLineNum)) + "{t}" + _
"Integer" + "{t}" + _
sVarName + "{t}" + _
_Trim$(Str$(myFinalValue))
End If
End Sub ' DebugDumpVarInt
Sub DebugDumpVarLng (iLineNum As Integer, sVarName As String, myFinalValue As Long)
If m_bDebug = TRUE Then
m_iDebugCount = m_iDebugCount + 1
_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + _
"{t}" + _
_Trim$(Str$(iLineNum)) + "{t}" + _
"Long" + "{t}" + _
sVarName + "{t}" + _
_Trim$(Str$(myFinalValue))
End If
End Sub ' DebugDumpVarLng
Sub DebugDumpVarSng (iLineNum As Integer, sVarName As String, myFinalValue As Single)
If m_bDebug = TRUE Then
m_iDebugCount = m_iDebugCount + 1
_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + _
"{t}" + _
_Trim$(Str$(iLineNum)) + "{t}" + _
"Single" + "{t}" + _
sVarName + "{t}" + _
SngToStr$(myFinalValue)
End If
End Sub ' DebugDumpVarSng
Sub DebugDumpVarDbl (iLineNum As Integer, sVarName As String, myFinalValue As Double)
If m_bDebug = TRUE Then
m_iDebugCount = m_iDebugCount + 1
_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + _
"{t}" + _
_Trim$(Str$(iLineNum)) + "{t}" + _
"Double" + "{t}" + _
sVarName + "{t}" + _
DblToStr$(myFinalValue)
End If
End Sub ' DebugDumpVarDbl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub InitDebugFile
If m_bDebug = TRUE Then
Dim sError As String
sError = PrintFile$(m_DebugFile$, _
"Count" + chr$(9) + _
"Line" + chr$(9) + _
"Type" + chr$(9) + _
"Variable" + chr$(9) + _
"Value" + chr$(9) + _
"Comment", _
FALSE)
End If
End Sub ' DebugFileString
Sub DebugFileString (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
Dim sError As String
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
m_iDebugCount = m_iDebugCount + 1
'_Echo _Trim$(Str$(m_iDebugCount)) + "{t}" + arrLines(iLoop)
sError = PrintFile$(m_DebugFile$, _
_Trim$(Str$(m_iDebugCount)) + chr$(9) + _
chr$(9) + _
chr$(9) + _
chr$(9) + _
chr$(9) + _
arrLines(iLoop), _
TRUE)
Next iLoop
End If
End Sub ' DebugFileString
Sub DebugFileVarInt (iLineNum As Integer, sVarName As String, myFinalValue As Integer)
If m_bDebug = TRUE Then
Dim sError As String
m_iDebugCount = m_iDebugCount + 1
sError = PrintFile$(m_DebugFile$, _
_Trim$(Str$(m_iDebugCount)) + chr$(9) + _
chr$(9) + _
_Trim$(Str$(iLineNum)) + chr$(9) + _
"Integer" + chr$(9) + _
sVarName + chr$(9) + _
_Trim$(Str$(myFinalValue)), _
TRUE)
End If
End Sub ' DebugFileVarInt
Sub DebugFileVarLng (iLineNum As Integer, sVarName As String, myFinalValue As Long)
If m_bDebug = TRUE Then
Dim sError As String
m_iDebugCount = m_iDebugCount + 1
sError = PrintFile$(m_DebugFile$, _
_Trim$(Str$(m_iDebugCount)) + chr$(9) + _
chr$(9) + _
_Trim$(Str$(iLineNum)) + chr$(9) + _
"Long" + chr$(9) + _
sVarName + chr$(9) + _
_Trim$(Str$(myFinalValue)), _
TRUE)
End If
End Sub ' DebugFileVarLng
Sub DebugFileVarSng (iLineNum As Integer, sVarName As String, myFinalValue As Single)
If m_bDebug = TRUE Then
Dim sError As String
m_iDebugCount = m_iDebugCount + 1
sError = PrintFile$(m_DebugFile$, _
_Trim$(Str$(m_iDebugCount)) + chr$(9) + _
chr$(9) + _
_Trim$(Str$(iLineNum)) + chr$(9) + _
"Single" + chr$(9) + _
sVarName + chr$(9) + _
SngToStr$(myFinalValue), _
TRUE)
End If
End Sub ' DebugFileVarSng
Sub DebugFileVarDbl (iLineNum As Integer, sVarName As String, myFinalValue As Double)
If m_bDebug = TRUE Then
Dim sError As String
m_iDebugCount = m_iDebugCount + 1
sError = PrintFile$(m_DebugFile$, _
_Trim$(Str$(m_iDebugCount)) + chr$(9) + _
chr$(9) + _
_Trim$(Str$(iLineNum)) + chr$(9) + _
"Double" + chr$(9) + _
sVarName + chr$(9) + _
DblToStr$(myFinalValue), _
TRUE)
End If
End Sub ' DebugFileVarDbl
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++