!***********************
! CODE 1 - METAPHON.CLW
!***********************
  MEMBER('YourProg')  !*** Change to match your Application
!==============================================================================
  MAP
    M::Init(STRING,BYTE),BYTE
    M::Append(STRING)
    M::IsDoubleLetter(BYTE),BYTE
  END!MAP
!==============================================================================
E::MaxNameLen        EQUATE(250)
E::MaxMetaphLen      EQUATE(250)
E::DefMetaphLen      EQUATE(5)
!==============================================================================
M::Name              STRING(E::MaxNameLen),THREAD
M::Metaph            STRING(E::MaxMetaphLen),THREAD
M::MetaphLen         BYTE,THREAD
M::MaxMetaphLen      BYTE,THREAD
!==============================================================================
Metaphone            FUNCTION(P::Name,P::MetaphLen)

L::Vowels            STRING('AEIOU')
L::FrontV            STRING('EIY')
L::VarSon            STRING('CSPTG')  !Modified when followed by 'H'

L::Hard              BYTE(False)  !Boolean
L::Silent            BYTE,AUTO    !Boolean
L::Symb              STRING(1),AUTO
L::L                 BYTE,AUTO
L::N                 BYTE,AUTO

  CODE
  IF NOT M::Init(P::Name,P::MetaphLen)
    RETURN('')
  END!IF
  CASE M::Name[1:2]
  OF 'WH'
    M::Name = 'W' & M::Name[3 : SIZE(M::Name)]
  OF 'AA'
    M::Name = 'E' & M::Name[3 : SIZE(M::Name)]
  OF 'PN' OROF 'AE' OROF 'KN' OROF 'GN' OROF 'WR'
    M::Name = M::Name[2 : SIZE(M::Name)]
  ELSE
    IF M::Name[1] = 'X'
      M::Name = 'S' & M::Name[2 : SIZE(M::Name)]
    END!IF
  END!CASE
  L::L = LEN(CLIP(M::Name))
  LOOP L::N = 1 TO L::L
    IF M::MetaphLen >= M::MaxMetaphLen  !Done
      BREAK
    END!IF
    L::Symb = M::Name[L::N]
    IF NOT M::IsDoubleLetter(L::N)
      IF INSTRING(L::Symb,L::Vowels) AND L::N = 1
        M::Append(L::Symb)
      ELSE
        CASE L::Symb
        OF 'B'
          L::Silent = CHOOSE(L::N = L::L AND M::Name[L::N-1] = 'M',True,False)
          IF NOT L::Silent
            M::Append(L::Symb)
          END!IF
        OF 'C'
          IF NOT (L::N > 1 AND M::Name[L::N-1] = 'S' |
          AND INSTRING(M::Name[L::N+1],L::FrontV))
            IF M::Name[L::N+1] = 'I' AND M::Name[L::N+2] = 'A'
              M::Append('X')
            ELSE
              IF INSTRING(M::Name[L::N+1],L::FrontV)
                M::Append('S')
              ELSE
                IF L::N > 1 AND M::Name[L::N+1] = 'H' AND M::Name[L::N-1] = 'S'
                  IF NOT INSTRING(M::Name[L::N+2],L::Vowels)
                    M::Append('X')
                  ELSE
                    M::Append('K')
                  END!IF
                ELSE
                  IF M::Name[L::N+1] = 'H'
                    IF L::N = 1 AND INSTRING(M::Name[L::N+2],L::Vowels & 'R')
                      M::Append('K')
                    ELSE
                      M::Append('X')
                    END!IF
                  ELSIF M::Name[L::N+1] <> 'K'
                    M::Append('K')
                  END!IF
                END!IF
              END!IF
            END!IF
          END!IF
        OF 'D'
          IF M::Name[L::N+1] = 'G' AND INSTRING(M::Name[L::N+2],L::FrontV)
            M::Append('J')
          ELSIF M::Name[L::N+1] = 'T' AND L::N+1 = L::L
          ELSE
            M::Append('T')
          END!IF
        OF 'G'
          IF M::Name[L::N+1] = 'H' AND INSTRING(M::Name[L::N+2],L::Vowels)
            L::Silent = True
          ELSIF L::N > 1 AND M::Name[L::N-1] = 'D' |
          AND INSTRING(M::Name[L::N+1],L::FrontV,1)
            L::Silent = True
          ELSIF L::N > 1 AND (L::N+1 = L::L OR (L::N+3 = L::L  |
          AND M::Name[L::N+1 : L::N+3] = 'NED'))
            L::Silent = True
          ELSE
            L::Silent = False
          END!IF
          L::Hard = CHOOSE(L::N > 1 AND M::Name[L::N-1] = 'G',True,False)
          IF NOT L::Silent
            IF INSTRING(M::Name[L::N+1],L::FrontV) AND NOT L::Hard
              M::Append('J')
            ELSE
              M::Append('K')
            END!IF
          END!IF
        OF 'H'
          IF NOT (L::N = L::L OR (L::N > 1  |
          AND INSTRING(M::Name[L::N-1],L::VarSon)))
            IF INSTRING(M::Name[L::N+1],L::Vowels)
              M::Append('H')
            END!IF
          END!IF
        OF 'F' OROF 'J' OROF 'K' OROF 'L' OROF 'M' OROF 'N' OROF 'R'
          M::Append(L::Symb)
        OF 'P'
          IF M::Name[L::N+1] = 'H'
            M::Append('F')
          ELSE
            M::Append('P')
          END!IF
        OF 'Q'
          M::Append('K')
        OF 'S'
          IF L::N > 1 AND M::Name[L::N+1] = 'I'  |
          AND INSTRING(M::Name[L::N+2],'OA')  !Mansion
            M::Append('X')
          ELSE
            IF M::Name[L::N+1] = 'H'
              M::Append('X')
            ELSE
              M::Append('S')
            END!IF
          END!IF
        OF 'T'
          IF L::N > 1 AND M::Name[L::N+1] = 'I'  |
          AND INSTRING(M::Name[L::N+2],'OA')  !Station
            M::Append('X')
          ELSE
            IF M::Name[L::N+1] = 'H'  !Thumb, Thomas
              M::Append('T')  !Not a great match. Original metaphopne used '0'
            ELSIF M::Name[L::N+1 : L::N+2] = 'CH'  !Kitchen
              M::Append('X')
            ELSE
              M::Append('T')
            END!IF
          END!IF
        OF 'V'
          M::Append('F')
        OF 'W' OROF 'Y'
          IF INSTRING(M::Name[L::N+1],L::Vowels)
            M::Append(L::Symb)
          END!IF
        OF 'X'
          M::Append('KS')
        OF 'Z'
          M::Append('S')
        END!CASE
      END!IF
    END!IF
  END!LOOP
  RETURN(M::Metaph)
