PureBasic Forums - English

Code: Select all

;**
;   SoundexC()
;   Convert a string To a soundex code (C-callable).
;
;	"Soundex" algorithm is standard Odell/Russell (1918):
;
;	Produce a code of the form "letter, digit, digit, digit"
;	using these rules:
;
;	1)	Retain the first letter unchanged.
;
;	2)	For each succeeding letter, produce a result based
;		on the following table:
;
;		letter							result
;
;		B, F, P, V						digit 1
;		C, G, J, K, Q, S, X, Z			digit 2
;		D, T							digit 3
;		L								digit 4
;		M, N							digit 5
;		R								digit 6
;		A, E, H, I, O, U, W, Y			(nothing)
;
;
;	3)	If two Or more adjacent letters produce the same
;		result IN Step 2, ignore all but the first of the
;		adjacent letters.
;
;	4)  Repeat steps 2 And 3 Until three digits have been
;		produced Or Until the source is exhausted.
;
;	5)	If less than three digits were produced, right-fill
;		With zeros.
;
;
;	Notes:
;
;	Non-alpha characters are ignored entirely; letters which
;	are separated only by non-alpha characters are considered
;	adjacent.  If the source contains no alpha characters, a
;	value of "0000" is returned.
;
;	Case is Not significant.
;
;	Letters which produce (nothing) IN Step 2 are still
;	significant With respect To Step 3.  That is, two letters
;	which produce the same digit are Not considered adjacent
;	If they are separated by a letter that produces (nothing).
;	This is IN accordance With the original algorithm.
;
;	This C-callable function returns a pointer To a Static
;	buffer.  The buffer is overwritten by successive calls.
;/

EnableExplicit

#SOUNDEX_LENGTH = 4

Macro IsAlpha(c)
  ((c) >= "a" And (c) <= "z") Or ((c) >= "A" And (c) <= "Z")
EndMacro


Procedure Step2(Char.s)
  Protected Result

  Select Char
    Case "B", "F", "P", "V"
      Result = 1
  
    Case "C", "G", "J", "K", "Q", "S", "X", "Z"
      Result = 2
  
    Case "D", "T"
      Result = 3
  
    Case "L"
      Result = 4
  
    Case "M", "N":
      Result = 5
  
    Case "R"
      Result = 6
  
    Case "A", "E", "H", "I", "O", "U", "W", "Y"
      ;~ Return (NIL);
      Result = #Null
  
    Default 
      ;~ /* bad param -- Return something obviously wrong */
      Result =  9
  EndSelect
  
  ProcedureReturn Result
EndProcedure


Procedure.s SoundexC(Source.s)
  Protected i
  Protected Char.s{1}
  Protected Result
  Protected Previous
  Protected Length = Len(Source)
  Protected Code.s

  For i = 1 To Length
    Char = UCase(Mid(Source, i, 1))
    If (IsAlpha(Char))
      Result = Step2(Char)
      If (i = 1)
        Code + Char
      ElseIf ((Result <> #Null)  And (Result <> Previous))
        Code + Str(Result)
      EndIf
      Previous = Result
    EndIf
  Next  
  Code = LSet(Code, #SOUNDEX_LENGTH, "0")

  ProcedureReturn Code
EndProcedure


Procedure.s SoundEx(sText.s)
  Protected sCode.s

  If (Len(sText) >= 1) And IsAlpha(Left(sText, 1))
    sCode = SoundexC(sText)
  Else
    sCode = "0000"
  EndIf

  ProcedureReturn sCode
EndProcedure


Debug SoundEx("kakaoudas")           ; It must be K232
Debug SoundEx("Thanos Douros")       ; It must be T523
Debug SoundEx("DUROS ATHANASIOS")    ; It must be D623
Debug SoundEx("ntouros athanasios")  ; It must be N362 BUT RETURNS 0000 which is an empty string
Debug SoundEx("kakao")               ; It must be K200
Debug SoundEx("nounou")              ; It must be N500
Debug SoundEx("elephant")            ; It must be E415

Code: Select all

Macro IsAlpha(c)
  ((c) >= "a" And (c) <= "z") Or ((c) >= "A" And (c) <= "Z")
EndMacro