New apropos from hell

library/compiler/inference/branches.factor

@@ -21,8 +21,6 @@ namespaces parser prettyprint sequences strings vectors words ;
     [ dup [ length - ] [ 2drop f ] if ] 2map
     [ ] subset all-equal? ;
 
-: supremum ( seq -- n ) -1./0. [ max ] reduce ;
-
 : unbalanced-branches ( in out -- )
     [ swap unparse " " rot length unparse append3 ] 2map
     "Unbalanced branches:" add* "\n" join inference-error ;

library/io/plain-stream.factor

@@ -11,8 +11,7 @@ C: plain-writer ( stream -- stream ) [ set-delegate ] keep ;
 M: plain-writer stream-terpri CHAR: \n swap stream-write1 ;
 
 M: plain-writer stream-format ( string style stream -- )
-    highlight rot hash [ >r ">> " swap " <<" append3 r> ] when
-    stream-write ;
+    highlight rot hash [ >r >upper r> ] when stream-write ;
 
 M: plain-writer with-nested-stream ( quot style stream -- )
     nip swap with-stream* ;

library/syntax/prettyprint.factor

@@ -250,12 +250,15 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 : pprint-element ( object -- )
     dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
 
+: hilite-style ( -- hash )
+    H{
+        { background { 0.9 0.9 0.9 1 } }
+        { highlight t }
+    } ;
+
 : pprint-hilite ( object n -- )
     hilite-index get = [
-        H{
-            { background { 0.9 0.9 0.9 1 } }
-            { highlight t }
-        } <block pprint-element block>
+        hilite-style <block pprint-element block>
     ] [
         pprint-element
     ] if ;

library/tools/word-tools.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: words
-USING: definitions help inspector io kernel math namespaces
-prettyprint sequences strings ;
+USING: arrays definitions hashtables help inspector io kernel
+math namespaces prettyprint sequences strings styles ;
 
 : word-outliner ( word quot -- )
     swap natural-sort [
@@ -13,9 +13,6 @@ prettyprint sequences strings ;
 : usage. ( word -- )
     usage [ usage. ] word-outliner ;
 
-: apropos ( substring -- )
-    all-words completions [ (help) ] word-outliner ;
-
 : annotate ( word quot -- | quot: word def -- def )
     over >r >r dup word-def r> call r> swap define-compound ;
     inline
@@ -33,4 +30,75 @@ prettyprint sequences strings ;
 : watch ( word -- ) [ (watch) ] annotate ;
 
 : profile ( word -- )
-    [ swap [ global [ inc ] bind ] curry swap append ] annotate ;
+    [
+        swap [ global [ inc ] bind ] curry swap append
+    ] annotate ;
+
+: 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 ;
+
+: prev >r 1- r> nth ;
+: next >r 1+ r> nth ;
+
+: score-1 ( i full -- n )
+    {
+        { [ over zero? ] [ 2drop 10 ] }
+        { [ 2dup length 1- = ] [ 2drop 4 ] }
+        { [ 2dup prev Letter? not ] [ 2drop 10 ] }
+        { [ 2dup next 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 ;
+
+: completion ( str word -- { score indices word } )
+    [
+        word-name [ swap fuzzy ] keep swap [ score ] keep
+    ] keep
+    3array ;
+
+: completions ( str -- seq )
+    all-words [ completion ] map-with [ first zero? not ] subset
+    [ [ first ] 2apply - ] sort dup length 20 min tail* ;
+
+: fuzzy. ( fuzzy full -- )
+    dup length [
+        pick member?
+        [ hilite-style >r ch>string r> format ] [ write1 ] if 
+    ] 2each drop ;
+
+: apropos ( str -- )
+    completions [
+        first3 dup presented associate [
+            word-name fuzzy. drop
+        ] with-nesting terpri
+    ] each ;