!==============================================================================
M::Init              FUNCTION(P::Name,P::MaxMetaphLen)

L::Symb              STRING(1),AUTO
L::L                 BYTE(0)
L::S                 BYTE,AUTO

  CODE
  M::Metaph = ''
  M::MetaphLen = 0
  IF NOT P::MaxMetaphLen
    M::MaxMetaphLen = E::DefMetaphLen
  ELSIF P::MaxMetaphLen = E::MaxMetaphLen
    M::MaxMetaphLen = E::MaxMetaphLen
  ELSE
    M::MaxMetaphLen = P::MaxMetaphLen
  END!IF
  !-----
  M::Name = ''
  LOOP L::S = 1 TO LEN(CLIP(P::Name))
    L::Symb = UPPER(P::Name[L::S])
    IF INRANGE(L::Symb,'A','Z')
      L::L += 1
      M::Name[L::L] = L::Symb
    END!IF
  END!LOOP
  !-----
  RETURN(CHOOSE(M::Name='',False,True))
!==============================================================================
M::Append            PROCEDURE(P::String)

L::Len               BYTE,AUTO

  CODE
  L::Len = LEN(CLIP(P::String))
  IF L::Len = 1
    M::MetaphLen += 1
    M::Metaph[M::MetaphLen] = P::String
  ELSIF M::MetaphLen + L::Len > M::MaxMetaphLen
    M::Metaph[M::MetaphLen+1 : M::MaxMetaphLen] = P::String
    M::MetaphLen = M::MaxMetaphLen
  ELSE
    M::Metaph[M::MetaphLen+1 : M::MetaphLen+L::Len] = P::String
    M::MetaphLen += L::Len
  END!IF
!==============================================================================
M::IsDoubleLetter    FUNCTION(P::N)

  CODE
  IF P::N > 1
    IF M::Name[P::N] = M::Name[P::N-1]
      RETURN(True)
    END!IF
  END!IF
  RETURN(False)
