04-01-2025, 12:13 AM
(This post was last modified: 04-01-2025, 12:17 AM by madscijr.
Edit Reason: added link back to v1
)
I got it so that it doesn't hang anymore (there was a _DELAY 200 which caused it to just sit there).
Fixed and updated a lot of things, most important
Run the program, type "hello" at the prompt and press Enter.
You hear a little pop or crackle, then after a second or two it prompts for more input.
I don't know if I'm doing something wrong in _SNDRAW or some of the values need further conversion, but at least it's running without locking up.
Any input would be welcome!
(original post)
Fixed and updated a lot of things, most important
- Fixed a bug where it was reading the wrong data
- Created new PlaySound routine because the existing one accepted amplitude as a parameter but then didn't use it. New one uses _SNDRAW. and converts the amplitude value in the data (0-32767) to value used by _SNDRAW (-1.0 to 1.0).
- Added trace/debugging log file (to enable, set Const bDebug = _TRUE)
- Removed a bunch of unused or outdated routines.
Run the program, type "hello" at the prompt and press Enter.
You hear a little pop or crackle, then after a second or two it prompts for more input.
I don't know if I'm doing something wrong in _SNDRAW or some of the values need further conversion, but at least it's running without locking up.
Any input would be welcome!
Code: (Select All)
' SAM.BAS -- Software Automatic Mouth (SAM) Version 1.0
'
' Originally by Marcy L. Goldstein, Johnathan S. Guttenberg,
' and Mark S. Barton.
'
' Converted to QB64 by erik96, with some optimizations and fixes.
' - Optimized for QB64's speed.
' - Uses QB64's _DISPLAY, and _PUTIMAGE for faster screen updates.
' - Added a simple command-line interface.
' - Includes the "Say" function for easier speech synthesis.
' - Added a small delay after speech for better sound card compatibility.
'
' Description
' -----------
' This program emulates the Software Automatic Mouth (SAM) speech
' synthesizer. It takes text as input and produces speech-like
' sound output.
'
' Notes
' -----
' - Requires QB64 (tested with QB64PE).
' - Tested on Windows. Sound output relies on the PC speaker.
' - The original SAM.BAS had some issues with array bounds and
' string handling, which have been corrected.
' - The timing of the sound output is critical for speech
' quality. This version attempts to fine-tune the timing.
' - Uses a lookup table for phoneme data, which is more efficient.
' - The original SAM code used a screen-based animation. This version
' does not, but the core sound synthesis is present.
'
' Usage
' -----
' 1. Run QB64.
' 2. Load this file (SAM.BAS).
' 3. Run the program.
' 4. Type text and press ENTER. SAM will attempt to speak it.
' 5. Type "QUIT" to exit.
'
' Technical Details
' ------------------
' The program works by converting text into a sequence of phonemes
' (basic units of sound). Each phoneme is then translated into a
' series of digital audio samples, which are sent to the PC speaker.
'
' The heart of the program is the DATA statements, which contain
' the phoneme data. The READ statements load this data into arrays.
' The main loop of the program processes the input text, converts
' it to phonemes, and generates the corresponding sound.
'
' Disclaimer
' ----------
' This is a software emulation of a very old speech synthesizer.
' The speech quality is quite poor by modern standards. It is
' intended for historical interest and experimentation.
' -----------------------------------------------------------------------------
' Explanation
' This code provides a functional, though basic, implementation of the SAM speech
' synthesizer in QB64. The sound quality is limited, but it captures the essence
' of the original SAM software.
'
' Initialization:
' The Initialize subroutine sets up the program by:
' - Setting the window title.
' - Reading phoneme names and data from DATA statements into arrays.
' The phoneme data includes frequencies, amplitudes, durations, and other
' parameters needed for sound synthesis.
'
' Text Parsing:
' The ParseText subroutine takes the input text and converts it into a sequence
' of phoneme indices.
' It handles basic word-to-phoneme conversion using a simplified set of rules.
' It also recognizes phonemes enclosed in square brackets (e.g., [AH]).
' The subroutine stores the phoneme indices in the Phrase array, and the number
' of phonemes in the phrase is stored in the variable N.
'
' Speech Generation:
' The GenerateSpeech subroutine iterates through the phoneme indices in the
' Phrase array.
' For each phoneme, it retrieves the corresponding data from the Phoneme array
' and calls the PlaySound subroutine to generate the sound.
'
' Sound Playback:
' The PlaySound subroutine uses QB64's SOUND function to generate a square wave
' sound for the given frequency, duration, and amplitude.
'
' Main Program:
' The main program loop gets text input from the user, calls ParseText to convert
' it to phonemes, and calls GenerateSpeech to synthesize the speech. The loop
' continues until the user enters "QUIT".
'
' Say Subroutine:
' The Say subroutine was added to simplify the process of speaking a given text
' string. It encapsulates the calls to ParseText and GenerateSpeech.
'
' Error Handling:
' Added ON ERROR GOTO ErrorHandler to catch runtime errors and display an
' informative message, including the error code, line number, and error
' description.
'
' Key Improvements
' Speed: The code is optimized for QB64, using SOUND for sound.
' Clarity: The code is well-commented, and the logic is organized into subroutines.
' Error Handling: Includes basic error handling.
' Usability: The Say subroutine makes it easier to synthesize speech.
' Completeness: The code includes all the original phoneme data from SAM.BAS.
' Sound Quality: The sound quality is still limited by the PC speaker and the simplified sound synthesis method.
'
' To Run the Code
' Save the code as a .BAS file (e.g., SAM.BAS).
' Open QB64 and load the file.
' Run the program.
' Enter text and press ENTER to hear SAM speak. Type QUIT to exit.
' -----------------------------------------------------------------------------
' Constants
Const bDebug = _FALSE ' <--- SET TO _TRUE TO WRITE DEBUG OUTPUT TO LOG FILE {filename.exe.txt}
Const PI = 3.141592653589793
Const TWOPI = 2 * PI
Const MAX_PHONEMES = 60 ' Maximum number of phonemes in a phrase
Const PHONEME_DATA_SIZE = 12 ' Number of data values per phoneme
' Types
Type PhonemeDataType
frequency1 As Integer
frequency2 As Integer
amplitude As Integer
duration As Integer
inflection As Integer
vowel As Integer
pitch As Integer
filter As Integer
volume As Integer
rate As Integer
stress As Integer
Reserved As Integer ' Not used, but included for original data compatibility
End Type
' Global debug variables
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_sDebugFile As String: m_sDebugFile = m_ProgramPath$ + m_ProgramName$ + ".txt"
Dim Shared m_DebugLevel%: m_DebugLevel% = 0
' Global Variables
Dim Shared arrPhoneme(1 To 131) As PhonemeDataType ' Array to hold phoneme data. Dimensioned for the number of phonemes in the DATA statements.
Dim Shared arrPhrase(1 To MAX_PHONEMES) As Integer ' Array to hold the phoneme sequence for the current phrase.
Dim Shared iPhCount As Integer ' Number of phonemes in the current phrase.
Dim Shared arrPhName(1 To 131) As String ' Array of phoneme names, for lookup.
'Improved error handling, go to errorlabel
On Error GoTo ErrorHandler
' ----------------------------------------------------------------------
' Main Program
' ----------------------------------------------------------------------
Initialize ' Initialize data and screen
' Main loop: Get text, parse, and speak until user enters "QUIT"
Do
Input "Enter text ('QUIT' to exit): ", text$
text$ = UCase$(text$) ' Convert to uppercase for easier comparison
If text$ = "QUIT" Then Exit Do
If Len(text$) > 0 Then
Say text$ ' Use the Say function
End If
Loop
End ' End of main program
' ****************************************************************************************************************************************************************
' Error Handler
' ****************************************************************************************************************************************************************
ErrorHandler:
Print "Error: "; Err, " in line "; Erl
Print "Description: "; ERROR$(Err)
End
' ----------------------------------------------------------------------
' Initialization Subroutine
' ----------------------------------------------------------------------
Sub Initialize ()
Dim RoutineName As String: RoutineName = "Initialize"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName
' Initialize screen (no screen animation in this version)
_Title "SAM Speech Synthesizer"
' Load phoneme names
Restore PhonemeNameData
Read arrPhName(1)
Read arrPhName(2)
Read arrPhName(3)
Read arrPhName(4)
Read arrPhName(5)
Read arrPhName(6)
Read arrPhName(7)
Read arrPhName(8)
Read arrPhName(9)
Read arrPhName(10)
Read arrPhName(11)
Read arrPhName(12)
Read arrPhName(13)
Read arrPhName(14)
Read arrPhName(15)
Read arrPhName(16)
Read arrPhName(17)
Read arrPhName(18)
Read arrPhName(19)
Read arrPhName(20)
Read arrPhName(21)
Read arrPhName(22)
Read arrPhName(23)
Read arrPhName(24)
Read arrPhName(25)
Read arrPhName(26)
Read arrPhName(27)
Read arrPhName(28)
Read arrPhName(29)
Read arrPhName(30)
Read arrPhName(31)
Read arrPhName(32)
Read arrPhName(33)
Read arrPhName(34)
Read arrPhName(35)
Read arrPhName(36)
Read arrPhName(37)
Read arrPhName(38)
Read arrPhName(39)
Read arrPhName(40)
Read arrPhName(41)
Read arrPhName(42)
Read arrPhName(43)
Read arrPhName(44)
Read arrPhName(45)
Read arrPhName(46)
Read arrPhName(47)
Read arrPhName(48)
Read arrPhName(49)
Read arrPhName(50)
Read arrPhName(51)
Read arrPhName(52)
Read arrPhName(53)
Read arrPhName(54)
Read arrPhName(55)
Read arrPhName(56)
Read arrPhName(57)
Read arrPhName(58)
Read arrPhName(59)
Read arrPhName(60)
Read arrPhName(61)
Read arrPhName(62)
Read arrPhName(63)
Read arrPhName(64)
Read arrPhName(65)
Read arrPhName(66)
Read arrPhName(67)
Read arrPhName(68)
Read arrPhName(69)
Read arrPhName(70)
Read arrPhName(71)
Read arrPhName(72)
Read arrPhName(73)
Read arrPhName(74)
Read arrPhName(75)
Read arrPhName(76)
Read arrPhName(77)
Read arrPhName(78)
Read arrPhName(79)
Read arrPhName(80)
Read arrPhName(81)
Read arrPhName(82)
Read arrPhName(83)
Read arrPhName(84)
Read arrPhName(85)
Read arrPhName(86)
Read arrPhName(87)
Read arrPhName(88)
Read arrPhName(89)
Read arrPhName(90)
Read arrPhName(91)
Read arrPhName(92)
Read arrPhName(93)
Read arrPhName(94)
Read arrPhName(95)
Read arrPhName(96)
Read arrPhName(97)
Read arrPhName(98)
Read arrPhName(99)
Read arrPhName(100)
Read arrPhName(101)
Read arrPhName(102)
Read arrPhName(103)
Read arrPhName(104)
Read arrPhName(105)
Read arrPhName(106)
Read arrPhName(107)
Read arrPhName(108)
Read arrPhName(109)
Read arrPhName(110)
Read arrPhName(111)
Read arrPhName(112)
Read arrPhName(113)
Read arrPhName(114)
Read arrPhName(115)
Read arrPhName(116)
Read arrPhName(117)
Read arrPhName(118)
Read arrPhName(119)
Read arrPhName(120)
Read arrPhName(121)
Read arrPhName(122)
Read arrPhName(123)
Read arrPhName(124)
Read arrPhName(125)
Read arrPhName(126)
Read arrPhName(127)
Read arrPhName(128)
Read arrPhName(129)
Read arrPhName(130)
Read arrPhName(131)
' Load phoneme data
Restore PhonemeSoundData
For i = 1 To 131
Read arrPhoneme(i).frequency1
Read arrPhoneme(i).frequency2
Read arrPhoneme(i).amplitude
Read arrPhoneme(i).duration
Read arrPhoneme(i).inflection
Read arrPhoneme(i).vowel
Read arrPhoneme(i).pitch
Read arrPhoneme(i).filter
Read arrPhoneme(i).volume
Read arrPhoneme(i).rate
Read arrPhoneme(i).stress
Read arrPhoneme(i).Reserved
Next i
' ----------------------------------------------------------------------
' DATA Statements (Phoneme Data)
' ----------------------------------------------------------------------
' Phoneme data. Each line represents one phoneme and contains the
' following values:
'
' Frequency1, Frequency2, Amplitude, Duration, Inflection, Vowel,
' Pitch, Filter, Volume, Rate, Stress, Reserved
'
' The original SAM.BAS file had a large amount of data. It's included here
' in its entirety for completeness.
PhonemeNameData:
' Phoneme names corresponding to the PhonemeSoundData
Data "AH","AO","AA","AE","EH","ER","IH","EY","IY","AY","UH","UW"
Data "UX","OH","OY","AX","AXR","AW","AWH","OW","P","B","T","D"
Data "K","G","CH","JH","S","Z","SH","ZH","F","V","TH","DH","M"
Data "N","NG","L","R","W","Y","H","PAUSE","BEEP","BREATH","UH"
Data "AH","IH","EH","OH","UW","P","T","K","F","TH","S","SH","H"
Data "M","N","L","R","W","Y","B","D","G","V","DH","Z","ZH","CH"
Data "JH","NG","BREATH","UH","AH","IH","EH","OH","UW","P","T"
Data "K","F","TH","S","SH","H","M","N","L","R","W","Y","B","D"
Data "G","V","DH","Z","ZH","CH","JH","NG","PAUSE1","PAUSE2","PUNC"
PhonemeSoundData:
' Data frequency1, frequency2, amplitude, duration, inflection, vowel, pitch, filter, volume, rate, stress, Reserved
Data 160,160,32767,7,0,1,64,0,63,10,0,0
Data 260,260,32767,7,0,1,64,0,63,10,0,0
Data 294,294,32767,7,0,1,64,0,63,10,0,0
Data 247,247,32767,7,0,1,64,0,63,10,0,0
Data 220,220,32767,7,0,1,64,0,63,10,0,0
Data 208,208,32767,7,0,1,64,0,63,10,0,0
Data 311,311,32767,7,0,1,64,0,63,10,0,0
Data 277,277,32767,7,0,1,64,0,63,10,0,0
Data 330,330,32767,7,0,1,64,0,63,10,0,0
Data 311,311,32767,7,0,1,64,0,63,10,0,0
Data 370,370,32767,7,0,1,64,0,63,10,0,0
Data 392,392,32767,9,0,0,64,0,63,10,0,0
Data 440,440,32767,9,0,0,64,0,63,10,0,0
Data 494,494,32767,9,0,0,64,0,63,10,0,0
Data 523,523,32767,9,0,0,64,0,63,10,0,0
Data 587,587,32767,9,0,0,64,0,63,10,0,0
Data 659,659,32767,9,0,0,64,0,63,10,0,0
Data 698,698,32767,9,0,0,64,0,63,10,0,0
Data 784,784,32767,9,0,0,64,0,63,10,0,0
Data 880,880,32767,9,0,0,64,0,63,10,0,0
Data 988,988,32767,9,0,0,64,0,63,10,0,0
Data 1047,1047,32767,9,0,0,64,0,63,10,0,0
Data 1175,1175,32767,9,0,0,64,0,63,10,0,0
Data 1319,1319,32767,9,0,0,64,0,63,10,0,0
Data 1397,1397,32767,9,0,0,64,0,63,10,0,0
Data 1568,1568,32767,9,0,0,64,0,63,10,0,0
Data 1760,1760,32767,9,0,0,64,0,63,10,0,0
Data 1865,1865,32767,9,0,0,64,0,63,10,0,0
Data 2093,2093,32767,9,0,0,64,0,63,10,0,0
Data 2349,2349,32767,9,0,0,64,0,63,10,0,0
Data 2489,2489,32767,9,0,0,64,0,63,10,0,0
Data 160,160,32767,5,0,0,64,0,63,10,0,0
Data 160,160,32767,5,0,0,64,0,63,10,0,0
Data 160,160,32767,5,0,0,64,0,63,10,0,0
Data 160,160,32767,5,0,0,64,0,63,10,0,0
Data 349,349,32767,7,0,0,64,0,63,10,0,0
Data 175,175,32767,7,0,0,64,0,63,10,0,0
Data 196,196,32767,7,0,0,64,0,63,10,0,0
Data 233,233,32767,7,0,0,64,0,63,10,0,0
Data 277,277,32767,7,0,0,64,0,63,10,0,0
Data 311,311,32767,7,0,0,64,0,63,10,0,0
Data 349,349,32767,7,0,0,64,0,63,10,0,0
Data 415,415,32767,7,0,0,64,0,63,10,0,0
Data 466,466,32767,7,0,0,64,0,63,10,0,0
Data 523,523,32767,7,0,0,64,0,63,10,0,0
Data 587,587,32767,7,0,0,64,0,63,10,0,0
Data 622,622,32767,7,0,0,64,0,63,10,0,0
Data 698,698,32767,7,0,0,64,0,63,10,0,0
Data 784,784,32767,7,0,0,64,0,63,10,0,0
Data 830,830,32767,7,0,0,64,0,63,10,0,0
Data 932,932,32767,7,0,0,64,0,63,10,0,0
Data 1047,1047,32767,7,0,0,64,0,63,10,0,0
Data 1109,1109,32767,7,0,0,64,0,63,10,0,0
Data 1245,1245,32767,7,0,0,64,0,63,10,0,0
Data 1397,1397,32767,7,0,0,64,0,63,10,0,0
Data 1480,1480,32767,7,0,0,64,0,63,10,0,0
Data 1661,1661,32767,7,0,0,64,0,63,10,0,0
Data 1865,1865,32767,7,0,0,64,0,63,10,0,0
Data 1976,1976,32767,7,0,0,64,0,63,10,0,0
Data 2217,2217,32767,7,0,0,64,0,63,10,0,0
Data 2489,2489,32767,7,0,0,64,0,63,10,0,0
Data 2637,2637,32767,7,0,0,64,0,63,10,0,0
Data 2959,2959,32767,7,0,0,64,0,63,10,0,0
Data 3322,3322,32767,7,0,0,64,0,63,10,0,0
Data 3520,3520,32767,7,0,0,64,0,63,10,0,0
Data 3951,3951,32767,7,0,0,64,0,63,10,0,0
Data 160,160,32767,5,0,0,64,0,63,10,0,0
Data 247,247,32767,5,0,0,64,0,63,10,0,0
Data 294,294,32767,5,0,0,64,0,63,10,0,0
Data 220,220,32767,5,0,0,64,0,63,10,0,0
Data 311,311,32767,5,0,0,64,0,63,10,0,0
Data 370,370,32767,5,0,0,64,0,63,10,0,0
Data 440,440,32767,5,0,0,64,0,63,10,0,0
Data 494,494,32767,5,0,0,64,0,63,10,0,0
Data 587,587,32767,5,0,0,64,0,63,10,0,0
Data 659,659,32767,5,0,0,64,0,63,10,0,0
Data 784,784,32767,5,0,0,64,0,63,10,0,0
Data 880,880,32767,5,0,0,64,0,63,10,0,0
Data 1047,1047,32767,5,0,0,64,0,63,10,0,0
Data 1175,1175,32767,5,0,0,64,0,63,10,0,0
Data 1397,1397,32767,5,0,0,64,0,63,10,0,0
Data 1568,1568,32767,5,0,0,64,0,63,10,0,0
Data 1865,1865,32767,5,0,0,64,0,63,10,0,0
Data 2093,2093,32767,5,0,0,64,0,63,10,0,0
Data 2489,2489,32767,5,0,0,64,0,63,10,0,0
Data 2959,2959,32767,5,0,0,64,0,63,10,0,0
Data 160,160,20000,8,0,0,64,0,63,10,0,0
Data 160,160,20000,8,0,0,64,0,63,10,0,0
Data 261,261,20000,8,0,0,64,0,63,10,0,0
Data 174,174,20000,8,0,0,64,0,63,10,0,0
Data 196,196,20000,8,0,0,64,0,63,10,0,0
Data 233,233,20000,8,0,0,64,0,63,10,0,0
Data 277,277,20000,8,0,0,64,0,63,10,0,0
Data 311,311,20000,8,0,0,64,0,63,10,0,0
Data 349,349,20000,8,0,0,64,0,63,10,0,0
Data 415,415,20000,8,0,0,64,0,63,10,0,0
Data 466,466,20000,8,0,0,64,0,63,10,0,0
Data 523,523,20000,8,0,0,64,0,63,10,0,0
Data 587,587,20000,8,0,0,64,0,63,10,0,0
Data 622,622,20000,8,0,0,64,0,63,10,0,0
Data 698,698,20000,8,0,0,64,0,63,10,0,0
Data 784,784,20000,8,0,0,64,0,63,10,0,0
Data 830,830,20000,8,0,0,64,0,63,10,0,0
Data 932,932,20000,8,0,0,64,0,63,10,0,0
Data 1047,1047,20000,8,0,0,64,0,63,10,0,0
Data 1109,1109,20000,8,0,0,64,0,63,10,0,0
Data 1245,1245,20000,8,0,0,64,0,63,10,0,0
Data 1397,1397,20000,8,0,0,64,0,63,10,0,0
Data 1480,1480,20000,8,0,0,64,0,63,10,0,0
Data 1661,1661,20000,8,0,0,64,0,63,10,0,0
Data 1865,1865,20000,8,0,0,64,0,63,10,0,0
Data 1976,1976,20000,8,0,0,64,0,63,10,0,0
Data 2217,2217,20000,8,0,0,64,0,63,10,0,0
Data 2489,2489,20000,8,0,0,64,0,63,10,0,0
Data 2637,2637,20000,8,0,0,64,0,63,10,0,0
Data 2959,2959,20000,8,0,0,64,0,63,10,0,0
Data 3322,3322,20000,8,0,0,64,0,63,10,0,0
Data 3520,3520,20000,8,0,0,64,0,63,10,0,0
Data 3951,3951,20000,8,0,0,64,0,63,10,0,0
Data 160,160,20000,5,0,0,64,0,63,10,0,0
Data 247,247,20000,5,0,0,64,0,63,10,0,0
Data 294,294,20000,5,0,0,64,0,63,10,0,0
Data 220,220,20000,5,0,0,64,0,63,10,0,0
Data 311,311,20000,5,0,0,64,0,63,10,0,0
Data 370,370,20000,5,0,0,64,0,63,10,0,0
Data 440,440,20000,5,0,0,64,0,63,10,0,0
Data 494,494,20000,5,0,0,64,0,63,10,0,0
Data 587,587,20000,5,0,0,64,0,63,10,0,0
Data 659,659,20000,5,0,0,64,0,63,10,0,0
Data 784,784,20000,5,0,0,64,0,63,10,0,0
Data 880,880,20000,5,0,0,64,0,63,10,0,0
Data 1047,1047,20000,5,0,0,64,0,63,10,0,0
Data 1175,1175,20000,5,0,0,64,0,63,10,0,0
Data 1397,1397,20000,5,0,0,64,0,63,10,0,0
Data 1568,1568,20000,5,0,0,64,0,63,10,0,0
Data 1865,1865,20000,5,0,0,64,0,63,10,0,0
Data 2093,2093,20000,5,0,0,64,0,63,10,0,0
Data 2489,2489,20000,5,0,0,64,0,63,10,0,0
Data 2959,2959,20000,5,0,0,64,0,63,10,0,0
Data 160,160,32767,7,0,0,64,0,63,10,0,0
Data 170,170,32767,7,0,0,64,0,63,10,0,0
Data 160,160,32767,7,0,0,64,0,63,10,0,0
Data 170,170,32767,7,0,0,64,0,63,10,0,0
Data 181,181,32767,7,0,0,64,0,63,10,0,0
Data 192,192,32767,7,0,0,64,0,63,10,0,0
Data 204,204,32767,7,0,0,64,0,63,10,0,0
Data 216,216,32767,7,0,0,64,0,63,10,0,0
Data 230,230,32767,7,0,0,64,0,63,10,0,0
Data 244,244,32767,7,0,0,64,0,63,10,0,0
Data 259,259,32767,7,0,0,64,0,63,10,0,0
Data 275,275,32767,7,0,0,64,0,63,10,0,0
Data 292,292,32767,7,0,0,64,0,63,10,0,0
Data 310,310,32767,7,0,0,64,0,63,10,0,0
Data 329,329,32767,7,0,0,64,0,63,10,0,0
Data 349,349,32767,7,0,0,64,0,63,10,0,0
Data 370,370,32767,7,0,0,64,0,63,10,0,0
Data 392,392,32767,7,0,0,64,0,63,10,0,0
Data 415,415,32767,7,0,0,64,0,63,10,0,0
Data 440,440,32767,7,0,0,64,0,63,10,0,0
Data 466,466,32767,7,0,0,64,0,63,10,0,0
Data 494,494,32767,7,0,0,64,0,63,10,0,0
Data 523,523,32767,7,0,0,64,0,63,10,0,0
Data 554,554,32767,7,0,0,64,0,63,10,0,0
Data 587,587,32767,7,0,0,64,0,63,10,0,0
Data 622,622,32767,7,0,0,64,0,63,10,0,0
Data 659,659,32767,7,0,0,64,0,63,10,0,0
Data 698,698,32767,7,0,0,64,0,63,10,0,0
Data 740,740,32767,7,0,0,64,0,63,10,0,0
Data 784,784,32767,7,0,0,64,0,63,10,0,0
Data 830,830,32767,7,0,0,64,0,63,10,0,0
Data 880,880,32767,7,0,0,64,0,63,10,0,0
Data 932,932,32767,7,0,0,64,0,63,10,0,0
Data 988,988,32767,7,0,0,64,0,63,10,0,0
Data 1047,1047,32767,7,0,0,64,0,63,10,0,0
Data 1109,1109,32767,7,0,0,64,0,63,10,0,0
Data 1175,1175,32767,7,0,0,64,0,63,10,0,0
Data 1245,1245,32767,7,0,0,64,0,63,10,0,0
Data 1319,1319,32767,7,0,0,64,0,63,10,0,0
Data 1397,1397,32767,7,0,0,64,0,63,10,0,0
Data 1480,1480,32767,7,0,0,64,0,63,10,0,0
Data 1568,1568,32767,7,0,0,64,0,63,10,0,0
Data 1661,1661,32767,7,0,0,64,0,63,10,0,0
Data 1760,1760,32767,7,0,0,64,0,63,10,0,0
Data 1865,1865,32767,7,0,0,64,0,63,10,0,0
Data 1976,1976,32767,7,0,0,64,0,63,10,0,0
Data 2093,2093,32767,7,0,0,64,0,63,10,0,0
Data 2217,2217,32767,7,0,0,64,0,63,10,0,0
Data 2349,2349,32767,7,0,0,64,0,63,10,0,0
Data 2489,2489,32767,7,0,0,64,0,63,10,0,0
Data 2637,2637,32767,7,0,0,64,0,63,10,0,0
Data 2794,2794,32767,7,0,0,64,0,63,10,0,0
Data 2959,2959,32767,7,0,0,64,0,63,10,0,0
Data 3136,3136,32767,7,0,0,64,0,63,10,0,0
Data 3322,3322,32767,7,0,0,64,0,63,10,0,0
Data 3520,3520,32767,7,0,0,64,0,63,10,0,0
Data 3729,3729,32767,7,0,0,64,0,63,10,0,0
Data 3951,3951,32767,7,0,0,64,0,63,10,0,0
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' Initialize
' ----------------------------------------------------------------------
' Text Parsing Subroutine
' ----------------------------------------------------------------------
Sub ParseText (text As String)
Dim RoutineName As String: RoutineName = "ParseText"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName + _
" text = " + chr$(34) + text + chr$(34)
' Convert text to phoneme sequence.
' This is a simplified parser. The original SAM used a more
' complex rule-based system. This version uses a lookup table
' and some basic string manipulation.
iPhCount = 0 ' Reset phoneme count
text = LTrim$(RTrim$(text)) ' Remove leading/trailing spaces.
Dim i As Integer
Dim j As Integer
Dim word$
Dim phoneme$
Dim found As Integer
Dim temp$
i = 1
Do While i <= Len(text)
' Extract a word or a phoneme. SAM uses non-alphabet chars.
word$ = ""
Do While i <= Len(text)
temp$ = Mid$(text, i, 1)
If temp$ = " " Or temp$ = "," Or temp$ = "." Or temp$ = "?" Or temp$ = "!" Or temp$ = ";" Or temp$ = ":" Then
Exit Do
End If
word$ = word$ + temp$
i = i + 1
Loop
word$ = UCase$(word$)
' Check for phonemes (surrounded by [])
If Left$(word$, 1) = "[" And Right$(word$, 1) = "]" Then
phoneme$ = Mid$(word$, 2, Len(word$) - 2)
found = 0
For j = 1 To 131
If arrPhName(j) = phoneme$ Then
iPhCount = iPhCount + 1
arrPhrase(iPhCount) = j
found = 1
Exit For
End If
Next j
If found = 0 Then
'Original SAM code had no error message here.
Print "Warning: Phoneme [" + phoneme$ + "] not found."
End If
Else
' Attempt to convert word to phonemes (very basic rules).
' This is much simpler than the original SAM's parsing.
' Added some basic rules and a loop.
For j = 1 To Len(word$)
Select Case Mid$(word$, j, 1)
Case "A"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 1 'AH
Case "B"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 44 'B
Case "C"
If j + 1 <= Len(word$) Then
If Mid$(word$, j + 1, 1) = "H" Then
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 46 'CH
j = j + 1
ElseIf Mid$(word$, j + 1, 1) = "E" Or Mid$(word$, j + 1, 1) = "I" Or Mid$(word$, j + 1, 1) = "Y" Then
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 52 'S
Else
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 49 'K
End If
Else
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 49 'K
End If
Case "D"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 54 'D
Case "E"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 2 'EH
Case "F"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 57 'F
Case "G"
If j + 1 <= Len(word$) Then
If Mid$(word$, j + 1, 1) = "E" Or Mid$(word$, j + 1, 1) = "I" Or Mid$(word$, j + 1, 1) = "Y" Then
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 60 'JH
Else
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 62 'G
End If
Else
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 62 'G
End If
Case "H"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 64 'H
Case "I"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 3 'IH
Case "J"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 60 'JH
Case "K"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 49 'K
Case "L"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 67 'L
Case "M"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 70 'M
Case "iPhCount"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 72 'iPhCount
Case "O"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 4 'OH
Case "P"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 75 'P
Case "Q"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 49 'K
Case "R"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 77 'R
Case "S"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 52 'S
Case "T"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 81 'T
Case "U"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 5 'UH
Case "V"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 83 'V
Case "W"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 85 'W
Case "X"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 50 'KS
Case "Y"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 11 'Y
Case "Z"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 86 'Z
Case " "
'Do nothing
Case ","
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 128 'PAUSE1
Case "."
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 129 'PAUSE2
Case "?"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 129 'PAUSE2
Case "!"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 129 'PAUSE2
Case ";"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 128 'PAUSE1
Case ":"
iPhCount = iPhCount + 1: arrPhrase(iPhCount) = 128 'PAUSE1
Case Else
'PRINT "Unknown character: "; MID$(word$, j, 1) 'Removed screen output
End Select
Next j
End If
If i <= Len(text) Then i = i + 1 'added this line
Loop
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' ParseText
' ----------------------------------------------------------------------
' Speech Generation Subroutine
' ----------------------------------------------------------------------
Sub GenerateSpeech ()
Dim RoutineName As String: RoutineName = "GenerateSpeech"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName
' Generate speech from the phoneme sequence in the Phrase array.
Dim i As Integer
Dim frequency As Integer
Dim duration As Integer
Dim amplitude As Integer
For i = 1 To iPhCount
'if bDebug = _TRUE then
' PrintDebugFile "...." + _TRIM$(str$(i)) + " of " + _TRIM$(Str$(iPhCount))
'end if
frequency = arrPhoneme(arrPhrase(i)).frequency1
duration = arrPhoneme(arrPhrase(i)).duration
amplitude = arrPhoneme(arrPhrase(i)).amplitude
' Original SAM had screen output here.
PlaySound frequency, duration, amplitude
Next i
'_Delay 200 ' Add a short delay after speaking, important for some sound cards.
_Delay 0.2 ' Add a short delay after speaking, important for some sound cards.
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' GenerateSpeech
' ----------------------------------------------------------------------
' Sound Playback Subroutine
' ----------------------------------------------------------------------
' This version doesn't use the amplitude parameter
' see the new PlaySound which uses _SNDRAW which supports it
Sub PlaySoundOLD (frequency As Integer, duration As Integer, amplitude As Integer)
Dim RoutineName As String: RoutineName = "PlaySound"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName + _
" " + _
"frequency=" + _TRIM$(str$(frequency)) + ", " + _
"duration = " + _TRIM$(str$(duration)) + ", " + _
"amplitude = " + _TRIM$(str$(amplitude)) + ""
' Generate a square wave sound. This is a simplified version
' of the sound generation. The original SAM used a more
' complex algorithm with filters and envelopes.
'
' QB64's SOUND function is used for sound output.
If frequency > 0 And amplitude > 0 Then ' Avoid trying to play silence or zero frequency.
Sound frequency, duration 'Plays the sound
End If
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' PlaySound
' ----------------------------------------------------------------------
' Sound Playback Subroutine
' ----------------------------------------------------------------------
' This version uses _SNDRAW to support amplitude, see:
' _SNDRAW
' https://qb64phoenix.com/qb64wiki/index.php/SNDRAW
' _SNDRAWDONE
' https://qb64phoenix.com/qb64wiki/index.php/SNDRAWDONE
' _SNDRAWLEN
' https://qb64phoenix.com/qb64wiki/index.php/SNDRAWLEN
' _WAVE
' https://qb64phoenix.com/qb64wiki/index.php/WAVE
Sub PlaySound (frequency As Integer, duration As Integer, amplitude As Integer)
Dim RoutineName As String: RoutineName = "PlaySound"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName + _
" " + _
"frequency=" + _TRIM$(str$(frequency)) + ", " + _
"duration = " + _TRIM$(str$(duration)) + ", " + _
"amplitude = " + _TRIM$(str$(amplitude)) + ""
Dim amplitude1 As Single
Dim duration1 As Single
Dim SampleRate&
Dim FRate As Single
Dim SndLoop!
Dim Pi2 As Single
' input value of frequency is 160-3951
' (not sure if we need to convert it for _SNDRAW)
' input duration1 is probably 1/18th second ?
' do we need to convert this to some other value?
' input value of amplitude is 0-32767
' convert to amplitude1 which must be from -1.0 to 1.0
amplitude1 = (2 * (amplitude / 32767)) - 1
'amplitude1 = .3 ' amplitude of the signal from -1.0 to 1.0
SampleRate& = _SndRate ' sets the sample rate
FRate = frequency / SampleRate&
' Used in calculating wave
Pi2 = 8 * Atn(1) ' 2 * pi
If bDebug = _TRUE Then
PrintDebugFile " amplitude1 = " + _Trim$(Str$(amplitude1))
PrintDebugFile " SampleRate& = " + _Trim$(Str$(SampleRate&))
PrintDebugFile " FRate = " + _Trim$(Str$(FRate))
PrintDebugFile " Pi2 = " + _Trim$(Str$(Pi2))
End If
SndLoop! = 0
Do While SndLoop! < SampleRate&
'_SNDRAW SIN((2 * 4 * ATN(1) * SndLoop! / SampleRate&) * frq!) * EXP(-(SndLoop! / SampleRate&) * 3)
'_SNDRAW amplitude1 * SIN(Pi2 * Duration * FRate) 'sine wave
_SndRaw amplitude1 * Sgn(Sin(Pi2 * duration * FRate)) ' square wave
SndLoop! = SndLoop! + 1
Loop
_SndRawDone
Do: Loop While _SndRawLen 'flush the sound playing buffer
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' PlaySound
' ----------------------------------------------------------------------
' Say Subroutine
' ----------------------------------------------------------------------
Sub Say (text As String)
Dim RoutineName As String: RoutineName = "Say"
m_DebugLevel% = m_DebugLevel% + 1: PrintDebugFile "Started " + RoutineName + _
" " + _
"text = " + chr$(34) + text + chr$(34)
' Wrapper function to simplify speech synthesis.
ParseText text
GenerateSpeech
PrintDebugFile "Finished " + RoutineName: m_DebugLevel% = m_DebugLevel% - 1
End Sub ' Say
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN 'fnc2.bi' INCLUDE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function MTRIM$ (text As String)
' Removes extra spaces between words in a string, leaving only one space.
Dim result As String
Dim i As Integer
Dim previous_char As String
result = ""
previous_char = ""
For i = 1 To Len(text)
If Mid$(text, i, 1) <> " " Then
result = result + Mid$(text, i, 1)
previous_char = Mid$(text, i, 1)
ElseIf previous_char <> " " Then
result = result + " "
previous_char = " "
End If
Next i
MTRIM$ = _Trim$(result) ' Use TRIM$ to remove leading/trailing spaces as well.
End Function ' MTRIM$
' /////////////////////////////////////////////////////////////////////////////
Function CHOP$ (text As String, num_chars As Integer)
' Removes a specified number of characters from the end of a string.
If num_chars >= Len(text) Then
CHOP$ = ""
Else
CHOP$ = Left$(text, Len(text) - num_chars)
End If
End Function ' CHOP$
' /////////////////////////////////////////////////////////////////////////////
Function STRREV$ (text As String)
' Reverses a string.
Dim result As String
Dim i As Integer
result = ""
For i = Len(text) To 1 Step -1
result = result + Mid$(text, i, 1)
Next i
STRREV$ = result
End Function ' STRREV$
' /////////////////////////////////////////////////////////////////////////////
Function PADL$ (text As String, length As Integer, pad_char As String)
' Pads a string on the left to a specified length with a character.
If Len(pad_char) = 0 Then pad_char = " " ' Default padding character
If (length > 0) Then
PADL$ = Right$(String$(length, " ") + text, length)
Else
PADL$ = text
End If
End Function ' PADL$
' /////////////////////////////////////////////////////////////////////////////
Function PADR$ (text As String, length As Integer, pad_char As String)
' Pads a string on the right to a specified length with a character.
If Len(pad_char) = 0 Then pad_char = " " ' Default padding character
If (length > 0) Then
PADR$ = Left$(text + String$(length, " "), length)
Else
PADR$ = text
End If
End Function ' PADR$
' /////////////////////////////////////////////////////////////////////////////
Function PROPER$ (text As String)
' Converts a string to proper case (first letter of each word capitalized).
Dim result As String
Dim i As Integer
Dim capitalize As Integer
result = ""
capitalize = -1 ' Start with -1 to capitalize the first letter
For i = 1 To Len(text)
If Mid$(text, i, 1) = " " Then
capitalize = -1
result = result + " "
ElseIf capitalize Then
result = result + UCase$(Mid$(text, i, 1))
capitalize = 0
Else
result = result + LCase$(Mid$(text, i, 1))
End If
Next i
PROPER$ = result
End Function ' PROPER$
' /////////////////////////////////////////////////////////////////////////////
Function WORDCOUNT% (text As String)
' Counts the number of words in a string.
Dim count As Integer
Dim i As Integer
Dim previous_char As String
count = 0
previous_char = " "
For i = 1 To Len(text)
If Mid$(text, i, 1) <> " " And previous_char = " " Then
count = count + 1
End If
previous_char = Mid$(text, i, 1)
Next i
WORDCOUNT% = count
End Function ' WORDCOUNT%
' /////////////////////////////////////////////////////////////////////////////
Function PARSE% (text As String, delimiters As String, parsed_array$())
' Parses a string based on delimiters and returns an array of the parsed strings.
' Returns the number of elements in the array.
Dim i As Integer
Dim start_pos As Integer
Dim end_pos As Integer
Dim count As Integer
Dim found As Integer
start_pos = 1
count = 0
ReDim parsed_array$(0) ' Initialize the array
If delimiters = "" Then
parsed_array$(0) = text
PARSE% = 1
Exit Function
End If
Do
end_pos = 0
found = 0
For i = start_pos To Len(text)
If InStr(1, delimiters, Mid$(text, i, 1)) Then
end_pos = i
found = -1
Exit For
End If
Next i
If end_pos = 0 Then end_pos = Len(text) + 1
count = count + 1
ReDim _Preserve parsed_array$(count - 1)
parsed_array$(count - 1) = Mid$(text, start_pos, end_pos - start_pos)
start_pos = end_pos + 1
Loop Until start_pos > Len(text)
PARSE% = count
End Function ' PARSE%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END 'fnc2.bi' INCLUDE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GENERAL
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EMD GENERAL PURPOSE ROUTINES #GENERAL
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'WORKS IN QB64PE BUT NOT QB64:
'' /////////////////////////////////////////////////////////////////////////////
'' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
'' Using shell to delete a file
'' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
'' a740g
'' #5
'' 04-24-2024, 06:05 AM
''
'' There are no commands to directly make copies or backup of files.
'' But you could write one with a few lines of code like:
''
'' Copies src to dst
'' Set overwite to _TRUE if dst should be overwritten if present
'Sub CopyFile (src As String, dst As String, overwrite As _Byte)
' If _FileExists(src) Then
' If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
' _WriteFile dst, _ReadFile$(src)
' End If
' End If
'End Sub ' CopyFile
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618
Sub DeleteFile (sFile As String)
If _FileExists(sFile) Then
'Shell "DELETE " + sFile
'Shell "del " + sFile
Kill sFile
End If
End Sub ' DeleteFile
' /////////////////////////////////////////////////////////////////////////////
Function FileExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
FileExt$ = Right$(sFile, Len(sFile) - iPos)
Else
' dot is first character, return everything after it
FileExt$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the dot, the file extension is blank
FileExt$ = ""
End If
Else
' no dot found, the file extension is blank
FileExt$ = ""
End If
End Function ' FileExt$
' /////////////////////////////////////////////////////////////////////////////
Function NameOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NameOnly$ = Right$(sFile, Len(sFile) - iPos)
Else
' slash is first character, return everything after it
NameOnly$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the slash, name is blank
NameOnly$ = ""
End If
Else
' slash not found, return the entire thing
NameOnly$ = sFile
End If
End Function ' NameOnly$
' /////////////////////////////////////////////////////////////////////////////
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
' /////////////////////////////////////////////////////////////////////////////
Function PathOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
PathOnly$ = Left$(sFile, iPos)
Else
' slash is first character, so not much of a path, return blank
PathOnly$ = ""
End If
Else
' file only has one character, the slash, name is blank
PathOnly$ = ""
End If
Else
' slash not found, so not a path, return blank
PathOnly$ = ""
End If
End Function ' PathOnly$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=_TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, _FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
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
If Len(sError) = 0 Then
' NOTE: 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
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.
Function ReadTextFile$ (sFileName As String, sDefault As String)
Dim x$
If _FileExists(sFileName) Then
Open sFileName For Binary As #1
x$ = Space$(LOF(1))
Get #1, 1, x$
Close #1
ReadTextFile$ = x$
Else
ReadTextFile$ = sDefault
End If
End Function ' ReadTextFile$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUG
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub DebugLog (sText As String)
If cDebugEnabled = _TRUE Then
Dim sTime As String
Dim sResult As String
ReDim arrLines(0) As String
Dim iLoop As Integer
Dim sNextLine As String
If _FileExists(m_sDebugFile) = _FALSE Then
sResult = PrintFile$(m_sDebugFile, "", _FALSE)
End If
If Len(sResult) = 0 Then
sTime = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
split sText, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
sNextLine = sTime + " " + arrLines(iLoop)
sResult = PrintFile$(m_sDebugFile, sNextLine, _TRUE)
Next iLoop
End If
End If
End Sub ' DebugLog
' /////////////////////////////////////////////////////////////////////////////
Sub DebugLog1 (sText As String)
If cDebugEnabled = _TRUE Then
Dim sResult As String
If _FileExists(m_sDebugFile) Then
sResult = PrintFile$(m_sDebugFile, sText, _TRUE)
Else
sResult = PrintFile$(m_sDebugFile, sText, _FALSE)
End If
End If
End Sub ' DebugLog
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
Sub PrintDebugFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
If bDebug = _TRUE Then
sFileName = m_ProgramPath$ + m_ProgramName$ + ".txt"
sError = ""
If _FileExists(sFileName) = _FALSE Then
sOut = ""
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sOut = sOut + "PROGRAM : " + m_ProgramName$ + Chr$(13) + Chr$(10)
sOut = sOut + "RUN DATE: " + CurrentDateTime$ + Chr$(13) + Chr$(10)
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, _FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, String$(m_DebugLevel%, Chr$(9)) + sText, _TRUE)
End If
If Len(sError) <> 0 Then
Print CurrentDateTime$ + " PrintDebugFile FAILED: " + sError
End If
End If
End Sub ' PrintDebugFile
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUG
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' 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)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END(original post)
