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
   4 strings io fry vectors words assocs combinators sorting
   5 unicode.case unicode.categories math.order vocabs
   6 tools.vocabs unicode.data ;
   7 IN: tools.completion
   8
   9 : (fuzzy) ( accum ch i full -- accum i ? )
  10     index-from
  11     [
  12         [ swap push ] 2keep 1+ t
  13     ] [
  14         drop f -1 f
  15     ] if* ;
  16
  17 : fuzzy ( full short -- indices )
  18     dup length <vector> -rot 0 -rot
  19     [ -rot [ (fuzzy) ] keep swap ] 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 ;