extra/spelling/spelling.factor

   1 USING: arrays ascii assocs combinators combinators.smart fry
   2 http.client io.encodings.ascii io.files io.files.temp kernel
   3 locals math math.statistics memoize sequences sorting splitting
   4 strings urls ;
   5 IN: spelling
   6
   7 ! http://norvig.com/spell-correct.html
   8
   9 CONSTANT: ALPHABET "abcdefghijklmnopqrstuvwxyz"
  10
  11 : splits ( word -- sequence )
  12     dup length iota [ cut 2array ] with map ;
  13
  14 : deletes ( sequence -- sequence' )
  15     [ second length 0 > ] filter [ first2 rest append ] map ;
  16
  17 : transposes ( sequence -- sequence' )
  18     [ second length 1 > ] filter [
  19         [
  20             {
  21                 [ first ]
  22                 [ second second 1string ]
  23                 [ second first 1string ]
  24                 [ second 2 tail ]
  25             } cleave
  26         ] "" append-outputs-as
  27     ] map ;
  28
  29 : replaces ( sequence -- sequence' )
  30     [ second length 0 > ] filter [
  31         [ ALPHABET ] dip first2
  32         '[ 1string _ _ rest surround ] { } map-as
  33     ] map concat ;
  34
  35 : inserts ( sequence -- sequence' )
  36     [
  37         ALPHABET
  38         [ [ first2 ] dip 1string glue ] with { } map-as
  39     ] map concat ;
  40
  41 : edits1 ( word -- edits )
  42     [
  43         splits {
  44             [ deletes ]
  45             [ transposes ]
  46             [ replaces ]
  47             [ inserts ]
  48         } cleave
  49     ] append-outputs ;
  50
  51 : edits2 ( word -- edits )
  52     edits1 [ edits1 ] map concat ;
  53
  54 : filter-known ( words dictionary -- words' )
  55     '[ _ key? ] filter ;
  56
  57 :: corrections ( word dictionary -- words )
  58     word 1array dictionary filter-known
  59     [ word edits1 dictionary filter-known ] when-empty
  60     [ word edits2 dictionary filter-known ] when-empty
  61     [ dictionary at 1 or ] sort-with ;
  62
  63 : words ( string -- words )
  64     >lower [ letter? not ] split-when harvest ;
  65
  66 : load-dictionary ( file -- assoc )
  67     ascii file-contents words histogram ;
  68
  69 MEMO: default-dictionary ( -- counts )
  70     "big.txt" temp-file dup exists?
  71     [ URL" http://norvig.com/big.txt" over download-to ] unless
  72     load-dictionary ;
  73
  74 : (correct) ( word dictionary -- word/f )
  75     corrections [ f ] [ first ] if-empty ;
  76
  77 : correct ( word -- word/f )
  78     default-dictionary (correct) ;