1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs colors combinators
4 combinators.short-circuit io.directories io.files io.files.info
5 io.pathnames kernel make math math.order sequences
6 sequences.private sorting splitting splitting.monotonic unicode
7 unicode.data vocabs vocabs.hierarchy ;
12 : fuzzy-index-from ( ch i seq -- n/f )
13 rot [ ch>lower ] [ ch>upper ] bi
14 '[ dup _ eq? [ drop t ] [ _ eq? ] if ] find-from drop ;
16 :: (fuzzy) ( accum i ch full -- accum i ? )
17 ch i full fuzzy-index-from [
19 [ accum swap 1 + t ] bi
26 : fuzzy ( full short -- indices )
27 [ V{ } clone 0 ] 2dip swap '[ _ (fuzzy) ] all? 2drop ;
29 : runs ( seq -- newseq )
30 [ 1 - = ] monotonic-split-slice ;
34 : score-1 ( i full -- n )
36 { [ over zero? ] [ 2drop 10 ] }
37 { [ 2dup length 1 - = ] [ 2drop 4 ] }
38 { [ 2dup [ 1 - ] dip nth-unsafe Letter? not ] [ 2drop 10 ] }
39 { [ 2dup [ 1 + ] dip nth-unsafe Letter? not ] [ 2drop 4 ] }
45 : score ( full fuzzy -- n )
47 [ 2length - 15 swap [-] 3 /f ] 2keep
49 [ 0 [ pick score-1 max ] reduce nip ] keep
56 : rank-completions ( results -- newresults )
58 [ [ first ] [ max ] map-reduce 4 /f ] keep
59 [ first < ] with filter
60 ] when sort-keys <reversed> values ;
62 : complete ( full short -- score )
63 [ dupd fuzzy score ] 2keep pick 0 > [
64 [ <reversed> ] bi@ dupd fuzzy score max
67 : completion ( short candidate -- score candidate )
68 [ second swap complete ] keep ; inline
70 : completion, ( short candidate -- )
71 completion over 0 > [ 2array , ] [ 2drop ] if ;
73 : completions ( short candidates -- seq )
75 [ [ completion, ] with each ] { } make
79 : named ( seq -- seq' )
80 [ dup name>> ] { } map>assoc ;
82 : vocabs-matching ( str -- seq )
83 all-disk-vocabs-recursive filter-vocabs named completions ;
85 : vocab-words-matching ( str vocab -- seq )
86 vocab-words named completions ;
88 : qualified-named ( str -- seq/f )
90 vocabs-matching keys [
91 [ vocab-words ] [ vocab-name ] bi ":" append
92 [ over name>> append ] curry { } map>assoc
96 : words-matching ( str -- seq )
97 all-words named over qualified-named [ append ] unless-empty completions ;
99 : chars-matching ( str -- seq )
100 name-map keys dup zip completions ;
102 : colors-matching ( str -- seq )
103 named-colors dup zip completions ;
105 : strings-matching ( str seq -- seq' )
106 dup zip completions keys ;
110 : directory-paths ( directory -- alist )
113 [ name>> dup _ prepend-path ]
114 [ directory? [ path-separator append ] when ]
117 ] with-directory-entries ;
121 : paths-matching ( str -- seq )
123 dup last-path-separator [ 1 + cut ] [ drop "" ] if swap
124 dup { [ file-exists? ] [ file-info directory? ] } 1&&
125 [ directory-paths completions ] [ 2drop { } ] if
126 ] dip [ [ [ "P\"" prepend ] dip ] assoc-map ] when ;
130 : (complete-single-vocab?) ( str -- ? )
132 "IN:" "USE:" "UNUSE:" "QUALIFIED:"
133 "QUALIFIED-WITH:" "FROM:" "EXCLUDE:"
137 : complete-single-vocab? ( tokens -- ? )
139 harvest ?last (complete-single-vocab?)
141 harvest dup length 1 >
142 [ 2 tail* ?first (complete-single-vocab?) ] [ drop f ] if
145 : chop-; ( seq -- seq' )
146 { ";" } split1-last [ ] [ ] ?if ;
148 : complete-vocab-list? ( tokens -- ? )
149 chop-; 1 index-or-length head* "USING:" swap member? ;
153 : complete-vocab? ( tokens -- ? )
154 { [ complete-single-vocab? ] [ complete-vocab-list? ] } 1|| ;
156 : complete-vocab-words? ( tokens -- ? )
159 [ first { "FROM:" "EXCLUDE:" } member? ]
165 : complete-token? ( tokens token -- ? )
167 [ harvest ?last ] [ = ] bi*
169 swap harvest dup length 1 >
170 [ 2 tail* ?first = ] [ 2drop f ] if
175 : complete-char? ( tokens -- ? ) "CHAR:" complete-token? ;
177 : complete-color? ( tokens -- ? ) "COLOR:" complete-token? ;
181 : complete-string? ( tokens token -- ? )
184 [ harvest ?last ] dip ?head
185 [ ?last CHAR: \" = not ] [ drop f ] if
192 : complete-pathname? ( tokens -- ? ) "P\"" complete-string? ;