73 lines
1.8 KiB
Factor
73 lines
1.8 KiB
Factor
! Copyright (C) 2005, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: completion
|
|
USING: kernel arrays sequences math namespaces strings io ;
|
|
|
|
! Simple fuzzy search.
|
|
|
|
: fuzzy ( full short -- indices )
|
|
0 swap >array [ swap pick index* [ 1+ ] keep ] map 2nip
|
|
-1 over member? [ drop f ] when ;
|
|
|
|
: (runs) ( n i seq -- )
|
|
2dup length < [
|
|
3dup nth [
|
|
number= [
|
|
>r >r 1+ r> r>
|
|
] [
|
|
split-next,
|
|
rot drop [ nth 1+ ] 2keep
|
|
] if >r 1+ r>
|
|
] keep split, (runs)
|
|
] [
|
|
3drop
|
|
] if ;
|
|
|
|
: runs ( seq -- seq )
|
|
[
|
|
split-next,
|
|
dup first 0 rot (runs)
|
|
] { } make ;
|
|
|
|
: score-1 ( i full -- n )
|
|
{
|
|
{ [ over zero? ] [ 2drop 10 ] }
|
|
{ [ 2dup length 1- = ] [ 2drop 4 ] }
|
|
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
|
|
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
|
|
{ [ t ] [ 2drop 1 ] }
|
|
} cond ;
|
|
|
|
: score ( full fuzzy -- n )
|
|
dup [
|
|
[ [ length ] 2apply - 15 swap [-] 3 / ] 2keep
|
|
runs [
|
|
[ swap score-1 ] map-with dup supremum swap length *
|
|
] map-with sum +
|
|
] [
|
|
2drop 0
|
|
] if ;
|
|
|
|
: rank-completions ( results -- newresults )
|
|
#! Discard results in the low 33%
|
|
[ [ second ] 2apply swap - ] sort
|
|
[ 0 [ second max ] reduce 3 / ] keep
|
|
[ second < ] subset-with ;
|
|
|
|
: completion ( str quot obj -- pair )
|
|
#! pair is { obj score }
|
|
[ swap call dup rot fuzzy score ] keep swap 2array ; inline
|
|
|
|
: completions ( str candidates quot -- seq )
|
|
pick empty? [
|
|
3drop f
|
|
] [
|
|
[ >r 2dup r> completion ] map 2nip rank-completions
|
|
] if ; inline
|
|
|
|
: completion>string ( score str -- newstr )
|
|
[ % " (score: " % >fixnum # ")" % ] "" make ;
|
|
|
|
: string-completions ( str strs -- seq )
|
|
f swap completions ;
|