Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
neat _SndRaw example, but how do you stop _SndRaw from playing?
#11
(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                              1

Other 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Attached Files
.zip   program_fm_v16.zip (Size: 3.05 MB / Downloads: 34)
Reply




Users browsing this thread: 1 Guest(s)