home *** CD-ROM | disk | FTP | other *** search
/ Power CD-ROM!! 7 / POWERCD7.ISO / prgmming / clipper / fonetix.prg < prev    next >
Text File  |  1993-10-14  |  13KB  |  453 lines
  1. /*
  2.  * GT CLIPPER STANDARD HEADER
  3.  *
  4.  * File......: fonetix.prg
  5.  * Author....: Andy M Leighton
  6.  * BBS.......: The Dark Knight Returns
  7.  * Net/Node..: 050/069
  8.  * User Name.: Andy Leighton
  9.  * Date......: $Date$
  10.  * Revision..: $Revision$
  11.  *
  12.  * This is an original work by Andy Leighton and is placed in the
  13.  * public domain.
  14.  *
  15.  * Modification history:
  16.  * ---------------------
  17.  *
  18.  * $Log$
  19.  *
  20.  */
  21.  
  22. /*  $DOC$
  23.  *  $FUNCNAME$
  24.  *       GT_FONETIX()
  25.  *  $CATEGORY$
  26.  *       String
  27.  *  $ONELINER$
  28.  *       Make a phonetic match string
  29.  *  $SYNTAX$
  30.  *       GT_Fonetix(<cStr>) --> cFonStr
  31.  *  $ARGUMENTS$
  32.  *      <cStr>    -  The input string
  33.  *  $RETURNS$
  34.  *      cFonStr   -  A phonetic representation of the input string
  35.  *  $DESCRIPTION$
  36.  *      Make a phonetic match string for a passed string.
  37.  *      Only works in english.  Words with foreign roots
  38.  *      may not match very well.  Words with more than one
  39.  *      syllable also translate poorly in some cases.
  40.  *      However this approach seems to match most intelligent
  41.  *      misspellings and most of those made by children.
  42.  *      Note the order in which these rules are applied are
  43.  *      important, nevertheless please feel free to experiment
  44.  *      with reordering or even adding new rules, after all you
  45.  *      know what kind of strings/names are going to be matched.
  46.  *
  47.  *      Rules for producing the phonetic string
  48.  *
  49.  *      1.  Uppercase <cStr>
  50.  *
  51.  *      2.  Replace KN with N                       (Knight)
  52.  *
  53.  *      3.  Replace GN with N                       (Gnome)
  54.  *
  55.  *      4.  Replace WR with R                       (Wright)
  56.  *
  57.  *      5.  Replace WH with H if WH is followed by O
  58.  *
  59.  *      6.  Replace WH with W if WH isn't follwed by O
  60.  *                                                   (Whately)
  61.  *
  62.  *      7.  Replace MC with MK
  63.  *
  64.  *      8.  Replace MAC with MK
  65.  *
  66.  *      9.  Replace EIGH with AY
  67.  *          (Can't have it not matching *my* name :-)
  68.  *
  69.  *     10.  Replace IGHT with ITE                   (Wright)
  70.  *
  71.  *     11.  Replace C with S if followed by E, I or Y
  72.  *
  73.  *     12.  Replace C with K if not followed by E, I, Y, H
  74.  *
  75.  *     13.  Replace D[JG] with J
  76.  *
  77.  *     14.  Replace G with J if followed by E, I, or Y
  78.  *
  79.  *     15.  Replace GH with H
  80.  *
  81.  *     16.  Replace PH with F
  82.  *
  83.  *     17.  Replace Q with KW
  84.  *
  85.  *     18.  Replace TI with SH if it is followed by a vowel and
  86.  *          is not at start of a word
  87.  *
  88.  *     19.  Replace X with KS
  89.  *
  90.  *     20   Replace Y with I if it is not the first or last
  91.  *          character
  92.  *
  93.  *     21.  Replace Z with S
  94.  *
  95.  *     22.  Replace MB with M if MB is at end of string (thanks METAPH.PRG)
  96.  *
  97.  *     23.  Replace double consonants with just one of 'em
  98.  *
  99.  *     24.  Replace AIT with ATE
  100.  *
  101.  *     25.  Replace IE at end of word with Y
  102.  *
  103.  *     26.  Replace LE with L
  104.  *
  105.  *     27.  TERN at end of word gets replaced with TN
  106.  *
  107.  *     28.  EVE is replaced with EFE
  108.  *
  109.  *     29   Replace the schwa sound with "" if succeeded by
  110.  *          R, L, M, N
  111.  *
  112.  *     30.  Replace SCH with SH
  113.  *
  114.  *     31.  ARY, IRY, ORY, ERY all get replaced with RY if
  115.  *          at end of word
  116.  *
  117.  *     32.  Replace OO with U
  118.  *
  119.  *     33.  Replace OI with OY
  120.  *
  121.  *     34.  Remove vowels at end of word
  122.  *
  123.  *     35.  Replace all vowel groups with just the first
  124.  *          vowel in the group (you can try last as well)
  125.  *
  126.  *  $EXAMPLES$
  127.  *     use PERSONS                     // assume a personnel table
  128.  *
  129.  *     index on GT_fonetix(PERSONS->LAST_NAME) to LASTNAME
  130.  *
  131.  *     seek GT_fonetix("Leighton")
  132.  *     ? found(), PERSONS_LAST_NAME    // .T., Leighton
  133.  *
  134.  *     seek GT_fonetix("Layton")
  135.  *     ? found(), PERSONS->LAST_NAME   // .T., Leighton
  136.  *
  137.  *     Also compile with -DTEST
  138.  *  $REFERENCES$
  139.  *     .EXE Magazine Vol 4, Issue 3
  140.  *     Soundex()
  141.  *     METAPH.PRG in nanfor.lib
  142.  *  $END$
  143.  */
  144.  
  145. #include "gt_LIB.ch"
  146.  
  147. // a translate to make the code read nicer
  148.  
  149. #translate REPLACERULE(<cStr>, <cPhoneme>, <cRepl>) =>               ;
  150.                      iif(<cPhoneme> $ <cStr>,                        ;
  151.                               strtran(<cStr>, <cPhoneme>, <cRepl>),  ;
  152.                               <cStr>)
  153.  
  154. /*
  155.  * TEST HARNESS
  156.  *
  157.  * create a tbrowse of names, and their GT_Fonetix() equivalents
  158.  */
  159.  
  160. #ifdef TEST
  161. #include "inkey.ch"
  162.  
  163. static aNames := {}
  164.  
  165. function main()
  166.  
  167.    local tb, i, nKey
  168.  
  169.    cls
  170.  
  171.    aadd(aNames, "Adams"        )
  172.    aadd(aNames, "Addams"       )
  173.    aadd(aNames, "Smith"        )
  174.    aadd(aNames, "Smythe"       )
  175.    aadd(aNames, "Naylor"       )
  176.    aadd(aNames, "Nailer"       )
  177.    aadd(aNames, "Holberry"     )
  178.    aadd(aNames, "Wholebary"    )
  179.    aadd(aNames, "Jackson"      )
  180.    aadd(aNames, "Jaksun"       )
  181.    aadd(aNames, "Fischer"      )
  182.    aadd(aNames, "Fisher"       )
  183.    aadd(aNames, "Knight"       )
  184.    aadd(aNames, "Nite"         )
  185.    aadd(aNames, "Stephens"     )
  186.    aadd(aNames, "Stevens"      )
  187.    aadd(aNames, "Neilson"      )
  188.    aadd(aNames, "Nelson"       )
  189.    aadd(aNames, "Wright"       )
  190.    aadd(aNames, "Write"        )
  191.    aadd(aNames, "Right"        )
  192.    aadd(aNames, "McLean"       )
  193.    aadd(aNames, "McLane"       )
  194.    aadd(aNames, "Maclean"      )
  195.    aadd(aNames, "Leighton"     )
  196.    aadd(aNames, "Layton"       )
  197.    aadd(aNames, "Whately"      )
  198.    aadd(aNames, "Waitly"       )
  199.    aadd(aNames, "Swaine"       )
  200.    aadd(aNames, "Swane"        )
  201.    aadd(aNames, "Codie"        )
  202.    aadd(aNames, "Cody"         )
  203.    aadd(aNames, "Griffon"      )
  204.    aadd(aNames, "Griphon"      )
  205.    aadd(aNames, "Gryphon"      )
  206.    aadd(aNames, "Pearson"      )
  207.    aadd(aNames, "Peerson"      )
  208.    aadd(aNames, "Peersun"      )
  209.    aadd(aNames, "Chilton"      )
  210.    aadd(aNames, "Chiltern"     )
  211.    aadd(aNames, "Chiltun"      )
  212.  
  213.    i := 1
  214.    tb := tbrowseNew(1, 1, 23, 78)
  215.    tb:addColumn(tbColumnNew(padc("Name", 25),                           ;
  216.                             {|| padc(aNames[i], 25)}))
  217.    tb:addColumn(tbColumnNew(padc("Phoneme", 25),                        ;
  218.                             {|| padc(GT_FONETIX(aNames[i]), 25)}))
  219.    tb:skipBlock := {|SkipCnt| SkipIt(@i, SkipCnt, len(aNames)) }
  220.    tb:goTopBlock := {|| i := 1}
  221.    tb:goBottomBlock := {|| i := len(aNames)}
  222.  
  223.    do while lastkey() != K_ESC
  224.       do while nextkey() = 0 .and. !tb:stabilize()
  225.       enddo
  226.       nKey = inkey(0)
  227.       do case
  228.          case nKey = K_DOWN
  229.                tb:down()
  230.          case nKey = K_UP
  231.                tb:up()
  232.          case nKey = K_PGDN
  233.                tb:pagedown()
  234.          case nKey = K_PGUP
  235.                tb:pageup()
  236.          case nKey = K_CTRL_PGUP
  237.                tb:gotop()
  238.          case nKey = K_CTRL_PGDN
  239.                tb:gobottom()
  240.       endcase
  241.    enddo
  242.  
  243.    cls
  244.  
  245. return NIL
  246.  
  247. static function SkipIt(ele, skip_cnt, maxval)
  248.  
  249.    local movement := 0                 // this will be returned to TBROWSE
  250.  
  251.    if skip_cnt > 0
  252.       do while ele + movement < maxval .and. movement < skip_cnt
  253.          movement++
  254.       enddo
  255.  
  256.    elseif skip_cnt < 0
  257.       do while ele + movement > 1 .and. movement > skip_cnt
  258.          movement--
  259.       enddo
  260.    endif
  261.    ele += movement
  262.  
  263. return movement
  264.  
  265. #endif
  266.  
  267. /* */
  268.  
  269. function GT_fonetix(cStr)
  270.  
  271.    local cPhone := upper(cStr)
  272.    local nPtr   := 1
  273.  
  274.    cPhone := REPLACERULE(cPhone, "KN", "N")
  275.    cPhone := REPLACERULE(cPhone, "GN", "N")
  276.    cPhone := REPLACERULE(cPhone, "WR", "R")
  277.    cPhone := REPLACERULE(cPhone, "WHO", "HO")
  278.    cPhone := REPLACERULE(cPhone, "WH", "W")
  279.    cPhone := REPLACERULE(cPhone, "MAC", "MK")
  280.    cPhone := REPLACERULE(cPhone, "MC", "MK")
  281.    cPhone := REPLACERULE(cPhone, "EIGH", "AY")
  282.    cPhone := REPLACERULE(cPhone, "IGHT", "ITE")
  283.  
  284.    cPhone := REPLACERULE(cPhone, "CE", "S")
  285.    cPhone := REPLACERULE(cPhone, "CI", "S")
  286.    cPhone := REPLACERULE(cPhone, "CY", "S")
  287.  
  288. /*
  289.  * do not split the following 3 rules on pain of death
  290.  */
  291.    cPhone := REPLACERULE(cPhone, "CH", "||")
  292.    cPhone := REPLACERULE(cPhone, "C",  "K")
  293.    cPhone := REPLACERULE(cPhone, "||", "CH")
  294.  
  295.    cPhone := REPLACERULE(cPhone, "DG", "J")
  296.    cPhone := REPLACERULE(cPhone, "DJ", "J")
  297.  
  298.    cPhone := REPLACERULE(cPhone, "GE", "JE")
  299.    cPhone := REPLACERULE(cPhone, "GI", "JY")
  300.    cPhone := REPLACERULE(cPhone, "GY", "JY")
  301.  
  302.    cPhone := REPLACERULE(cPhone, "GH", "H")
  303.  
  304.    cPhone := REPLACERULE(cPhone, "PH", "F")
  305.    cPhone := REPLACERULE(cPhone, "Q", "KW")
  306.  
  307. /*
  308.  * do not split the TI rules on pain of death
  309.  */
  310.  
  311.    if substr(cPhone, 1, 2) == "TI"
  312.       cPhone := "||" + substr(cPhone, 3)
  313.    endif
  314.    cPhone := REPLACERULE(cPhone, "TION", "SHUN")
  315.    cPhone := REPLACERULE(cPhone, "TIA", "SHA")
  316.    cPhone := REPLACERULE(cPhone, "TIE", "SHE")
  317.    cPhone := REPLACERULE(cPhone, "TII", "SHI")       // ???
  318.    cPhone := REPLACERULE(cPhone, "TIO", "SHO")
  319.    cPhone := REPLACERULE(cPhone, "TIU", "SHU")
  320.    cPhone := REPLACERULE(cPhone, "||", "TI")
  321.  
  322.    cPhone := REPLACERULE(cPhone, "X", "KS")
  323.  
  324. /*
  325.  * do not split the Y rules on pain of death
  326.  */
  327.    if substr(cPhone, 1, 1) == "Y"
  328.       cPhone := "|" + substr(cPhone, 2)
  329.    endif
  330.    if substr(cPhone, len(cPhone), 1) == "Y"
  331.       cPhone := substr(cPhone, 1, len(cPhone) - 1) + '|'
  332.    endif
  333.    cPhone := REPLACERULE(cPhone, "Y", "I")
  334.    cPhone := REPLACERULE(cPhone, "|", "Y")
  335.  
  336.    cPhone := REPLACERULE(cPhone, "Z", "S")
  337.  
  338.    if substr(cPhone, len(cPhone) - 1, 2) == 'MB'
  339.       cPhone := substr(cPhone, 1, len(cPhone) - 1)
  340.    endif
  341.  
  342. /*
  343.  * double consonants NOTE no C, Q, X, or Z
  344.  * they have been replaced away already
  345.  */
  346.  
  347.    cPhone := REPLACERULE(cPhone, "BB", "B")
  348.    cPhone := REPLACERULE(cPhone, "DD", "D")
  349.    cPhone := REPLACERULE(cPhone, "FF", "F")
  350.    cPhone := REPLACERULE(cPhone, "GG", "G")
  351.    cPhone := REPLACERULE(cPhone, "HH", "H")
  352.    cPhone := REPLACERULE(cPhone, "JJ", "J")
  353.    cPhone := REPLACERULE(cPhone, "KK", "K")
  354.    cPhone := REPLACERULE(cPhone, "LL", "L")
  355.    cPhone := REPLACERULE(cPhone, "MM", "M")
  356.    cPhone := REPLACERULE(cPhone, "NN", "N")
  357.    cPhone := REPLACERULE(cPhone, "PP", "P")
  358.    cPhone := REPLACERULE(cPhone, "RR", "R")
  359.    cPhone := REPLACERULE(cPhone, "SS", "S")
  360.    cPhone := REPLACERULE(cPhone, "TT", "T")
  361.    cPhone := REPLACERULE(cPhone, "VV", "V")
  362.    cPhone := REPLACERULE(cPhone, "WW", "W")
  363.  
  364.    cPhone := REPLACERULE(cPhone, "LE", "L")
  365.  
  366.    if substr(cPhone, len(cPhone) - 3, 4) == 'TERN'
  367.       cPhone := substr(cPhone, 1, len(cPhone) - 4) + "TN"
  368.    endif
  369.    cPhone := REPLACERULE(cPhone, "EVE", "EFE")
  370.  
  371.    cPhone := gGT_FoneSchwa(cPhone, "E", "R")
  372.    cPhone := gGT_FoneSchwa(cPhone, "E", "L")
  373.    cPhone := gGT_FoneSchwa(cPhone, "E", "M")
  374.    cPhone := gGT_FoneSchwa(cPhone, "E", "N")
  375.    cPhone := gGT_FoneSchwa(cPhone, "OU", "R")
  376.    cPhone := gGT_FoneSchwa(cPhone, "OU", "L")
  377.    cPhone := gGT_FoneSchwa(cPhone, "OU", "M")
  378.    cPhone := gGT_FoneSchwa(cPhone, "OU", "N")
  379.    cPhone := gGT_FoneSchwa(cPhone, "O", "R")
  380.    cPhone := gGT_FoneSchwa(cPhone, "O", "L")
  381.    cPhone := gGT_FoneSchwa(cPhone, "O", "M")
  382.    cPhone := gGT_FoneSchwa(cPhone, "O", "N")
  383.    cPhone := gGT_FoneSchwa(cPhone, "I", "R")
  384.    cPhone := gGT_FoneSchwa(cPhone, "I", "L")
  385.    cPhone := gGT_FoneSchwa(cPhone, "I", "M")
  386.    cPhone := gGT_FoneSchwa(cPhone, "I", "N")
  387.    cPhone := gGT_FoneSchwa(cPhone, "U", "R")
  388.    cPhone := gGT_FoneSchwa(cPhone, "U", "L")
  389.    cPhone := gGT_FoneSchwa(cPhone, "U", "M")
  390.    cPhone := gGT_FoneSchwa(cPhone, "U", "N")
  391.  
  392.    cPhone := REPLACERULE(cPhone, "SCH", "SH")
  393.  
  394.    cPhone := REPLACERULE(cPhone, "OO", "U")
  395.    cPhone := REPLACERULE(cPhone, "OI", "OY")
  396.  
  397.    if substr(cPhone, len(cPhone) - 1, 2) == 'IE'
  398.       cPhone := substr(cPhone, 1, len(cPhone) - 2) + "Y"
  399.    endif
  400.  
  401.    if substr(cPhone, len(cPhone) - 1, 2) == 'RY'
  402.       if substr(cPhone, len(cPhone) - 2, 1) $ [AEIOUY]
  403.          cPhone := substr(cPhone, 1, len(cPhone) - 3) + "RY"
  404.       endif
  405.    endif
  406.  
  407. /*
  408.  * remove trailing vowels
  409.  */
  410.    do while substr(cPhone, len(cPhone), 1) $ [AEIOU]
  411.       cPhone := substr(cPhone, 1, len(cPhone) - 1)
  412.    enddo
  413.  
  414.    do while nPtr <= len(cPhone)
  415.       if substr(cPhone, nPtr, 1) $ [AEIOU]
  416.          do while substr(cPhone, nPtr + 1, 1) $ [AEIOU]
  417.             cPhone := substr(cPhone, 1, nPtr) + substr(cPhone, nPtr + 2)
  418.          enddo
  419.       endif
  420.       nPtr++
  421.    enddo
  422.  
  423. return cPhone
  424.  
  425.  
  426.  
  427.  
  428. /*
  429.  * Internal Function: gGT_FoneSchwa()
  430.  *
  431.  * handle a schwa phoneme.
  432.  *
  433.  * A schwa is the er or uh sound for example the o in carbon.
  434.  *
  435.  */
  436.  
  437. function gGT_FoneSchwa(cPhone, cSchwa, cFollow)
  438.  
  439.    local nPos
  440.  
  441.    do while (cSchwa + cFollow) $ cPhone
  442.       nPos := at(cSchwa + cFollow, cPhone)
  443.  
  444.       if substr(cPhone, nPos - 1, 1) $ [BDGFJKLMPRSTVW]
  445.          cPhone := substr(cPhone, 1, nPos - 1) +;
  446.                    substr(cPhone, nPos + len(cSchwa))
  447.       else
  448.          exit
  449.       endif
  450.    enddo
  451.  
  452. return cPhone
  453.