morse code player

[idle]

two version

one plays with wave in a thread or blocking

two plays with midi or Beep

Code: Select all

;morse code player 

EnableExplicit 
InitSound() 

Structure RIFFStructure
  Riff.a[4]
  Length.l
  Wave.a[4]
EndStructure

Structure fmtStructure
  fmt.a[4]
  Length.l
  Format.u
  Channels.u
  SampleRate.l
  BytesPerSecond.l
  BlockAlign.u
  BitsPerSample.u
EndStructure

Structure dataStructure
  Signature.a[4]
  Length.l
EndStructure

Procedure.i CreateSound(Sound.i, Duration.i, Bits.i=16, Channels.i=2, SamplingRate.i=44100,frequency=500)
  
  Protected.i Result, HeaderSize, DataSize, samples,sample,time.f,tone.u  
  Protected *WAVBuffer, *RiffPtr.RIFFStructure, *fmtPtr.fmtStructure, *dataPtr.dataStructure, *audioPtr.Unicode
    
  HeaderSize = SizeOf(RIFFStructure)
  HeaderSize + SizeOf(fmtStructure)
  HeaderSize + SizeOf(dataStructure)
  
  DataSize = (Bits / 8) * SamplingRate * Duration * Channels / 1000
  samples = (DataSize / 2 / 2) - 1  
  
  *WAVBuffer = AllocateMemory(HeaderSize + DataSize, #PB_Memory_NoClear)
  If *WAVBuffer
    
    *RiffPtr = *WAVBuffer
    PokeS(@*RiffPtr\Riff, "RIFF", 4, #PB_Ascii|#PB_String_NoZero)
    *RiffPtr\Length = HeaderSize + DataSize - 8
    PokeS(@*RiffPtr\Wave, "WAVE", 4, #PB_Ascii|#PB_String_NoZero)
    
    *fmtPtr = *WAVBuffer + SizeOf(RIFFStructure)
    PokeS(@*fmtPtr\fmt, "fmt ", 4, #PB_Ascii|#PB_String_NoZero)
    *fmtPtr\Length = SizeOf(fmtStructure) - 8
    *fmtPtr\Format = 1
    *fmtPtr\Channels = Channels
    *fmtPtr\SampleRate = SamplingRate
    *fmtPtr\BitsPerSample = Bits
    *fmtPtr\BlockAlign = *fmtPtr\Channels * ((*fmtPtr\BitsPerSample + 7) / 8)
    *fmtPtr\BytesPerSecond = *fmtPtr\SampleRate * *fmtPtr\BlockAlign
    
    *dataPtr = *WAVBuffer + SizeOf(RIFFStructure) + SizeOf(fmtStructure)
    PokeS(@*dataPtr\Signature, "data", 4, #PB_Ascii|#PB_String_NoZero)
    *dataPtr\Length = DataSize
    
    *audioPtr = *WAVBuffer + SizeOf(RIFFStructure) + SizeOf(fmtStructure) + SizeOf(dataStructure) 
         
    For sample = 0 To samples 
	    time = sample / SamplingRate * 8
	    tone = Sin(time * frequency) * 32767
	    *audioPtr\u= tone  
	    *audioPtr+2 
	    *audioPtr\u = tone 
	    *audioPtr+2 
    Next
 
    Result = CatchSound(Sound, *WAVBuffer)
    FreeMemory(*WAVBuffer)
  EndIf
  
  ProcedureReturn Result
  
EndProcedure

#dot = 1 
#dash = 2 

Structure _morse 
  code.a
  count.a 
  pattern.s
EndStructure 

Global binit,sdot,sdash  
Global NewMap amorse._morse() 

Declare.s EncodeMorse(text.s) 

Procedure Addcode(symbol.s,a,b=0,c=0,d=0,e=0,f=0,g=0) 
  Protected code.s 
  amorse(symbol)\code = a-1  
  If a = 1 
    code ="."
  ElseIf a = 2
    code = "-"
  EndIf   
  If b 
    amorse(symbol)\code << 1 | (b-1)
    amorse(symbol)\count=1
    If b = 1 
      code +"."
    ElseIf b = 2
      code + "-"
    EndIf  
    
  EndIf 
  If c 
    amorse(symbol)\code << 1 | (c-1) 
    amorse(symbol)\count=2
    If c = 1 
      code +"."
    ElseIf c = 2
      code + "-"
    EndIf  
  EndIf 
  If d 
    amorse(symbol)\code << 1 | (d-1)
    amorse(symbol)\count=3
    If d = 1 
      code +"."
    ElseIf d = 2
      code + "-"
    EndIf  
  EndIf 
  If e 
    amorse(symbol)\code << 1 | (e-1)
    amorse(symbol)\count=4
    If e = 1 
      code +"."
    ElseIf e = 2
      code + "-"
    EndIf  
  EndIf 
  If f 
    amorse(symbol)\code << 1 | (f-1)
    amorse(symbol)\count=5
    If f = 1 
      code +"."
    ElseIf f = 2
      code + "-"
    EndIf  
  EndIf 
  If g 
    amorse(symbol)\code << 1 | (g-1)
    amorse(symbol)\count=6
    If g = 1 
      code +"."
    ElseIf g = 2
      code + "-"
    EndIf  
  EndIf 
  
  amorse(code)\pattern = symbol  
  amorse("........")\pattern = "<HH>" ; correction
  amorse(".-.-")\pattern = "<AA>"  ; unknown station 
  amorse(".-.-.")\pattern = "<AR>" ;OUT
  amorse(".-...")\pattern = "<AS>" ; wait
  amorse("...-.")\pattern = "<VE>" ; verified
  amorse("..-.-")\pattern = "<INT>" ;interrogative
  amorse("-...-")\pattern = "<BT>"  ; break
  amorse("-.-.-")\pattern = "<KA>" ; attention 
  amorse("...-.-")\pattern = "<SK>";out
  amorse("...---...")\pattern = "<SOS>" 
  amorse("-..-..-..")\pattern = "<DDD>" ;relay distress 
   
  
EndProcedure   

Procedure InitMorse() 
  
  Protected a 
  
  For a = 0 To 128 
    amorse(Chr(a))\code = $ff 
  Next 
  amorse("<")\code = 0
  amorse("<")\pattern = "<"
  amorse(">")\code = 0 
  amorse(">")\pattern = ">"
  
  Addcode("A",#dot,#dash) 
  Addcode("B",#dash,#dot,#dot,#dot)
  Addcode("C",#dash,#dot,#dash,#dot)
  Addcode("D",#dash,#dot,#dot)
  Addcode("E",#dot)
  Addcode("F",#dot,#dot,#dash,#dot)
  Addcode("G",#dash,#dash,#dot)
  Addcode("H",#dot,#dot,#dot,#dot)
  Addcode("I",#dot,#dot)
  Addcode("J",#dot,#dash,#dash,#dash) 
  Addcode("K",#dash,#dot,#dash)
  Addcode("L",#dot,#dash,#dot,#dot)
  Addcode("M",#dash,#dash) 
  Addcode("N",#dash,#dot)
  Addcode("O",#dash,#dash,#dash)
  Addcode("P",#dot,#dash,#dash,#dot)
  Addcode("Q",#dash,#dash,#dot,#dash)
  Addcode("R",#dot,#dash,#dot)
  Addcode("S",#dot,#dot,#dot)
  Addcode("T",#dash)
  Addcode("U",#dot,#dot,#dash)
  Addcode("V",#dot,#dot,#dot,#dash)
  Addcode("W",#dot,#dash,#dash)
  Addcode("X",#dash,#dot,#dot,#dash)
  Addcode("Y",#dash,#dot,#dash,#dash)
  Addcode("Z",#dash,#dash,#dot,#dot)
  Addcode("0",#dash,#dash,#dash,#dash,#dash)
  Addcode("1",#dot,#dash,#dash,#dash,#dash)
  Addcode("2",#dot,#dot,#dash,#dash,#dash)
  Addcode("3",#dot,#dot,#dot,#dash,#dash)
  Addcode("4",#dot,#dot,#dot,#dot,#dash)
  Addcode("5",#dot,#dot,#dot,#dot,#dot) 
  Addcode("6",#dash,#dot,#dot,#dot,#dot) 
  Addcode("7",#dash,#dash,#dot,#dot,#dot) 
  Addcode("8",#dash,#dash,#dash,#dot,#dot)
  Addcode("9",#dash,#dash,#dash,#dash,#dot)
  
  Addcode("&",#dot,#dash,#dot,#dot,#dot)
  Addcode(Chr(39), #dot,#dash,#dash,#dash,#dash,#dot)
  Addcode("@",#dot,#dash,#dash,#dot,#dash,#dot) 
  Addcode(")",#dash,#dot,#dash,#dash,#dot,#dash)
  Addcode("(",#dash,#dot,#dash,#dash,#dot)
  Addcode(":",#dash,#dash,#dash,#dot,#dot,#dot)
  Addcode(",",#dash,#dash,#dot,#dot,#dash,#dash)
  Addcode("=",#dash,#dot,#dot,#dot,#dash)
  Addcode("!",#dash,#dot,#dash,#dot,#dash,#dash)
  Addcode(".",#dot,#dash,#dot,#dash,#dot,#dash)
  Addcode("-",#dash,#dot,#dot,#dot,#dot,#dash) 
  Addcode("*",#dash,#dot,#dot,#dash)
  Addcode("+",#dot,#dash,#dot,#dash,#dot)
  Addcode(Chr(34),#dot,#dash,#dot,#dot,#dash,#dot)
  Addcode("?",#dot,#dot,#dash,#dash,#dot,#dot)
  Addcode("/",#dash,#dot,#dot,#dash,#dot) 
  
EndProcedure 

Structure morse 
  msg.s
  WPM.i 
EndStructure   

Procedure _PlayMorse(*mc.morse) 
  Protected *char.Unicode = @*mc\msg
  Protected speed.f 
  speed = 1200 / *mc\WPM    
  
  If sdot = 0 
    sdot = CreateSound(#dot,speed) 
  EndIf 
  If sdash = 0
    sdash = CreateSound(#dash,speed*3)    
  EndIf   
     
  While *char\u <> 0  
    If *char\u = '.' 
      PlaySound(#dot)
      Delay(speed*2) 
    ElseIf *char\u = '-' 
      PlaySound(#dash)
      Delay(speed*4) 
    Else 
      Delay(speed) 
    EndIf   
    *char+2 
  Wend   
  
  FreeStructure(*mc)
  
EndProcedure   

Procedure PlayMorse(msg.s,WPM,bmorse=1,bthread=0) 
  Protected tid 
  Protected *mc.morse = AllocateStructure(morse) 
  If *mc 
    If bmorse = 0 
      *mc\msg = encodeMorse(msg)
    Else   
      *mc\msg = UCase(msg) 
    EndIf 
    *mc\WPM = WPM 
    If bthread 
      ProcedureReturn CreateThread(@_playmorse(),*mc) 
    Else 
      _playmorse(*mc) 
    EndIf 
  EndIf  
EndProcedure  

Procedure.s EncodeMorse(text.s) 
  Protected msg.s = UCase(text) 
  Protected *char.Unicode = @Msg 
  Protected ct, v, out.s, bdelay = 1    
  Protected a,result.s   
    
  If binit = 0 
    InitMorse() 
    binit = 1 
  EndIf   
    
  While *char\u <> 0 
    
    If amorse(Chr(*char\u))\code <> $ff
      
      If *char\u = '<'  ;if Prosign no delay between chars
        bdelay = 0
        *char + 2
        Continue
      ElseIf *char\u  = '>'
        bdelay = 1
        *char + 2
        Continue
      EndIf
      
      ct = amorse(Chr(*char\u))\count
      
      For a = 0 To amorse(Chr(*char\u))\count
        v = ((amorse(Chr(*char\u))\code >> ct) & 1) + 1
        ct - 1
        If v = 1
          out + ". "
        Else
          out + "- "
        EndIf
      Next
      
      result + out 
      out = "" 
      
      If bdelay
         result + "   " 
      EndIf
      
    Else
      If *char\u = 32
        result + "       "
      EndIf
    EndIf
    *char + 2
  Wend
  
  ProcedureReturn result  
   
EndProcedure

Procedure.s DecodeMorse(msg.s) 
  
  Protected sp,*char.Unicode  
  Protected key.s,tkey.s,out.s 
  
  If binit = 0 
    InitMorse() 
    binit = 1 
  EndIf   
  
  *char = @msg 
  
  While *char\u <> 0  
    
    If *char\u = '.' 
      key + "." 
      sp=1 
    ElseIf *char\u = '-' 
      key + "-"
      sp=1
    ElseIf *char\u = ' '   
      sp+1  
      If (sp > 2 And sp < 7) 
       If key <> "" 
        tkey = amorse(key)\pattern
        If tkey 
          out + tkey 
          key=""
        EndIf   
      EndIf   
      ElseIf sp = 7   
        out + " "
        sp=0
      EndIf   
    EndIf      
    *char + 2
    
  Wend 
  
  ProcedureReturn out 
  
EndProcedure  

CompilerIf #PB_Compiler_IsMainFile 
  Global tid 
  tid = PlayMorse("Hello test <HH> <DDD> <SOS> !" ,30,0,1) 
  WaitThread(tid)
  Global msg.s = "Hello test <HH> <DDD> <SOS> !" 
  msg = encodeMorse(msg)
  Debug msg 
  PlayMorse(msg,30)  
  Debug decodeMorse(msg) 
  Debug decodeMorse("-    .    ...    -        -..-..-..        . -   ")    
CompilerEndIf 

two plays with beep or midi
midi by infratec

Code: Select all

;CreateMorseMidi(msg.s,speed.f,bplay=0) if bplay is 0 it writes a midi file, if bplay=1 plays with beep_
EnableExplicit 

#dot = 1 
#dash = 2 

Structure _morse 
  code.a
  count.a 
EndStructure 

Global Dim amorse._morse(128) 

Procedure Addcode(symbol,a,b=0,c=0,d=0,e=0,f=0,g=0) 
  
  amorse(symbol)\code = a-1  
  If b 
    amorse(symbol)\code << 1 | (b-1)
    amorse(symbol)\count=1
  EndIf 
  If c 
    amorse(symbol)\code << 1 | (c-1) 
    amorse(symbol)\count=2
  EndIf 
  If d 
    amorse(symbol)\code << 1 | (d-1)
    amorse(symbol)\count=3
  EndIf 
  If e 
    amorse(symbol)\code << 1 | (e-1)
    amorse(symbol)\count=4
  EndIf 
  If f 
    amorse(symbol)\code << 1 | (f-1)
    amorse(symbol)\count=5
  EndIf 
  If g 
    amorse(symbol)\code << 1 | (g-1)
    amorse(symbol)\count=6
  EndIf 
EndProcedure   

Procedure InitMorse() 
  
  Protected a 
  
  For a = 0 To 128 
    amorse(a)\code = $ff 
  Next 
  amorse('<')\code = 0
  amorse('>')\code = 0 
  
  Addcode('A',#dot,#dash) 
  Addcode('B',#dash,#dot,#dot,#dot)
  Addcode('C',#dash,#dot,#dash,#dot)
  Addcode('D',#dash,#dot,#dot)
  Addcode('E',#dot)
  Addcode('F',#dot,#dot,#dash,#dot)
  Addcode('G',#dash,#dash,#dot)
  Addcode('H',#dot,#dot,#dot,#dot)
  Addcode('I',#dot,#dot)
  Addcode('J',#dot,#dash,#dash,#dash) 
  Addcode('K',#dash,#dot,#dash)
  Addcode('L',#dot,#dash,#dot,#dot)
  Addcode('M',#dash,#dash) 
  Addcode('N',#dash,#dot)
  Addcode('O',#dash,#dash,#dash)
  Addcode('P',#dot,#dash,#dash,#dot)
  Addcode('Q',#dash,#dash,#dot,#dash)
  Addcode('R',#dot,#dash,#dot)
  Addcode('S',#dot,#dot,#dot)
  Addcode('T',#dash)
  Addcode('U',#dot,#dot,#dash)
  Addcode('V',#dot,#dot,#dot,#dash)
  Addcode('W',#dot,#dash,#dash)
  Addcode('X',#dash,#dot,#dot,#dash)
  Addcode('Y',#dash,#dot,#dash,#dash)
  Addcode('Z',#dash,#dash,#dot,#dot)
  Addcode('0',#dash,#dash,#dash,#dash,#dash)
  Addcode('1',#dot,#dash,#dash,#dash,#dash)
  Addcode('2',#dot,#dot,#dash,#dash,#dash)
  Addcode('3',#dot,#dot,#dot,#dash,#dash)
  Addcode('4',#dot,#dot,#dot,#dot,#dash)
  Addcode('5',#dot,#dot,#dot,#dot,#dot) 
  Addcode('6',#dash,#dot,#dot,#dot,#dot) 
  Addcode('7',#dash,#dash,#dot,#dot,#dot) 
  Addcode('8',#dash,#dash,#dash,#dot,#dot)
  Addcode('9',#dash,#dash,#dash,#dash,#dot)
  
  Addcode('&',#dot,#dash,#dot,#dot,#dot)
  Addcode(39, #dot,#dash,#dash,#dash,#dash,#dot)
  Addcode('@',#dot,#dash,#dash,#dot,#dash,#dot) 
  Addcode(')',#dash,#dot,#dash,#dash,#dot,#dash)
  Addcode('(',#dash,#dot,#dash,#dash,#dot)
  Addcode(':',#dash,#dash,#dash,#dot,#dot,#dot)
  Addcode(',',#dash,#dash,#dot,#dot,#dash,#dash)
  Addcode('=',#dash,#dot,#dot,#dot,#dash)
  Addcode('!',#dash,#dot,#dash,#dot,#dash,#dash)
  Addcode('.',#dot,#dash,#dot,#dash,#dot,#dash)
  Addcode('-',#dash,#dot,#dot,#dot,#dot,#dash) 
  Addcode('*',#dash,#dot,#dot,#dash)
  Addcode('+',#dot,#dash,#dot,#dash,#dot)
  Addcode(34,#dot,#dash,#dot,#dot,#dash,#dot)
  Addcode('?',#dot,#dot,#dash,#dash,#dot,#dot)
  Addcode('/',#dash,#dot,#dot,#dash,#dot) 
  
EndProcedure 


#MIDI_VarLen_Max   = $0FFFFFFF ;4 reserved Bytes
#MIDI_VarLen_Error = $FFFFFFFF ;impossible VarLen or Num value

Structure ByteArray_Structure
  a.a[0]
EndStructure


Procedure.l NumToVarLen(Num.l)
  
  Protected VarLen.l, i.l
  Protected *VarLen.ByteArray_Structure
  
  
  If Num & ~#MIDI_VarLen_Max
    
    VarLen = #MIDI_VarLen_Error
    
  Else
    *VarLen = @VarLen
    
    *VarLen\a[0] = 0
    
    *VarLen\a[0] = (Num >>  0) & $7F
    *VarLen\a[1] = (Num >>  7) & $7F
    *VarLen\a[2] = (Num >> 14) & $7F
    *VarLen\a[3] = (Num >> 21) & $7F
    
    i = 3
    
    While i > 0 And Not *VarLen\a[i]
      i - 1
    Wend
    
    While i > 0
      *VarLen\a[i] | $80
      i - 1
    Wend
  EndIf
  
  ProcedureReturn VarLen
  
EndProcedure

Procedure WriteBigEndianWord(File.i, WordValue.u)
  
  Protected *ByteArray.ByteArray_Structure
    
  *ByteArray = @WordValue
  WriteByte(File, *ByteArray\a[1])
  WriteByte(File, *ByteArray\a[0])
  
EndProcedure

Procedure WriteBigEndianLong(File.i, LongValue.l)
  
  Protected *ByteArray.ByteArray_Structure
  
  *ByteArray = @LongValue
  WriteByte(File, *ByteArray\a[3])
  WriteByte(File, *ByteArray\a[2])
  WriteByte(File, *ByteArray\a[1])
  WriteByte(File, *ByteArray\a[0])
  
EndProcedure

Procedure.i WriteVarLen(File.i, Num.l)
  
  Protected Write.l, VarLen.l, i.i
  Protected *VarLen.ByteArray_Structure
  
  VarLen = NumToVarLen(Num)
  
  If IsFile(File) And VarLen <> #MIDI_VarLen_Error
    *VarLen = @VarLen
    
    i = 3
    
    While Not *VarLen\a[i] And i > 0
      i - 1
    Wend
    
    While i >= 0
      Write + WriteByte(File, *VarLen\a[i])
      i - 1
    Wend
  EndIf
  
  ProcedureReturn Write
  
EndProcedure


Procedure WriteCode(File.i, Mode.i, duration.i)
  
  #MIDI_Tone = $3C
  
  WriteVarLen(File, 0)
  If Mode = 0
    WriteByte(File, $90)
  Else
    WriteByte(File, $80)
  EndIf
  WriteByte(File, #MIDI_Tone)
  WriteByte(File, 100)
  
  WriteVarLen(File, duration / 2)
  WriteByte(File, $80)
  WriteByte(File, #MIDI_Tone)
  WriteByte(File, 100)
    
EndProcedure

Procedure playMIDIFile(hWndNotify,MIDIFileName.s)

    Protected wDeviceID.l;
    Protected dwReturn.l;
    Protected mciOpenParms.MCI_OPEN_PARMS
    Protected mciPlayParms.MCI_PLAY_PARMS
    Protected mciStatusParms.MCI_STATUS_PARMS
    Protected mciSeqSetParms.MCI_SEQ_SET_PARMS
   
    mciOpenParms\lpstrDeviceType = @"sequencer";
    mciOpenParms\lpstrElementName = @MIDIFileName;
    dwReturn = mciSendCommand_(#Null, #MCI_OPEN,#MCI_OPEN_TYPE | #MCI_OPEN_ELEMENT,@mciOpenParms)
    If dwReturn    
       ProcedureReturn dwReturn;
    EndIf 
   
    wDeviceID = mciOpenParms\wDeviceID;

    mciStatusParms\dwItem = #MCI_SEQ_STATUS_PORT;
    dwReturn = mciSendCommand_(wDeviceID, #MCI_STATUS,#MCI_STATUS_ITEM,@mciStatusParms)
    If dwReturn
        mciSendCommand_(wDeviceID, #MCI_CLOSE, 0, #Null);
        ProcedureReturn dwReturn;
    EndIf 
    
    mciPlayParms\dwCallback = hWndNotify;
    dwReturn = mciSendCommand_(wDeviceID, #MCI_PLAY, #MCI_NOTIFY,@mciPlayParms)
    If dwReturn
        mciSendCommand_(wDeviceID, #MCI_CLOSE, 0, #Null);
        ProcedureReturn dwReturn
    EndIf 

    ProcedureReturn 1
 EndProcedure 
  
 Procedure.s CreateMorseMidi(msg.s,speed.f,bplay=0) 
   
   Protected *char.Unicode = @Msg 
   Protected ct, v, out.s, bdelay = 1    
   Protected size,a
   Static binit 
   If Not binit 
     InitMorse() 
     binit=1
   EndIf   
   
   Protected path.s = GetTemporaryDirectory() + "morse.mid"
   
   Protected File = CreateFile(#PB_Any,path, #PB_Ascii)
   If File
     
     If bplay = 0 
       WriteString(File, "MThd")     ; signature
       WriteBigEndianLong(File, 6)   ; header length
       WriteBigEndianWord(File, 0)   ; single track file
       WriteBigEndianWord(File, 1)   ; 1 track follows
       WriteBigEndianWord(File, $60) ; speed
       
       WriteString(File, "MTrk")     ; signature
       WriteBigEndianLong(File, 0)   ; length of the track in bytes (dummy)
       
       WriteVarLen(File, 0)
       WriteByte(File, $C0)
       WriteByte(File, 87)           ; Instrument 
       
       speed = 1200/(speed*2) 
       
     Else 
       
       speed = 1200 / speed    
       
     EndIf 
     
     While *char\u <> 0 
       
       If amorse(*char\u)\code <> $ff
         
         If *char\u = '<'  ;if Prosign no delay between chars
           bdelay = 0
           *char + 2
           Continue
         ElseIf *char\u  = '>'
           bdelay = 1
           *char + 2
           Continue
         EndIf
         
         ct = amorse(*char\u)\count
         
         For a = 0 To amorse(*char\u)\count
           v = ((amorse(*char\u)\code >> ct) & 1) + 1
           ct - 1
           If v = 1
             out + "."
           Else
             out + "-"
             v = 3
           EndIf
           If bplay 
             Beep_(550, v * speed)
             Delay(speed)  
           Else   
             WriteCode(File, 0, v * speed)
             WriteCode(File, 1, speed)
           EndIf  
         Next
         
         Debug Chr(*char\u) + " " + out
         out = ""
         If bdelay
           If bplay 
             Delay(speed * 3)
           Else   
             WriteCode(File, 1, speed * 3)
           EndIf   
         EndIf
         
       Else
         If *char\u = 32
           Debug " "
           If bplay 
             Delay(speed * 7)
           Else   
             WriteCode(File, 1, speed * 7)
           EndIf   
         EndIf
       EndIf
       *char + 2
     Wend
     
     If bplay = 0 
       WriteVarLen(File, 0)
       WriteByte(File, $FF)
       WriteByte(File, $2F)
       WriteByte(File, 0)
       
       Size = Loc(File) - 22
       
       FileSeek(File, 18)
       WriteBigEndianLong(File, Size)   ; length of the track in bytes
       
       CloseFile(File)
     EndIf   
   EndIf
   
   ProcedureReturn path 
   
 EndProcedure
 
 Define ev,hwin,morsefile.s 
 morsefile = CreateMorseMidi(UCase("Testing morse in purebasic 123 <AA> <SOS> <HH> <0/0> !"),20,0) ;0 writes midi 1=beeps 20 is words per min
 
 If FileSize(morsefile) > 0  
   
   hwin = OpenWindow(-1,0,0,200,60,"midi",#PB_Window_Invisible)
   playMIDIFile(WindowID(hwin),morsefile) 
   Repeat  
     ev = WaitWindowEvent() 
   Until ev = #PB_Event_CloseWindow Or ev = #MM_MCINOTIFY   
 EndIf   

[Mijikai]

Thanks for sharing, pretty cool
Got me to play around with morse codes.

[idle]

Thanks for sharing, pretty cool
Got me to play around with morse codes.

I was tempted to try and write a decoder but that's not so easy.

[minimy]

Very good work idle!
This is a very usefull program.
I have one similar maked for android, the screen goes black and white (light) are dots and lines. Nice to use in the night
A decoder is a great idea.

[idle]

Very good work idle!
This is a very usefull program.
I have one similar maked for android, the screen goes black and white (light) are dots and lines. Nice to use in the night
A decoder is a great idea.

Decoding it is actually quite tricky. I would probably go with an FFT to find the frequency then feed it into goertzel which is like an DFT for a specific frequency. it outputs the magnitude so then you can feed it in and measure the on offs

I'll post these here so I remember

Code: Select all

Procedure _stockham(*x.arcomplex,n.i,flag.i,n2.i,*y.arcomplex)
  
  Protected *y_orig.arcomplex 
  Protected *tmp.complex 
  
  Protected i.i, j.i, k.i, k2.i, Ls.i, r.i, jrs.i
  Protected half, m, m2                          
  Protected wr.d, wi.d, tr.d, ti.d               
  
  *y_orig = *y
  half = n >> 1
  r = half 
  Ls = 1                                     
  
  While(r >= n2) 
    *tmp = *x                  
    *x = *y                             
    *y = *tmp
    m = 0                      
    m2 = half                    
    j=0
    While j < ls
      wr = Cos(#PI*j/Ls)
      wi = -flag * Sin(#PI*j/Ls)            
      jrs = j*(r+r)
      k = jrs
      While k < jrs+r
        k2 = k + r
        tr =  wr * *y\ar[k2]\Re - wi * *y\ar[k2]\Im   
        ti =  wr * *y\ar[k2]\Im + wi * *y\ar[k2]\Re
        *x\ar[m]\Re = *y\ar[k]\Re + tr
        *x\ar[m]\Im = *y\ar[k]\Im + ti
        *x\ar[m2]\Re = *y\ar[k]\Re - tr
        *x\ar[m2]\Im = *y\ar[k]\Im - ti
        m+1
        m2+1
        k+1
      Wend 
      j+1
    Wend  
    r  >> 1
    Ls << 1
  Wend 
  
  CopyMemory(*x,*y,n*SizeOf(complex))  
   
EndProcedure   

Procedure fft(*x.arcomplex,n.i,flag.i=1)
  Protected *y.arcomplex
  *y = AllocateMemory((n)*SizeOf(complex))
  _stockham(*x, n, flag, 1, *y)
  FreeMemory(*y) 
EndProcedure 

Procedure.f goertzel(numSamples,freq,samplerate,*data.float)
    
  Protected omega.f,sine.f,cosine.f,coeff.f,q0.f,q1.f,q2.f,real.f,imag.f
  Protected k,i
  Protected scalingFactor.f = numSamples / 2.0
    
  k = (0.5 + ((numSamples * freq) / samplerate))
  omega = ((2.0 * #PI * k) / numSamples)
  sine = Sin(omega)
  cosine = Cos(omega)
  coeff = 2.0 * cosine
  numSamples-1
  For i = 0 To numSamples
    q0 = coeff * q1 - q2 + *data\f
    q2 = q1
    q1 = q0
    *data+4
  Next 
  
  real = (q1 - q2 * cosine) / scalingFactor
  imag = (q2 * sine) / scalingFactor
    
  ProcedureReturn Sqr(real*real + imag*imag)
  
EndProcedure 

[minimy]

That's nice! It's challenging but fun to do.
I have a memory problem similar to yours, but I don't remember

[idle]

That's nice! It's challenging but fun to do.
I have a memory problem similar to yours, but I don't remember

Exactly

[wilbert]

Decoding it is actually quite tricky. I would probably go with an FFT to find the frequency then feed it into goertzel which is like an DFT for a specific frequency. it outputs the magnitude so then you can feed it in and measure the on offs

Wouldn't it be possible to just look at volume changes of the signal?
Very early morse code recordings from a telegraph are just clicks, no sine waves.

[TassyJim]

Wouldn't it be possible to just look at volume changes of the signal?
Very early morse code recordings from a telegraph are just clicks, no sine waves.

If you are listening to RF signals and have a good narrow CW filter in the radio, using signal amplitude would work well.

In my Z80 days, I used phase-locked-loop ICs to create a clean signal for the processor to work with.

With modern processors, FFT is very doable. Being able to pull a signal out of the mud and decode it is impressive to see.
A good SDR (Software defined radio) should be able to decode multiple signals at the same time.

Jim

[idle]

Decoding it is actually quite tricky. I would probably go with an FFT to find the frequency then feed it into goertzel which is like an DFT for a specific frequency. it outputs the magnitude so then you can feed it in and measure the on offs

Wouldn't it be possible to just look at volume changes of the signal?
Very early morse code recordings from a telegraph are just clicks, no sine waves.

yes if there's no noise but I'm thinking along the lines of using your mic or SDR, where you can't just use amplitude without a bandpass to filter out the other sound sources.

Goertzel builds a DFT at a specific frequency so it filters out noise and is light on processing, then you can use that to time on and off and look up sequences in a map or trie

Using FFT you would need to use windowing and band passes, I didn't actually consider decoding multiple channels as TazzyJim pointed out but that is also possible as The FFT will give you the dominant frequencies of the signals and then you can run parallel Goertzel.

[Kwai chang caine]

Nice idea, thanks for sharing

[idle]

updated 1st post.

Changed it to use playsound via Infratec's CatchSound tip as I can't record beep_() with AndyMK windows audio client since beep is played out of process.

morse.pb

Code: Select all

;morse code player 

EnableExplicit 
InitSound() 

Structure RIFFStructure
  Riff.a[4]
  Length.l
  Wave.a[4]
EndStructure

Structure fmtStructure
  fmt.a[4]
  Length.l
  Format.u
  Channels.u
  SampleRate.l
  BytesPerSecond.l
  BlockAlign.u
  BitsPerSample.u
EndStructure

Structure dataStructure
  Signature.a[4]
  Length.l
EndStructure

Procedure.i CreateSound(Sound.i, Duration.i, Bits.i=16, Channels.i=2, SamplingRate.i=44100,frequency=500)
  
  Protected.i Result, HeaderSize, DataSize, samples,sample,time.f,tone.u  
  Protected *WAVBuffer, *RiffPtr.RIFFStructure, *fmtPtr.fmtStructure, *dataPtr.dataStructure, *audioPtr.Unicode
    
  HeaderSize = SizeOf(RIFFStructure)
  HeaderSize + SizeOf(fmtStructure)
  HeaderSize + SizeOf(dataStructure)
  
  DataSize = (Bits / 8) * SamplingRate * Duration * Channels / 1000
  samples = (DataSize / 2 / 2) - 1  
  
  *WAVBuffer = AllocateMemory(HeaderSize + DataSize, #PB_Memory_NoClear)
  If *WAVBuffer
    
    *RiffPtr = *WAVBuffer
    PokeS(@*RiffPtr\Riff, "RIFF", 4, #PB_Ascii|#PB_String_NoZero)
    *RiffPtr\Length = HeaderSize + DataSize - 8
    PokeS(@*RiffPtr\Wave, "WAVE", 4, #PB_Ascii|#PB_String_NoZero)
    
    *fmtPtr = *WAVBuffer + SizeOf(RIFFStructure)
    PokeS(@*fmtPtr\fmt, "fmt ", 4, #PB_Ascii|#PB_String_NoZero)
    *fmtPtr\Length = SizeOf(fmtStructure) - 8
    *fmtPtr\Format = 1
    *fmtPtr\Channels = Channels
    *fmtPtr\SampleRate = SamplingRate
    *fmtPtr\BitsPerSample = Bits
    *fmtPtr\BlockAlign = *fmtPtr\Channels * ((*fmtPtr\BitsPerSample + 7) / 8)
    *fmtPtr\BytesPerSecond = *fmtPtr\SampleRate * *fmtPtr\BlockAlign
    
    *dataPtr = *WAVBuffer + SizeOf(RIFFStructure) + SizeOf(fmtStructure)
    PokeS(@*dataPtr\Signature, "data", 4, #PB_Ascii|#PB_String_NoZero)
    *dataPtr\Length = DataSize
    
    *audioPtr = *WAVBuffer + SizeOf(RIFFStructure) + SizeOf(fmtStructure) + SizeOf(dataStructure) 
         
    For sample = 0 To samples 
	    time = sample / SamplingRate * 8
	    tone = Sin(time * frequency) * 32767
	    *audioPtr\u= tone  
	    *audioPtr+2 
	    *audioPtr\u = tone 
	    *audioPtr+2 
    Next
 
    Result = CatchSound(Sound, *WAVBuffer)
    FreeMemory(*WAVBuffer)
  EndIf
  
  ProcedureReturn Result
  
EndProcedure

#dot = 1 
#dash = 2 

Structure _morse 
  code.a
  count.a 
  pattern.s
EndStructure 

Global binit,sdot,sdash  
Global NewMap amorse._morse() 

Declare.s EncodeMorse(text.s) 

Procedure Addcode(symbol.s,a,b=0,c=0,d=0,e=0,f=0,g=0) 
  Protected code.s 
  amorse(symbol)\code = a-1  
  If a = 1 
    code ="."
  ElseIf a = 2
    code = "-"
  EndIf   
  If b 
    amorse(symbol)\code << 1 | (b-1)
    amorse(symbol)\count=1
    If b = 1 
      code +"."
    ElseIf b = 2
      code + "-"
    EndIf  
    
  EndIf 
  If c 
    amorse(symbol)\code << 1 | (c-1) 
    amorse(symbol)\count=2
    If c = 1 
      code +"."
    ElseIf c = 2
      code + "-"
    EndIf  
  EndIf 
  If d 
    amorse(symbol)\code << 1 | (d-1)
    amorse(symbol)\count=3
    If d = 1 
      code +"."
    ElseIf d = 2
      code + "-"
    EndIf  
  EndIf 
  If e 
    amorse(symbol)\code << 1 | (e-1)
    amorse(symbol)\count=4
    If e = 1 
      code +"."
    ElseIf e = 2
      code + "-"
    EndIf  
  EndIf 
  If f 
    amorse(symbol)\code << 1 | (f-1)
    amorse(symbol)\count=5
    If f = 1 
      code +"."
    ElseIf f = 2
      code + "-"
    EndIf  
  EndIf 
  If g 
    amorse(symbol)\code << 1 | (g-1)
    amorse(symbol)\count=6
    If g = 1 
      code +"."
    ElseIf g = 2
      code + "-"
    EndIf  
  EndIf 
  
  amorse(code)\pattern = symbol  
  amorse("........")\pattern = "<HH>" ; correction
  amorse(".-.-")\pattern = "<AA>"  ; unknown station 
  amorse(".-.-.")\pattern = "<AR>" ;OUT
  amorse(".-...")\pattern = "<AS>" ; wait
  amorse("...-.")\pattern = "<VE>" ; verified
  amorse("..-.-")\pattern = "<INT>" ;interrogative
  amorse("-...-")\pattern = "<BT>"  ; break
  amorse("-.-.-")\pattern = "<KA>" ; attention 
  amorse("...-.-")\pattern = "<SK>";out
  amorse("...---...")\pattern = "<SOS>" 
  amorse("-..-..-..")\pattern = "<DDD>" ;relay distress 
   
  
EndProcedure   

Procedure InitMorse() 
  
  Protected a 
  
  For a = 0 To 128 
    amorse(Chr(a))\code = $ff 
  Next 
  amorse("<")\code = 0
  amorse("<")\pattern = "<"
  amorse(">")\code = 0 
  amorse(">")\pattern = ">"
  
  Addcode("A",#dot,#dash) 
  Addcode("B",#dash,#dot,#dot,#dot)
  Addcode("C",#dash,#dot,#dash,#dot)
  Addcode("D",#dash,#dot,#dot)
  Addcode("E",#dot)
  Addcode("F",#dot,#dot,#dash,#dot)
  Addcode("G",#dash,#dash,#dot)
  Addcode("H",#dot,#dot,#dot,#dot)
  Addcode("I",#dot,#dot)
  Addcode("J",#dot,#dash,#dash,#dash) 
  Addcode("K",#dash,#dot,#dash)
  Addcode("L",#dot,#dash,#dot,#dot)
  Addcode("M",#dash,#dash) 
  Addcode("N",#dash,#dot)
  Addcode("O",#dash,#dash,#dash)
  Addcode("P",#dot,#dash,#dash,#dot)
  Addcode("Q",#dash,#dash,#dot,#dash)
  Addcode("R",#dot,#dash,#dot)
  Addcode("S",#dot,#dot,#dot)
  Addcode("T",#dash)
  Addcode("U",#dot,#dot,#dash)
  Addcode("V",#dot,#dot,#dot,#dash)
  Addcode("W",#dot,#dash,#dash)
  Addcode("X",#dash,#dot,#dot,#dash)
  Addcode("Y",#dash,#dot,#dash,#dash)
  Addcode("Z",#dash,#dash,#dot,#dot)
  Addcode("0",#dash,#dash,#dash,#dash,#dash)
  Addcode("1",#dot,#dash,#dash,#dash,#dash)
  Addcode("2",#dot,#dot,#dash,#dash,#dash)
  Addcode("3",#dot,#dot,#dot,#dash,#dash)
  Addcode("4",#dot,#dot,#dot,#dot,#dash)
  Addcode("5",#dot,#dot,#dot,#dot,#dot) 
  Addcode("6",#dash,#dot,#dot,#dot,#dot) 
  Addcode("7",#dash,#dash,#dot,#dot,#dot) 
  Addcode("8",#dash,#dash,#dash,#dot,#dot)
  Addcode("9",#dash,#dash,#dash,#dash,#dot)
  
  Addcode("&",#dot,#dash,#dot,#dot,#dot)
  Addcode(Chr(39), #dot,#dash,#dash,#dash,#dash,#dot)
  Addcode("@",#dot,#dash,#dash,#dot,#dash,#dot) 
  Addcode(")",#dash,#dot,#dash,#dash,#dot,#dash)
  Addcode("(",#dash,#dot,#dash,#dash,#dot)
  Addcode(":",#dash,#dash,#dash,#dot,#dot,#dot)
  Addcode(",",#dash,#dash,#dot,#dot,#dash,#dash)
  Addcode("=",#dash,#dot,#dot,#dot,#dash)
  Addcode("!",#dash,#dot,#dash,#dot,#dash,#dash)
  Addcode(".",#dot,#dash,#dot,#dash,#dot,#dash)
  Addcode("-",#dash,#dot,#dot,#dot,#dot,#dash) 
  Addcode("*",#dash,#dot,#dot,#dash)
  Addcode("+",#dot,#dash,#dot,#dash,#dot)
  Addcode(Chr(34),#dot,#dash,#dot,#dot,#dash,#dot)
  Addcode("?",#dot,#dot,#dash,#dash,#dot,#dot)
  Addcode("/",#dash,#dot,#dot,#dash,#dot) 
  
EndProcedure 

Structure morse 
  msg.s
  WPM.i 
EndStructure   

Procedure _PlayMorse(*mc.morse) 
  Protected *char.Unicode = @*mc\msg
  Protected speed.f 
  speed = 1200 / *mc\WPM    
  
  If sdot = 0 
    sdot = CreateSound(#dot,speed) 
  EndIf 
  If sdash = 0
    sdash = CreateSound(#dash,speed*3)    
  EndIf   
     
  While *char\u <> 0  
    If *char\u = '.' 
      PlaySound(#dot)
      Delay(speed*2) 
    ElseIf *char\u = '-' 
      PlaySound(#dash)
      Delay(speed*4) 
    Else 
      Delay(speed) 
    EndIf   
    *char+2 
  Wend   
  
  FreeStructure(*mc)
  
EndProcedure   

Procedure PlayMorse(msg.s,WPM,bmorse=1,bthread=0) 
  Protected tid 
  Protected *mc.morse = AllocateStructure(morse) 
  If *mc 
    If bmorse = 0 
      *mc\msg = encodeMorse(msg)
    Else   
      *mc\msg = UCase(msg) 
    EndIf 
    *mc\WPM = WPM 
    If bthread 
      ProcedureReturn CreateThread(@_playmorse(),*mc) 
    Else 
      _playmorse(*mc) 
    EndIf 
  EndIf  
EndProcedure  

Procedure.s EncodeMorse(text.s) 
  Protected msg.s = UCase(text) 
  Protected *char.Unicode = @Msg 
  Protected ct, v, out.s, bdelay = 1    
  Protected a,result.s   
    
  If binit = 0 
    InitMorse() 
    binit = 1 
  EndIf   
    
  While *char\u <> 0 
    
    If amorse(Chr(*char\u))\code <> $ff
      
      If *char\u = '<'  ;if Prosign no delay between chars
        bdelay = 0
        *char + 2
        Continue
      ElseIf *char\u  = '>'
        bdelay = 1
        *char + 2
        Continue
      EndIf
      
      ct = amorse(Chr(*char\u))\count
      
      For a = 0 To amorse(Chr(*char\u))\count
        v = ((amorse(Chr(*char\u))\code >> ct) & 1) + 1
        ct - 1
        If v = 1
          out + ". "
        Else
          out + "- "
        EndIf
      Next
      
      result + out 
      out = "" 
      
      If bdelay
         result + "   " 
      EndIf
      
    Else
      If *char\u = 32
        result + "       "
      EndIf
    EndIf
    *char + 2
  Wend
  
  ProcedureReturn result  
   
EndProcedure

Procedure.s DecodeMorse(msg.s) 
  
  Protected sp,*char.Unicode  
  Protected key.s,tkey.s,out.s 
  
  If binit = 0 
    InitMorse() 
    binit = 1 
  EndIf   
  
  *char = @msg 
  
  While *char\u <> 0  
    
    If *char\u = '.' 
      key + "." 
      sp=1 
    ElseIf *char\u = '-' 
      key + "-"
      sp=1
    ElseIf *char\u = ' '   
      sp+1  
      If (sp > 2 And sp < 7) 
       If key <> "" 
        tkey = amorse(key)\pattern
        If tkey 
          out + tkey 
          key=""
        EndIf   
      EndIf   
      ElseIf sp = 7   
        out + " "
        sp=0
      EndIf   
    EndIf      
    *char + 2
    
  Wend 
  
  ProcedureReturn out 
  
EndProcedure  

CompilerIf #PB_Compiler_IsMainFile 
  Global tid 
  tid = PlayMorse("Hello test <HH> <DDD> <SOS> !" ,30,0,1) 
  WaitThread(tid)
  Global msg.s = "Hello test <HH> <DDD> <SOS> !" 
  msg = encodeMorse(msg)
  Debug msg 
  PlayMorse(msg,30)  
  Debug decodeMorse(msg) 
  Debug decodeMorse("-    .    ...    -        -..-..-..        . -   ")    
CompilerEndIf 

I will repost the recording and audio decoding once I've worked out how to do the timing and AGC but it's working with goertzel filter with minimal spectral leakage, so it will be possible to do multiple frequencies at once.

WIP includes the file above as morse.pb
decodes audio morse but needs adapting for speed and amplitude

Code: Select all

EnableExplicit

Procedure.f goertzel(numSamples,freq,samplerate,*data.float)
    
  Protected omega.f,sine.f,cosine.f,coeff.f,q0.f,q1.f,q2.f,real.f,imag.f
  Protected k,i
  Protected scalingFactor.f = numSamples / 2.0
    
  k = (0.5 + ((numSamples * freq) / samplerate))
  omega = ((2.0 * #PI * k) / numSamples)
  sine = Sin(omega)
  cosine = Cos(omega)
  coeff = 2.0 * cosine
  numSamples-1
  For i = 0 To numSamples
    q0 = coeff * q1 - q2 + *data\f
    q2 = q1
    q1 = q0
    *data+8
  Next 
   
  real = (q1 - q2 * cosine) / scalingFactor
  imag = (q2 * sine) / scalingFactor
  
  ProcedureReturn Sqr(real*real + imag*imag) * 32767
  
EndProcedure 

;- AUDIOCLIENT_ACTIVATION_TYPE
Enumeration
  #AUDIOCLIENT_ACTIVATION_TYPE_DEFAULT
  #AUDIOCLIENT_ACTIVATION_TYPE_PROCESS_LOOPBACK
EndEnumeration

;- PROCESS_LOOPBACK_MODE
Enumeration
  #PROCESS_LOOPBACK_MODE_INCLUDE_TARGET_PROCESS_TREE
  #PROCESS_LOOPBACK_MODE_EXCLUDE_TARGET_PROCESS_TREE
EndEnumeration

#CLSCTX_ALL = #CLSCTX_INPROC_SERVER | #CLSCTX_INPROC_HANDLER | #CLSCTX_LOCAL_SERVER | #CLSCTX_REMOTE_SERVER

#AUDCLNT_SHAREMODE_EXCLUSIVE = 1
#AUDCLNT_STREAMFLAGS_EVENTCALLBACK = $00040000
#AUDCLNT_STREAMFLAGS_LOOPBACK = $00020000

Interface IAudioClient Extends IUnknown
  Initialize(ShareMode.l, StreamFlags.l, hnsBufferDuration.q, hnsPeriodicity.q, *pFormat, *pSessionGuid)
  GetBufferSize(*pNumBufferFrames)
  GetStreamLatency(*phnsLatency)
  GetCurrentPadding(*pNumPaddingFrames)
  IsFormatSupported(ShareMode.l, *pFormat, *ppClosestMatch)
  GetMixFormat(*ppDeviceFormat)
  GetDevicePeriod(*phnsDefaultDevicePeriod, *phnsMinimumDevicePeriod)
  Start()
  Stop()
  Reset()
  SetEventHandle(*EventHandle)
  GetService(*riid, *ppv)
EndInterface

Interface IAudioCaptureClient Extends IUnknown
  GetBuffer(*ppData, *pNumFramesToRead, *pdwFlags, *pu64DevicePosition, *pu64QPCPosition)
  ReleaseBuffer(NumFramesRead.l)
  GetNextPacketSize(*pNumFramesInNextPacket)
EndInterface

Interface IActivateAudioInterfaceAsyncOperation Extends IUnknown
  GetActivateResult(activateResult.i, activatedInterface.i)
EndInterface

Structure BLOB Align #PB_Structure_AlignC
  cbSize.l
  pBlobData.i
EndStructure

Structure PROPVARIANT Align #PB_Structure_AlignC
  vt.w
  wReserved1.w
  wReserved2.w
  wReserved3.w
  blob.BLOB
EndStructure

Structure AUDIOCLIENT_PROCESS_LOOPBACK_PARAMS Align #PB_Structure_AlignC
  TargetProcessId.l 
  ProcessLoopbackMode.l 
EndStructure

Structure AUDIOCLIENT_ACTIVATION_PARAMS Align #PB_Structure_AlignC
  ActivationType.l
  ProcessLoopbackParams.AUDIOCLIENT_PROCESS_LOOPBACK_PARAMS
EndStructure

Structure IUnknownVtbl
  QueryInterface.i
  AddRef.i
  Release.i
EndStructure

Structure ActivateCompletionHandlerVtbl Extends IUnknownVtbl
  ActivateCompleted.i
EndStructure

Global.ActivateCompletionHandlerVtbl g_ActivateCompletionHandlerVtbl

Structure ActivateCompletionHandlerObj
  *vt.ActivateCompletionHandlerVtbl
  refCount.i
EndStructure

Procedure.i ACH_Free(*this.ActivateCompletionHandlerObj)
  Debug #PB_Compiler_Procedure
  
  FreeMemory(*this)
EndProcedure

Procedure.l ACH_QueryInterface(*this.ActivateCompletionHandlerObj, *iid.IID, *Obj.Integer)
  *Obj\i = *this
  *this\refCount + 1
  
  ProcedureReturn #S_OK
EndProcedure

Procedure.l ACH_AddRef(*this.ActivateCompletionHandlerObj)
  *this\refCount + 1
  ProcedureReturn #S_OK
EndProcedure

Procedure.l ACH_Release(*this.ActivateCompletionHandlerObj)
  Protected.l refCount
  
  *this\refCount - 1
  refCount = *this\refCount
  
  If *this\refCount = 0
    ACH_Free(*this)
  EndIf
  
  ProcedureReturn refCount
EndProcedure

#WAVE_FORMAT_IEEE_FLOAT = 3

Procedure SetWaveFormatPCM44100Stereo16(*wf.WAVEFORMATEX)
  *wf\wFormatTag       = #WAVE_FORMAT_IEEE_FLOAT
  *wf\nChannels        = 2
  *wf\nSamplesPerSec   = 44100
  *wf\wBitsPerSample   = 32
  *wf\nBlockAlign      = *wf\nChannels * (*wf\wBitsPerSample / 8)
  *wf\nAvgBytesPerSec  = *wf\nSamplesPerSec * *wf\nBlockAlign
  *wf\cbSize           = 0
EndProcedure

IncludeFile "morse.pb"

Procedure.l ACH_ActivateCompleted(*this.ActivateCompletionHandlerObj, activateOperation.IActivateAudioInterfaceAsyncOperation)
  Protected.l result
  Protected.IAudioClient activatedInterface
  Protected.IAudioCaptureClient captureClient
  Protected streamFlags.l = #AUDCLNT_STREAMFLAGS_EVENTCALLBACK | #AUDCLNT_STREAMFLAGS_LOOPBACK
  Protected waveFmt, hr, bufferFrames
  
  activateOperation\GetActivateResult(@result, @activatedInterface)
  Debug #PB_Compiler_Procedure
  
  If result = #S_OK
    SetWaveFormatPCM44100Stereo16(@waveFmt)
    
    hr = activatedInterface\Initialize(0, streamFlags, 50000, 0, @waveFmt, #Null)
    If hr <> #S_OK
      Debug "Initialize() failed hr=" + Hex(hr)
    EndIf
    
    Protected hEvent.i = CreateEvent_(#Null, 0, 0, #Null)
    If hEvent = 0
      Debug "CreateEvent_ failed"
    EndIf
    
    hr = activatedInterface\SetEventHandle(hEvent)
    If hr <> #S_OK
      Debug "SetEventHandle() failed hr=" + Hex(hr)
      CloseHandle_(hEvent)
    EndIf
    
    hr = activatedInterface\GetService(?IID_IAudioCaptureClient, @captureClient)
    
    If hr <> #S_OK
      Debug "GetService(IAudioRenderClient) failed hr=" + Hex(hr)
      CloseHandle_(hEvent)
    EndIf  
    
    hr = activatedInterface\Start()
    If hr <> #S_OK
      Debug "IAudioClient\Start() failed hr=" + Hex(hr)
      CloseHandle_(hEvent)
    EndIf
    
    Protected numPadding.l, numFramesAvailable.l, flags.l, pNumFramesInNextPacket.l, *Data
    
    Protected mag.f,a,fq = 500
    Static ct,min=3,max=10,out.s,lout.s   
    Static ct1,min1=3,max1=6 
    Repeat
      Protected waitRes = WaitForSingleObject_(hEvent, 500)
      If waitRes = #WAIT_OBJECT_0
        hr = captureClient\GetBuffer(@*data, @numFramesAvailable, @flags, #Null, #Null)
              
          mag = goertzel(numFramesAvailable,fq,44100,*data)
          If mag > 5000
            ct+1 
            If ct1 > 16 And ct1 < 40   
              out + " " 
            ElseIf ct1 > 40  
              out + "       " 
            EndIf
            ct1=0
          Else 
            If (ct > 2 And ct < 9) 
              out + ". "
              ct=0
            ElseIf ct > 9 
              out + "- "
              ct=0
            EndIf 
                        
            ct1 + 1 
            
          EndIf   
           
          If (out <> "" And ct1 > 40)
            If out <> lout 
              PrintN(DecodeMorse(out + " "))
            EndIf   
            lout = out 
          EndIf   
        captureClient\ReleaseBuffer(numFramesAvailable)
      EndIf
          
    ForEver
  EndIf 
  
  ProcedureReturn #S_OK
EndProcedure

g_ActivateCompletionHandlerVtbl\QueryInterface = @ACH_QueryInterface()
g_ActivateCompletionHandlerVtbl\AddRef = @ACH_AddRef()
g_ActivateCompletionHandlerVtbl\Release = @ACH_Release()
g_ActivateCompletionHandlerVtbl\ActivateCompleted = @ACH_ActivateCompleted()

Procedure.i ACH_New()
  Protected.ActivateCompletionHandlerObj *this
  
  *this = AllocateMemory(SizeOf(ActivateCompletionHandlerObj))
  *this\vt = @g_ActivateCompletionHandlerVtbl
  *this\refCount = 1
  
  ProcedureReturn *this
EndProcedure

Global ActivateAudioInterfaceAsync
Prototype.i ActivateAudioInterfaceAsync(deviceInterfacePath.s, *riid.IID, *activationParams.PROPVARIANT, completionHandler.i, activationOperation.i)

If OpenLibrary(0, "Mmdevapi.dll")
  ActivateAudioInterfaceAsync.ActivateAudioInterfaceAsync = GetFunction(0, "ActivateAudioInterfaceAsync")
EndIf

Procedure main(processId)
  Protected.IActivateAudioInterfaceAsyncOperation asyncOp
  Protected.l hr
  Protected.s VIRTUAL_AUDIO_DEVICE_PROCESS_LOOPBACK
  Protected.AUDIOCLIENT_ACTIVATION_PARAMS audioclientActivationParams
  Protected.PROPVARIANT activateParams
  Protected.ActivateCompletionHandlerObj *ach
  Protected.s deviceID
  Protected.i is
  
  hr = CoInitializeEx_(#Null, #COINIT_MULTITHREADED)
  If hr <> #S_OK
    Debug "CoInitialize_ failed, hr=" + Hex(hr)
    End
  EndIf
  
  *ach = ACH_New()
  
  audioclientActivationParams\ProcessLoopbackParams\ProcessLoopbackMode = #PROCESS_LOOPBACK_MODE_INCLUDE_TARGET_PROCESS_TREE
  audioclientActivationParams\ProcessLoopbackParams\TargetProcessId = processId
  audioclientActivationParams\ActivationType = #AUDIOCLIENT_ACTIVATION_TYPE_PROCESS_LOOPBACK
  
  activateParams\vt = #VT_BLOB
  activateParams\blob\cbSize = SizeOf(AUDIOCLIENT_ACTIVATION_PARAMS)
  activateParams\blob\pBlobData = @audioclientActivationParams
  
  hr = ActivateAudioInterfaceAsync("VAD\Process_Loopback", ?IID_IAudioClient, @activateParams, *ach, @asyncOp)
  
  ACH_Release(*ach)
  
  If asyncOp
    asyncOp\Release()
  EndIf
  
  If hr <> #S_OK
    Debug "ActivateAudioInterfaceAsync() failed hr=" + Hex(hr)
    End
  EndIf
  
EndProcedure

Procedure ACH_Close() 
  CloseLibrary(0) 
EndProcedure   

Define pid = GetCurrentProcessId_(); 
Debug pid 
OpenConsole() 
InitSound()

CreateThread(@main(), pid) 

Global tid 
  
 tid = PlayMorse("audio decoding morse by idle, credit to AndyMK and Infratec bye !" ,30,0,1) 
 WaitThread(tid)
 
 Input()
 
DataSection
  IID_IAudioClient:
  Data.l $1CB9AD4C
  Data.w $DBFA,$4c32
  Data.b $B1, $78, $C2, $F5, $68, $A7, $03, $B2
EndDataSection

DataSection
  IID_IAudioCaptureClient:
  Data.l $C8ADBD64
  Data.w $E71E,$48A0
  Data.b $A4,$DE,$18,$5C,$39,$5C,$D3,$17
EndDataSection

ACH_Close()

I still need to adapt it for dynamic amplitude and speed like make it adaptive for onMin onMax / offMin offMax
While it's working fine on my box doesn't mean it will work on another.

[idle]

updated previous post with WIP. Tested on windows 11. The message is at line 322
compile with thread safe!