Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
840eafbcae
|
|
@ -230,5 +230,3 @@ M: radio-control model-changed
|
|||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
|
||||
: toolbar, ( -- ) g <toolbar> f track, ;
|
||||
|
|
|
|||
|
|
@ -24,6 +24,8 @@ grid
|
|||
>r >r 2dup swap add-gadget drop r> r>
|
||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||
|
||||
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
|
||||
|
||||
: grid-remove ( grid i j -- )
|
||||
>r >r >r <gadget> r> r> r> grid-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,30 +29,22 @@ scroller H{
|
|||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: viewport, ( child -- )
|
||||
g model>> <viewport>
|
||||
g-> set-scroller-viewport @center frame, ;
|
||||
|
||||
: <scroller-model> ( -- model )
|
||||
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
||||
|
||||
: x-model ( -- model ) g model>> dependencies>> first ;
|
||||
|
||||
: y-model ( -- model ) g model>> dependencies>> second ;
|
||||
|
||||
: new-scroller ( gadget class -- scroller )
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
[
|
||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||
viewport,
|
||||
] make-gadget ;
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
scroller new-scroller ;
|
||||
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
|
||||
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
|
||||
|
||||
swap over model>> <viewport> >>viewport
|
||||
dup viewport>> @center grid-add* ;
|
||||
|
||||
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
||||
|
||||
: scroll ( value scroller -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -138,10 +138,11 @@ M: elevator layout*
|
|||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ set-gadget-orientation ] keep ;
|
||||
|
||||
: elevator, ( orientation -- )
|
||||
dup <elevator> g-> set-slider-elevator
|
||||
swap <thumb> g-> set-slider-thumb add-gadget
|
||||
@center frame, ;
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add* ;
|
||||
|
||||
: <left-button> ( -- button )
|
||||
{ 0 1 } arrow-left -1 <slide-button> ;
|
||||
|
|
@ -149,26 +150,12 @@ M: elevator layout*
|
|||
: <right-button> ( -- button )
|
||||
{ 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
||||
: build-x-slider ( slider -- slider )
|
||||
[
|
||||
<left-button> @left frame,
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right frame,
|
||||
] make-gadget ; inline
|
||||
|
||||
: <up-button> ( -- button )
|
||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
||||
|
||||
: <down-button> ( -- button )
|
||||
{ 1 0 } arrow-down 1 <slide-button> ;
|
||||
|
||||
: build-y-slider ( slider -- slider )
|
||||
[
|
||||
<up-button> @top frame,
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom frame,
|
||||
] make-gadget ; inline
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
slider new-frame
|
||||
swap >>orientation
|
||||
|
|
@ -176,10 +163,16 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider> build-x-slider ;
|
||||
{ 1 0 } <slider>
|
||||
<left-button> @left grid-add*
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right grid-add* ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider> build-y-slider ;
|
||||
{ 0 1 } <slider>
|
||||
<up-button> @top grid-add*
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom grid-add* ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
|
|
|
|||
|
|
@ -69,15 +69,13 @@ M: value-ref finish-editing
|
|||
} define-command
|
||||
|
||||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
[
|
||||
toolbar,
|
||||
<source-editor> g-> set-slot-editor-text
|
||||
<scroller> 1 track,
|
||||
] make-gadget
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add*
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add*
|
||||
dup revert ;
|
||||
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
||||
M: slot-editor focusable-child* text>> ;
|
||||
|
|
|
|||
|
|
@ -48,9 +48,13 @@ DEFER: (del-page)
|
|||
[ names>> index ] 2keep (del-page) ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed )
|
||||
tabbed new-frame
|
||||
[ g 0 <model> >>model
|
||||
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
|
||||
[ keys >vector g swap >>names ]
|
||||
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
|
||||
g redo-toggler g ] with-gadget ;
|
||||
tabbed new-frame
|
||||
0 <model> >>model
|
||||
<pile> 1 >>fill >>toggler
|
||||
dup toggler>> @left grid-add*
|
||||
swap
|
||||
[ keys >vector >>names ]
|
||||
[ values over model>> <book> >>content dup content>> @center grid-add* ]
|
||||
bi
|
||||
dup redo-toggler ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ IN: ui.tools.listener
|
|||
|
||||
TUPLE: listener-gadget < track input output stack ;
|
||||
|
||||
: listener-output, ( -- )
|
||||
<scrolling-pane> g-> set-listener-gadget-output
|
||||
<scroller> "Output" <labelled-gadget> 1 track, ;
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -22,10 +22,12 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
: <listener-input> ( listener -- gadget )
|
||||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( -- )
|
||||
g <listener-input> g-> set-listener-gadget-input
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget> f track, ;
|
||||
"Input" <labelled-gadget>
|
||||
f track-add* ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
|
|
@ -169,10 +171,11 @@ M: stack-display tool-scroller
|
|||
f <model> swap set-listener-gadget-stack ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
[ listener-output, listener-input, ] make-gadget ;
|
||||
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
\ listener-help H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
|
|||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
IN: ui.tools.tests
|
||||
|
||||
[ f ]
|
||||
[
|
||||
[ f ] [
|
||||
0 <model> <gadget> [ set-gadget-model ] keep gadget set
|
||||
<workspace-tabs> gadget-children empty?
|
||||
] unit-test
|
||||
] with-scope
|
||||
<gadget> 0 <model> >>model <workspace-tabs> children>> empty?
|
||||
] unit-test
|
||||
|
||||
[ ] [ <workspace> "w" set ] unit-test
|
||||
[ ] [ "w" get com-scroll-up ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue