Remove some code duplication between apropos and help search

TODO.FACTOR.txt

@@ -12,6 +12,11 @@
 - minibuffer should show a title
 - clean up listener's minibuffer-related code
 - help search looks funny
+- vocab completer
+- vocab operations:
+  - browse
+  - insert IN:   -- or just 'become in'
+  - insert USE:  -- 'use'
 
 + ui:
 

library/help/search.factor

@@ -36,12 +36,6 @@ SYMBOL: term-index
         drop
     ] if* ;
 
-: discard-irrelevant ( results -- newresults )
-    #! Discard results in the low 33%
-    dup 0 [ second max ] reduce
-    swap [ first2 rot / 2array ] map-with
-    [ second 1/3 > ] subset ;
-
 : count-occurrences ( seq -- hash )
     [
         dup [ [ drop off ] hash-each ] each
@@ -50,9 +44,7 @@ SYMBOL: term-index
 
 : search-help ( phrase -- assoc )
     tokenize [ term-index get hash ] map [ ] subset
-    count-occurrences hash>alist
-    [ first2 2array ] map
-    [ [ second ] 2apply swap - ] sort discard-irrelevant ;
+    count-occurrences hash>alist rank-completions ;
 
 : index-help ( -- )
     term-index get [
@@ -83,9 +75,6 @@ SYMBOL: term-index
     over >r "help" set-word-prop r>
     dup xref-article index-article ;
 
-: search-help. ( phrase -- )
-    search-help [ first ] map help-outliner ;
-
 ! Definition protocol
 M: link forget link-name remove-article ;
 

library/help/search.facts

@@ -36,7 +36,7 @@ HELP: search-help
 { $description "Performs a full-text search in the term index for help topics relating to " { $snippet "phrase" } ". The result is an association list of topic names paired with scores, sorted by decreasing score." } ;
 
 HELP: index-help
-{ $description "Updates the full-text search term index for use by " { $link search-help } " and " { $link search-help. } "." } ;
+{ $description "Updates the full-text search term index for use by " { $link search-help } "." } ;
 
 HELP: search-help.
 { $values { "phrase" "a string" } }

library/load.factor

@@ -94,7 +94,7 @@ PROVIDE: library {
     "tools/memory.factor"
     "tools/listener.factor"
     "tools/inspector.factor"
-    "tools/fuzzy.factor"
+    "tools/completion.factor"
     "tools/word-tools.factor"
     "tools/test.factor"
 
@@ -206,6 +206,7 @@ PROVIDE: library {
     "test/generic.factor"
     "test/help/porter-stemmer.factor"
     "test/help/topics.factor"
+    "test/help/search.factor"
     "test/inference.factor"
     "test/init.factor"
     "test/inspector.factor"

library/test/help/search.factor

@@ -0,0 +1,6 @@
+IN: temporary
+USING: help sequences math test ;
+
+[ t ]
+[ "variables" search-help [ second number? ] all? ]
+unit-test

library/test/tools.factor

@@ -2,3 +2,4 @@ IN: temporary
 USING: tools ;
 
 [ ] [ "" apropos ] unit-test
+[ ] [ "swp" apropos ] unit-test

library/tools/completion.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: tools
+IN: completion
 USING: kernel arrays sequences math namespaces strings io ;
 
 ! Simple fuzzy search.
@@ -48,14 +48,15 @@ USING: kernel arrays sequences math namespaces strings io ;
         2drop 0
     ] if ;
 
-: rank-completions ( seq -- seq )
-    [ first zero? not ] subset
-    [ [ first ] 2apply swap - ] sort
-    dup length 20 min head ;
+: rank-completions ( results -- newresults )
+    #! Discard results in the low 33%
+    [ [ second ] 2apply swap - ] sort
+    [ 0 [ second max ] reduce ] keep
+    [ second swap > ] subset-with ;
 
 : completion ( str quot obj -- pair )
-    #! pair is { score obj }
-    [ swap call dup rot fuzzy score ] keep 2array ; inline
+    #! pair is { obj score }
+    [ swap call dup rot fuzzy score ] keep swap 2array ; inline
 
 : completions ( str candidates quot -- seq )
     pick empty? [
@@ -64,9 +65,8 @@ USING: kernel arrays sequences math namespaces strings io ;
         [ >r 2dup r> completion ] map 2nip rank-completions
     ] if ; inline
 
-: completion. ( score str obj -- )
-    >r [ % " (score: " % >fixnum # ")" % ] "" make r>
-    write-object terpri ; inline
+: completion>string ( score str -- )
+    [ % " (score: " % >fixnum # ")" % ] "" make ;
 
 : string-completions ( str strs -- seq )
     f swap completions ;

library/tools/word-tools.factor

@@ -3,7 +3,7 @@
 IN: tools
 USING: arrays definitions hashtables help tools io kernel
 math namespaces prettyprint sequences strings styles words
-generic ;
+generic completion ;
 
 : word-outliner ( seq -- )
     natural-sort [
@@ -48,10 +48,11 @@ generic ;
     ] annotate ;
 
 : word-completion. ( pair -- )
-    first2 [ summary ] keep completion. ;
+    first2 over summary completion>string swap write-object ;
 
 : word-completions ( str words -- seq )
     [ word-name ] swap completions ;
 
 : apropos ( str -- )
-    all-words word-completions [ word-completion. ] each ;
+    all-words word-completions
+    [ word-completion. terpri ] each ;

library/ui/load.factor

@@ -54,5 +54,6 @@ PROVIDE: library/ui {
     "test/commands.factor"
     "test/panes.factor"
     "test/editor.factor"
+    "test/search.factor"
     "test/tracks.factor"
 } ;

library/ui/test/search.factor

@@ -0,0 +1,6 @@
+IN: temporary
+USING: gadgets-search io test ;
+
+[ "hey man (score: 123)" ]
+[ [ { "hey man" 123 } file-completion. ] string-out ]
+unit-test

library/ui/tools/search.factor

@@ -4,7 +4,8 @@ IN: gadgets-search
 USING: arrays gadgets gadgets-frames gadgets-labels
 gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
 generic help tools kernel models sequences words
-gadgets-borders gadgets-lists namespaces parser hashtables io ;
+gadgets-borders gadgets-lists namespaces parser hashtables io
+completion ;
 
 TUPLE: live-search field list model producer action presenter ;
 
@@ -59,7 +60,7 @@ C: live-search ( string action producer presenter -- gadget )
 M: live-search focusable-child* live-search-field ;
 
 : <word-search> ( string action -- gadget )
-    \ second add*
+    \ first add*
     all-words
     [ word-completions ] curry
     [ [ word-completion. ] make-pane ]
@@ -72,10 +73,10 @@ M: live-search focusable-child* live-search-field ;
     <live-search> ;
 
 : file-completion. ( pair -- )
-    first2 dup <pathname> completion. ;
+    first2 over completion>string swap <pathname> write-object ;
 
 : <source-files-search> ( string action -- gadget )
-    \ second add*
+    \ first add*
     source-files get hash-keys natural-sort
     [ string-completions ] curry
     [ [ file-completion. ] make-pane ]