factor/library/ui/tools/browser.factor

150 lines
4.0 KiB
Factor

! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-browser
USING: gadgets gadgets-buttons gadgets-labels gadgets-panes
gadgets-presentations gadgets-scrolling gadgets-search
gadgets-tabs gadgets-theme gadgets-tiles gadgets-tracks generic
hashtables help inspector kernel math prettyprint sequences
words ;
TUPLE: browser-track showing builder closer ;
C: browser-track ( builder closer -- gadget )
{ 0 1 0 } <track> over set-delegate
H{ } clone over set-browser-track-showing
[ set-browser-track-closer ] keep
[ set-browser-track-builder ] keep ;
: showing-asset? ( asset track -- ? )
browser-track-showing hash-member? ;
: (show-asset) ( gadget asset track -- )
[ browser-track-showing set-hash ] 3keep nip track-add ;
: show-asset ( asset track -- )
2dup showing-asset? [
2drop
] [
[ browser-track-builder call ] 2keep (show-asset)
] if ;
: hide-asset ( asset track -- )
[ dup browser-track-closer call ] 2keep
[ browser-track-showing remove-hash* ] keep track-remove ;
TUPLE: browser main-track vocab-track word-track ;
: find-browser [ browser? ] find-parent ;
: close-tile ( tile -- )
dup gadget-parent [
browser-track-showing hash>alist rassoc
] keep hide-asset ;
: <browser-tile> ( gadget title -- gadget )
[ close-tile ] <tile> ;
: showing-word? ( word browser -- ? )
browser-word-track showing-asset? ;
DEFER: show-vocab
: <word-pages> ( word -- tabs )
{
{ "Definition" [ see ] }
{ "Documentation" [ help ] }
{ "Calls in" [ usage. ] }
{ "Links in" [ links-in. ] }
{ "Properties" [ word-props describe ] }
} <pages> ;
: <word-view> ( word -- gadget )
[ <word-pages> ] keep article-title <browser-tile> ;
: show-word ( word browser -- )
over word-vocabulary over show-vocab
browser-word-track show-asset ;
: hide-word ( word browser -- )
browser-word-track hide-asset ;
: toggle-word ( word browser -- )
2dup showing-word? [ hide-word ] [ show-word ] if ;
: <word-button> ( word -- gadget )
dup word-name <label> swap
[ swap find-browser toggle-word ] curry
<roll-button> ;
: <vocab-view> ( vocab -- gadget )
[
words natural-sort
[ <word-button> ] map make-pile <scroller>
] keep <browser-tile> ;
: showing-vocab? ( vocab browser -- ? )
browser-vocab-track showing-asset? ;
: show-vocab ( vocab browser -- )
over [ browser-vocab-track show-asset ] [ 2drop ] if ;
: hide-vocab-words ( vocab browser -- )
[
browser-word-track browser-track-showing hash-keys
[ word-vocabulary = ] subset-with
] keep swap [ swap hide-word ] each-with ;
: hide-vocab ( vocab browser -- )
browser-vocab-track hide-asset ;
: toggle-vocab ( word browser -- )
2dup showing-vocab? [ hide-vocab ] [ show-vocab ] if ;
: <vocab-button> ( vocab -- gadget )
dup <label> swap
[ swap find-browser toggle-vocab ] curry
<roll-button> ;
: <vocabs> ( -- gadget )
vocabs [ <vocab-button> ] map make-pile <scroller>
"Vocabularies" f <tile> ;
: <apropos-gadget>
[ apropos ] <search-gadget> "Apropos" f <tile> ;
TUPLE: main-track vocabs apropos ;
C: main-track ( -- gadget )
{
{ [ <vocabs> ] set-main-track-vocabs 2/3 }
{ [ <apropos-gadget> ] set-main-track-apropos 1/3 }
} { 0 1 0 } make-track* ;
: <vocab-track> ( -- track )
[ <vocab-view> ] [ find-browser hide-vocab-words ]
<browser-track> ;
: <word-track> ( -- track )
[ <word-view> ] [ 2drop ] <browser-track> ;
C: browser ( -- browser )
{
{ [ <main-track> ] set-browser-main-track 1/5 }
{ [ <vocab-track> ] set-browser-vocab-track 1/5 }
{ [ <word-track> ] set-browser-word-track 3/5 }
} { 1 0 0 } make-track* ;
M: browser gadget-title drop "Browser" ;
M: browser focusable-child*
browser-main-track main-track-apropos ;
: browser-window ( -- ) <browser> open-window ;
: browser-tool
[ browser? ]
[ <browser> ]
[ show-word ] ;
M: word show ( word -- ) browser-tool call-tool ;