150 lines
4.0 KiB
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 ;
|