basis/tools/completion/completion.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel arrays sequences math namespaces strings io
   4 fry vectors words assocs combinators sorting unicode.case
   5 unicode.categories math.order vocabs vocabs.hierarchy unicode.data
   6 locals ;
   7 IN: tools.completion
   8
   9 :: (fuzzy) ( accum i full ch -- accum i full ? )
  10     ch i full index-from [
  11         :> i i accum push
  12         accum i 1+ full t
  13     ] [
  14         f -1 full f
  15     ] if* ;
  16
  17 : fuzzy ( full short -- indices )
  18     dup [ length <vector> 0 ] curry 2dip
  19     [ (fuzzy) ] all? 3drop ;
  20
  21 : (runs) ( runs n seq -- runs n )
  22     [
  23         [
  24             2dup number=
  25             [ drop ] [ nip V{ } clone pick push ] if
  26             1+
  27         ] keep pick peek push
  28     ] each ;
  29
  30 : runs ( seq -- newseq )
  31     V{ V{ } } [ clone ] map over first rot (runs) drop ;
  32
  33 : score-1 ( i full -- n )
  34     {
  35         { [ over zero? ] [ 2drop 10 ] }
  36         { [ 2dup length 1- number= ] [ 2drop 4 ] }
  37         { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
  38         { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
  39         [ 2drop 1 ]
  40     } cond ;
  41
  42 : score ( full fuzzy -- n )
  43     dup [
  44         [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
  45         runs [
  46             [ 0 [ pick score-1 max ] reduce nip ] keep
  47             length * +
  48         ] with each
  49     ] [
  50         2drop 0
  51     ] if ;
  52
  53 : rank-completions ( results -- newresults )
  54     sort-keys <reversed>
  55     [ 0 [ first max ] reduce 3 /f ] keep
  56     [ first < ] with filter
  57     [ second ] map ;
  58
  59 : complete ( full short -- score )
  60     [ dupd fuzzy score ] 2keep
  61     [ <reversed> ] bi@
  62     dupd fuzzy score max ;
  63
  64 : completion ( short candidate -- result )
  65     [ second >lower swap complete ] keep 2array ;
  66
  67 : completions ( short candidates -- seq )
  68     [ ] [ [ >lower ] dip [ completion ] with map rank-completions ]
  69     bi-curry if-empty ;
  70
  71 : name-completions ( str seq -- seq' )
  72     [ dup name>> ] { } map>assoc completions ;
  73
  74 : words-matching ( str -- seq )
  75     all-words name-completions ;
  76
  77 : vocabs-matching ( str -- seq )
  78     all-vocabs-seq name-completions ;
  79
  80 : chars-matching ( str -- seq )
  81     name-map keys dup zip completions ;