Browser cleanups, moving assoc word from lists to sequences
parent
fdfcc34621
commit
38602d63b9
|
@ -166,12 +166,12 @@ vectors words ;
|
|||
"/library/ui/gadgets.factor"
|
||||
"/library/ui/layouts.factor"
|
||||
"/library/ui/hierarchy.factor"
|
||||
"/library/ui/frames.factor"
|
||||
"/library/ui/world.factor"
|
||||
"/library/ui/paint.factor"
|
||||
"/library/ui/theme.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/gestures.factor"
|
||||
"/library/ui/frames.factor"
|
||||
"/library/ui/borders.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
"/library/ui/line-editor.factor"
|
||||
|
@ -183,6 +183,7 @@ vectors words ;
|
|||
"/library/ui/paragraphs.factor"
|
||||
"/library/ui/panes.factor"
|
||||
"/library/ui/outliner.factor"
|
||||
"/library/ui/environment.factor"
|
||||
"/library/ui/listener.factor"
|
||||
"/library/ui/browser.factor"
|
||||
"/library/ui/launchpad.factor"
|
||||
|
|
|
@ -79,8 +79,6 @@ M: cons = ( obj cons -- ? )
|
|||
|
||||
: curry ( obj quot -- quot ) >r literalize r> cons ;
|
||||
|
||||
: assoc ( key alist -- value ) [ car = ] find-with nip cdr ;
|
||||
|
||||
: (>list) ( n i seq -- list )
|
||||
pick pick <= [
|
||||
3drop [ ]
|
||||
|
|
|
@ -106,6 +106,9 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
|
|||
pick over bounds-check 2drop 2dup bounds-check 2drop
|
||||
exchange-unsafe ;
|
||||
|
||||
: assoc ( key assoc -- value )
|
||||
[ first = ] find-with nip second ;
|
||||
|
||||
IN: kernel
|
||||
|
||||
M: object <=>
|
||||
|
|
|
@ -37,7 +37,7 @@ TUPLE: rstate label base-case? ;
|
|||
r> current-node set ;
|
||||
|
||||
: with-recursive-state ( word label base-case quot -- )
|
||||
>r <rstate> cons recursive-state [ cons ] change r>
|
||||
>r <rstate> 2array recursive-state [ cons ] change r>
|
||||
nest-node 2slip unnest-node ; inline
|
||||
|
||||
: inline-block ( word base-case -- node-block variables )
|
||||
|
|
|
@ -1,24 +1,21 @@
|
|||
IN: components
|
||||
USING: help inspector kernel namespaces sequences words ;
|
||||
|
||||
! Component document framework, like OpenDoc.
|
||||
|
||||
TUPLE: component name predicate builder ;
|
||||
USING: hashtables help inspector kernel namespaces sequences
|
||||
words ;
|
||||
|
||||
SYMBOL: components
|
||||
|
||||
V{ } clone components set-global
|
||||
H{ } clone components set-global
|
||||
|
||||
: get-components ( obj -- seq )
|
||||
components get-global
|
||||
[ component-predicate call ] subset-with ;
|
||||
: get-components ( class -- assoc )
|
||||
components get-global hash [ { } ] unless*
|
||||
{ "Slots" [ describe ] } append ;
|
||||
|
||||
: define-component ( name predicate builder -- )
|
||||
<component> components get-global push ;
|
||||
{
|
||||
{ "Definition" [ help ] }
|
||||
{ "Calls in" [ usage. ] }
|
||||
{ "Calls out" [ uses. ] }
|
||||
} word components get-global set-hash
|
||||
|
||||
"Slots" [ drop t ] [ describe ] define-component
|
||||
"Documentation" [ word? ] [ help ] define-component
|
||||
"Calls in" [ word? ] [ usage. ] define-component
|
||||
"Calls out" [ word? ] [ uses. ] define-component
|
||||
"Definition" [ term? ] [ help ] define-component
|
||||
"Documentation" [ link? ] [ help ] define-component
|
||||
{
|
||||
{ "Documentation" [ help ] }
|
||||
} link components get-global set-hash
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-browser
|
||||
USING: components gadgets gadgets-buttons gadgets-labels
|
||||
USING: arrays components gadgets gadgets-buttons gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
|
||||
hashtables help inspector kernel lists math namespaces
|
||||
prettyprint sequences words ;
|
||||
|
@ -10,39 +10,32 @@ TUPLE: book page pages ;
|
|||
|
||||
: show-page ( key book -- )
|
||||
dup book-page unparent
|
||||
[ book-pages hash ] keep
|
||||
[ book-pages assoc ] keep
|
||||
[ set-book-page ] 2keep
|
||||
add-gadget ;
|
||||
|
||||
C: book ( page pages -- book )
|
||||
C: book ( pages -- book )
|
||||
dup delegate>gadget
|
||||
[ set-book-pages ] keep
|
||||
[ set-book-pages ] 2keep
|
||||
[ >r first r> show-page ] keep
|
||||
[ show-page ] keep ;
|
||||
|
||||
M: book pref-dim* ( book -- dim )
|
||||
{ 0 0 0 } swap book-pages [ nip pref-dim vmax ] hash-each ;
|
||||
book-pages { 0 0 0 } [ second pref-dim vmax ] reduce ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rect-dim swap book-page set-gadget-dim ;
|
||||
|
||||
: component-page ( obj component -- gadget )
|
||||
component-builder make-pane <scroller> ;
|
||||
|
||||
: component-pages ( obj -- hash )
|
||||
dup get-components [
|
||||
[ component-name over ] keep component-page
|
||||
] map>hash nip ;
|
||||
|
||||
: component-book ( hash -- book )
|
||||
dup hash-keys natural-sort first swap <book> ;
|
||||
: component-pages ( obj -- assoc )
|
||||
dup get-components
|
||||
[ first2 swapd make-pane <scroller> 2array ] map-with ;
|
||||
|
||||
: <tab> ( name book -- button )
|
||||
dupd [ show-page ] curry curry
|
||||
>r <label> r> <bevel-button> ;
|
||||
|
||||
: tabs ( hash book gadget -- )
|
||||
>r swap hash-keys natural-sort
|
||||
[ swap <tab> ] map-with r> add-gadgets ;
|
||||
: tabs ( assoc book gadget -- )
|
||||
>r swap [ first swap <tab> ] map-with r> add-gadgets ;
|
||||
|
||||
TUPLE: browser object history tabs ;
|
||||
|
||||
|
@ -52,7 +45,7 @@ TUPLE: browser object history tabs ;
|
|||
: browse ( obj browser -- )
|
||||
[ set-browser-object ] 2keep
|
||||
dup browser-tabs clear-gadget
|
||||
>r component-pages dup component-book r>
|
||||
>r component-pages dup <book> r>
|
||||
[ @center frame-add ] 2keep browser-tabs tabs ;
|
||||
|
||||
: find-browser [ browser? ] find-parent ;
|
||||
|
|
Loading…
Reference in New Issue