home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / fuzz.icn < prev    next >
Text File  |  2000-07-29  |  6KB  |  180 lines
  1. ############################################################################
  2. #
  3. #   File:     fuzz.icn
  4. #
  5. #   Subject:  Program to perform fuzzy pattern matching
  6. #
  7. #   Author:   Alex Cecil
  8. #
  9. #   Date:     November 10, 1993
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #      This program illustrates "fuzzy" string pattern matching.  The result
  18. #   of matching s and t is a number between 0 and 1 which is based on 
  19. #   counting matching pairs of characters in increasingly long substrings
  20. #   of s and t.  Characters may be weighted differently, and the reverse
  21. #   tally may be given a negative bias.
  22. #
  23. ############################################################################
  24.  
  25.  
  26. global bias, rank_list_max, weight1, weight2, weight_set, which_fuzz_value
  27.  
  28. procedure main()
  29.    local alphanum, in_id, in_name, in_record, rank_list,
  30.          start_time, word_requested
  31.  
  32.    bias          := -2                  # Reduce importance of reverse match
  33.    rank_list_max := 15                  # Number of best matches to write
  34.    weight1       := 6                   # Weight of chars not in weight_set
  35.    weight2       := 2                   # Weight of chars in weight_set
  36.    weight_set    := 'aehiouwy'          # Soundex ignore list
  37.  
  38.    write("The ",rank_list_max,
  39.       " best matches for the first word in each line will be written.")
  40.    writes("\nName of input file: "); in_name := read()
  41.    in_id := (open(in_name,"r")) | (stop("Can't open file ",in_name))
  42.  
  43.    writes("\nWord to search for: ")
  44.    word_requested := map(read())
  45.  
  46.    writes("\nWhich function: Simple, Optimized, Weighted (1,2,3): ")
  47.    which_fuzz_value := case read() of {
  48.       "1"     : fuzz_value_1            # Simple, "obvious" implementation
  49.       "2"     : fuzz_value_2            # Simple, linearized for speed
  50.       default : fuzz_value_3            # Weights and bias included
  51.    }
  52.  
  53.    write("\nSearching for \"",word_requested,"\" in file ",in_name)
  54.    start_time := &time
  55.    alphanum := &letters ++ &digits
  56.    rank_list := []                      # [[fuzz-value,in-record],...]
  57.    while in_record := read(in_id) do {
  58.       in_record ? {
  59.          tab(upto(alphanum))
  60.          rank(word_requested,map(tab(many(alphanum))),in_record,
  61.             rank_list,rank_list_max)
  62.       }
  63.    }
  64.    write("\nFuzz Value of first word\n  |   Input Record...")
  65.    every rank := !rank_list do {
  66.       write(left(string(rank[1]),5)," ",left(rank[2],72))
  67.    }
  68.    write("\nElapsed time in milliseconds: ",&time - start_time)
  69. end
  70.  
  71. procedure rank(s,t,r,rl,rm)
  72. # Maintain a sorted list (rl) of the rm best Fuzz values with records (r).
  73. # Special cases to save time: strings are the same; or s and t have fewer
  74. # than about 50% characters in common.
  75.    local i, v
  76.    if s == t then v := 1.0
  77.    else if *(s ** t) * 4 <= (*s + *t) then v := 0.0
  78.    else v := which_fuzz_value(s,t,weight1,weight2,weight_set,bias)
  79.                                         # 3rd-last args needed by fuzz_value_3
  80.    if *rl = 0 then put(rl,[v,r])        # First entry in list
  81.    else if v >= rl[*rl][1] then {       # If value greater than least in list...
  82.       put(rl,[v,r])                     #    add to list, sort, and trim
  83.       every i := *rl to 2 by -1 do {
  84.          if rl[i][1] > rl[i-1][1] then rl[i] :=: rl[i-1]
  85.       }
  86.       if *rl > rm then pull(rl)
  87.    }
  88. end
  89.  
  90. procedure fuzz_value_1(s,t)
  91. # Calculate Fuzz Value of s and t with weight=1 and bias=0
  92. # Simple, non-optomized algorithm.
  93.    if *s > *t then s :=: t
  94.    return 2.0 * (fuzz_match_1(s,t) + fuzz_match_1(reverse(s),reverse(t)))/
  95.       ((*s * (*s+1)) + (*t * (*t+1)))
  96. end
  97.  
  98. procedure fuzz_match_1(s,ti)
  99. # Calculate the Fuzz Matches between s and t.  Simple algorithm.
  100. # ASCII NUL is used to mark matched pairs, so can't be used in strings
  101.    local i, imax, jmax, m, t, tsdif
  102.    tsdif := *ti - *s
  103.    m := 0
  104.    every imax := 1 to *s do {
  105.       t := ti
  106.       jmax := imax + tsdif + 1
  107.       every i := 1 to imax do 
  108.          if t[find(s[i],t,1,jmax)] := "\0" then m +:= 1
  109.    }
  110.    return m
  111. end
  112.  
  113. procedure fuzz_value_2(s,t)
  114. # Calculate Fuzz Value with weight=1 and bias=0
  115. # Optomized version.
  116.    if *s > *t then s :=: t
  117.    return 2.0 * (fuzz_match_2(s,t) + fuzz_match_2(reverse(s),reverse(t)))/
  118.        ((*s * (*s+1)) + (*t * (*t+1)))
  119. end
  120.  
  121. procedure fuzz_match_2(s,t)
  122. # Calculate the Fuzz Matches between s and t.
  123. # Replace column loop by imperical calculation.
  124. # ASCII NUL is used to mark matched pairs, so can't be used in s or t. 
  125. # s(ip) is ith char from right, similarly for t(jp)
  126.    local ip, j, jmp, jp, m, si
  127.    ip := *s
  128.    jmp := *t + 1
  129.    m := 0
  130.    every si := !s do {
  131.       if t[j := find(si,t)] := "\0" then {
  132.          jp := jmp - j
  133.          m +:= (ip <= jp | ip) - abs(ip - jp)  # max column minus column offset
  134.       }
  135.       ip -:= 1
  136.    }
  137.    return m
  138. end
  139.  
  140. procedure fuzz_value_3(s,t,w1,w2,w2c,b,c)
  141. # Calculate Fuzz Value with weight w2 if in cset w2c, else weight w1; bias b.
  142.    if *s > *t then s :=: t
  143.    return 2.0 * (fuzz_match_3(s,t,w1,w2,w2c) +
  144.                  fuzz_match_3(reverse(s),reverse(t),w1+b,w2+b,w2c)) /
  145.         (fuzz_self_3(s,w1+w1+b,w2+w2+b,w2c) + fuzz_self_3(t,w1+w1+b,w2+w2+b,w2c))
  146. end
  147.  
  148. procedure fuzz_match_3(s,t,w1,w2,w2c)
  149. # Calculate the Fuzz Matches between s and t. 
  150. # Replace column loop by imperical calculation.
  151. # ASCII NUL is used to mark matched pairs, so can't be used in s or t. 
  152. # s(ip) is ith char from right, similarly for t(jp)
  153.    local ip, j, jmp, jp, m, mo, si
  154.    ip := *s
  155.    jmp := *t + 1
  156.    m := 0
  157.    every si := !s do {
  158.       if t[j := find(si,t)] := "\0" then {
  159.          jp := jmp - j
  160.          mo := (ip <= jp | ip) - abs(ip - jp)  # max column minus column offset
  161.          m +:= (any(w2c,si) & (w2 * mo)) | (w1 * mo)
  162.       }
  163.       ip -:= 1
  164.    }
  165.    return m
  166. end
  167.  
  168. procedure fuzz_self_3(s,w1fr,w2fr,w2c)
  169. # fuzz matches of s with s
  170. # w1fr, w2fr: forward plus reverse weights.
  171.    local ip, m, si
  172.    ip := *s
  173.    m := 0
  174.    every si := !s do {
  175.       m +:= (any(w2c,si) & (w2fr * ip)) | (w1fr * ip) 
  176.       ip -:= 1
  177.    }
  178.    return m
  179. end
  180.