basis/tools/completion/completion.factor

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