Announcement

Collapse
No announcement yet.

PB/DOS - Soundex function

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PB/DOS - Soundex function

    Code:
    '------------------------------------------------------------------------------
    '      Unit: soundex.pbl
    '     Zweck: Phonetische Ähnlichkeit von Zeichenketten (Namen) beurteilen
    '     Stand: 11.12.94
    '   Version: 1.00
    '     Autor: (C) PC-Magazine USA; angepaßt M.Hoffmann
    '   Sprache: PowerBASIC 3.x
    '------------------------------------------------------------------------------
    
    $com      0
    $compile  unit
    $cpu      80386
    $debug    map-,pbdebug-,path-,unit-
    $dim      all
    $error    bounds-,numeric-,overflow-,stack-
    $event    off
    $float    emulate
    $lib      com-,lpt-,cga-,ega-,vga-,fullfloat-,iprint-
    $optimize size
    $option   cntlbreak-,gosub-,signed-
    $sound    0
    $stack    &h800
    $static
    $string   1
    
    function soundex (text as string, count as integer) public as string
    
       dim word as local string
       dim code as local string
       dim snd  as local string
       dim i    as local integer
       dim e    as local byte
       dim this as local string
       dim prev as local string
       dim l    as local integer
    
       word = ucase$(Text$)
       do until instr(word,"Ä") = 0
          replace "Ä" with "AE" in word
       loop
       do until instr(word,"Ö") = 0
          replace "Ö" with "OE" in word
       loop
       do until instr(word,"Ü") = 0
          replace "Ü" with "UE" in word
       loop
       do until instr(word,"ß") = 0
          replace "ß" with "SS" in word
       loop
    
       code = "01230120022455012623010202"
       rem -> "abcdefghijklmnopqrstuvwxyz"
     ' snd  = left$(word,1)    Originalcodierung: 1.Zeichen zurückgeben
       if count = 0 then
          l = len(word)
       else
          l = count
       end if
    
       for i=1 to len(word)  ' Original: i=2
          e = ascii(mid$(word,i,1))-64
          if e > 0 and e < 27 then
             this = mid$(code,e,1)
             if ascii(this) <> 0 and this <> prev then
                snd  = snd+this
                prev = this
             end if
          end if
       next i
    
       soundex = left$(snd,l) ' Original: left$(snd+"0000",l)
    
    end function
    ------------------
Working...
X