steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

More control refactoring

release
Slava Pestov 2007-11-14 16:35:17 -05:00
parent 9bb0c40dc8
commit eee42d4bd5
26 changed files with 133 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/models/models-docs.factor Normal file → Executable file
View File

@ -106,7 +106,7 @@ $nl
": <funny-slider> <x-slider> 100 over set-slider-max ;" ": <funny-slider> <x-slider> 100 over set-slider-max ;"
"<funny-slider> <funny-slider> 2array" "<funny-slider> <funny-slider> 2array"
"dup make-pile gadget." "dup make-pile gadget."
"dup [ control-model ] map <compose> [ unparse ] <filter>" "dup [ gadget-model ] map <compose> [ unparse ] <filter>"
"<label-control> gadget." "<label-control> gadget."
} }
} ; } ;
@ -146,7 +146,7 @@ HELP: delay
": <funny-slider>" ": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;" " 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget." "<funny-slider> dup gadget."
"control-model 500 <delay> [ number>string ] <filter>" "gadget-model 500 <delay> [ number>string ] <filter>"
"<label-control> gadget." "<label-control> gadget."
} }
} ; } ;

2
extra/slides/slides.factor
View File

@ -75,7 +75,7 @@ TUPLE: slides ;
: change-page ( book n -- ) : change-page ( book n -- )
over control-value + over gadget-children length rem over control-value + over gadget-children length rem
swap control-model set-model ; swap gadget-model set-model ;
: next-page ( book -- ) 1 change-page ; : next-page ( book -- ) 1 change-page ;

4
extra/ui/gadgets/books/books-docs.factor
View File

@ -2,10 +2,10 @@ USING: ui.gadgets.books help.markup
help.syntax ui.gadgets models ; help.syntax ui.gadgets models ;
HELP: book HELP: book
{ $class-description "A book is a " { $link control } " containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." { $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
$nl $nl
"Books are created by calling " { $link <book> } "." } ; "Books are created by calling " { $link <book> } "." } ;
HELP: <book> HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } } { $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
{ $description "Creates a " { $link book } { $link control } ", which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ; { $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;

19
extra/ui/gadgets/buttons/buttons-tests.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
IN: temporary IN: temporary
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
ui.gadgets tools.test namespaces sequences kernel ; ui.gadgets tools.test namespaces sequences kernel models ;
TUPLE: foo-gadget ; TUPLE: foo-gadget ;
@ -17,3 +17,20 @@ T{ foo-gadget } <toolbar> "t" set
[ 2 ] [ "t" get gadget-children length ] unit-test [ 2 ] [ "t" get gadget-children length ] unit-test
[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test
[ ] [
2 <model> {
{ 0 "atheist" }
{ 1 "christian" }
{ 2 "muslim" }
{ 3 "jewish" }
} <radio-buttons> "religion" set
] unit-test
[ 0 ] [
"religion" get gadget-child radio-control-value
] unit-test
[ 2 ] [
"religion" get gadget-child control-value
] unit-test

9
extra/ui/gadgets/buttons/buttons.factor
View File

@ -183,13 +183,14 @@ M: radio-control model-changed
over set-button-selected? over set-button-selected?
relayout-1 ; relayout-1 ;
: <radio-controls> ( model assoc quot -- gadget ) : <radio-controls> ( model assoc quot -- )
swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline #! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
: radio-button-theme : radio-button-theme
{ 5 5 } over set-pack-gap 1/2 swap set-pack-align ; { 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
: <radio-button> ( model value label -- gadget ) : <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right <radio-knob> label-on-right
[ <button> ] <radio-control> [ <button> ] <radio-control>
dup radio-button-theme ; dup radio-button-theme ;
@ -201,7 +202,7 @@ M: radio-control model-changed
[ [ <radio-button> ] <radio-controls> ] make-filled-pile [ [ <radio-button> ] <radio-controls> ] make-filled-pile
dup radio-buttons-theme ; dup radio-buttons-theme ;
: <toggle-button> ( model value label -- gadget ) : <toggle-button> ( value model label -- gadget )
[ <bevel-button> ] <radio-control> ; [ <bevel-button> ] <radio-control> ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )

2
extra/ui/gadgets/editors/editors-docs.factor
View File

@ -3,7 +3,7 @@ ui.gadgets.scrollers models strings ui.commands ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
HELP: editor HELP: editor
{ $class-description "An editor is a " { $link control } " for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "." { $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
$nl $nl
"Editors have the following slots:" "Editors have the following slots:"
{ $list { $list

58
extra/ui/gadgets/editors/editors.factor
View File

@ -9,6 +9,7 @@ colors combinators ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor TUPLE: editor
self
font color caret-color selection-color font color caret-color selection-color
caret mark caret mark
focused? ; focused? ;
@ -31,6 +32,7 @@ TUPLE: loc-monitor editor ;
: <editor> ( -- editor ) : <editor> ( -- editor )
<document> <gadget> editor construct-control <document> <gadget> editor construct-control
dup dup set-editor-self
dup init-editor-locs dup init-editor-locs
dup editor-theme ; dup editor-theme ;
@ -38,42 +40,42 @@ TUPLE: loc-monitor editor ;
gray <solid> swap set-gadget-boundary ; gray <solid> swap set-gadget-boundary ;
: construct-editor ( class -- tuple ) : construct-editor ( class -- tuple )
>r <editor> { set-gadget-delegate } r> >r <editor> { set-gadget-delegate } r> construct
(construct-control) ; inline dup dup set-editor-self ; inline
TUPLE: source-editor ; TUPLE: source-editor ;
: <source-editor> source-editor construct-editor ; : <source-editor> source-editor construct-editor ;
: activate-editor-model ( editor model -- ) : activate-editor-model ( editor model -- )
dup activate-model swap control-model add-loc ; dup activate-model swap gadget-model add-loc ;
: deactivate-editor-model ( editor model -- ) : deactivate-editor-model ( editor model -- )
dup deactivate-model swap control-model remove-loc ; dup deactivate-model swap gadget-model remove-loc ;
M: editor graft* M: editor graft*
dup dup editor-caret activate-editor-model dup
dup dup editor-mark activate-editor-model dup editor-caret activate-editor-model
dup control-self swap control-model add-connection ; dup editor-mark activate-editor-model ;
M: editor ungraft* M: editor ungraft*
dup dup editor-caret deactivate-editor-model dup
dup dup editor-mark deactivate-editor-model dup editor-caret deactivate-editor-model
dup control-self swap control-model remove-connection ; dup editor-mark deactivate-editor-model ;
M: editor model-changed M: editor model-changed
control-self dup control-model dup gadget-model
over editor-caret [ over validate-loc ] (change-model) over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model) over editor-mark [ over validate-loc ] (change-model)
drop relayout ; drop editor-self relayout ;
: editor-caret* ( editor -- loc ) editor-caret model-value ; : editor-caret* ( editor -- loc ) editor-caret model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ; : editor-mark* ( editor -- loc ) editor-mark model-value ;
: change-caret ( editor quot -- ) : change-caret ( editor quot -- )
over >r >r dup editor-caret* swap control-model r> call r> over >r >r dup editor-caret* swap gadget-model r> call r>
[ control-model validate-loc ] keep [ gadget-model validate-loc ] keep
editor-caret set-model ; inline editor-caret set-model ; inline
: mark>caret ( editor -- ) : mark>caret ( editor -- )
@ -90,7 +92,7 @@ M: editor model-changed
editor-font* "" string-height ; editor-font* "" string-height ;
: y>line ( y editor -- line# ) : y>line ( y editor -- line# )
[ line-height / >fixnum ] keep control-model validate-line ; [ line-height / >fixnum ] keep gadget-model validate-line ;
: point>loc ( point editor -- loc ) : point>loc ( point editor -- loc )
[ [
@ -133,7 +135,7 @@ M: editor model-changed
] when drop ; ] when drop ;
M: loc-monitor model-changed M: loc-monitor model-changed
loc-monitor-editor control-self loc-monitor-editor editor-self
dup relayout-1 scroll>caret ; dup relayout-1 scroll>caret ;
: draw-caret ( -- ) : draw-caret ( -- )
@ -167,7 +169,7 @@ M: loc-monitor model-changed
swap swap
dup first-visible-line \ first-visible-line set dup first-visible-line \ first-visible-line set
dup last-visible-line \ last-visible-line set dup last-visible-line \ last-visible-line set
dup control-model document set dup gadget-model document set
editor set editor set
call call
] with-scope ; inline ] with-scope ; inline
@ -221,19 +223,19 @@ M: editor gadget-selection?
selection-start/end = not ; selection-start/end = not ;
M: editor gadget-selection M: editor gadget-selection
[ selection-start/end ] keep control-model doc-range ; [ selection-start/end ] keep gadget-model doc-range ;
: remove-selection ( editor -- ) : remove-selection ( editor -- )
[ selection-start/end ] keep control-model remove-doc-range ; [ selection-start/end ] keep gadget-model remove-doc-range ;
M: editor user-input* M: editor user-input*
[ selection-start/end ] keep control-model set-doc-range t ; [ selection-start/end ] keep gadget-model set-doc-range t ;
: editor-string ( editor -- string ) : editor-string ( editor -- string )
control-model doc-string ; gadget-model doc-string ;
: set-editor-string ( string editor -- ) : set-editor-string ( string editor -- )
control-model set-doc-string ; gadget-model set-doc-string ;
M: editor gadget-text* editor-string % ; M: editor gadget-text* editor-string % ;
@ -250,8 +252,8 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [ over gadget-selection? [
drop nip remove-selection drop nip remove-selection
] [ ] [
over >r >r dup editor-caret* swap control-model over >r >r dup editor-caret* swap gadget-model
r> call r> control-model remove-doc-range r> call r> gadget-model remove-doc-range
] if ; inline ] if ; inline
: editor-delete ( editor elt -- ) : editor-delete ( editor elt -- )
@ -277,7 +279,7 @@ M: editor gadget-text* editor-string % ;
: select-elt ( editor elt -- ) : select-elt ( editor elt -- )
over >r over >r
>r dup editor-caret* swap control-model r> prev/next-elt >r dup editor-caret* swap gadget-model r> prev/next-elt
r> editor-select ; r> editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@ -423,7 +425,7 @@ editor "selection" f {
M: editor stream-write1 >r 1string r> stream-write ; M: editor stream-write1 >r 1string r> stream-write ;
M: editor stream-write M: editor stream-write
control-self dup end-of-document user-input ; editor-self dup end-of-document user-input ;
M: editor stream-close drop ; M: editor stream-close drop ;
@ -445,10 +447,10 @@ TUPLE: field model editor ;
M: field graft* M: field graft*
dup field-model model-value dup field-model model-value
over field-editor set-editor-string over field-editor set-editor-string
dup field-editor control-model add-connection ; dup field-editor gadget-model add-connection ;
M: field ungraft* M: field ungraft*
dup field-editor control-model remove-connection ; dup field-editor gadget-model remove-connection ;
M: field model-changed M: field model-changed
dup field-editor editor-string dup field-editor editor-string

12
extra/ui/gadgets/gadgets.factor
View File

@ -68,16 +68,12 @@ M: gadget model-changed drop ;
: construct-gadget ( class -- tuple ) : construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline >r <gadget> r> construct-delegate ; inline
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model r> construct-delegate ; inline
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ dupd add-connection ] when dup gadget-model dup [ 2dup add-connection ] when drop
model-changed ; model-changed ;
: deactivate-control ( gadget -- ) : deactivate-control ( gadget -- )
dup gadget-model dup [ dupd remove-connection ] when dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
drop ;
: control-value ( control -- value ) : control-value ( control -- value )
gadget-model model-value ; gadget-model model-value ;
@ -139,6 +135,10 @@ M: gadget children-on nip gadget-children ;
dup pick [ set-gadget-parent ] curry* each-child dup pick [ set-gadget-parent ] curry* each-child
] when set-delegate ; ] when set-delegate ;
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model
{ set-gadget-delegate } r> construct ; inline
! Selection protocol ! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? ) GENERIC: gadget-selection? ( gadget -- ? )

2
extra/ui/gadgets/labelled/labelled-docs.factor
View File

@ -19,7 +19,7 @@ HELP: <closable-gadget>
HELP: <labelled-pane> HELP: <labelled-pane>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } } { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ; { $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ <labelled-pane> <pane-control> } related-words { <labelled-pane> <pane-control> } related-words

2
extra/ui/gadgets/labels/labels-docs.factor
View File

@ -18,7 +18,7 @@ HELP: set-label-string
HELP: <label-control> HELP: <label-control>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } } { $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a " { $link control } " which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ; { $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
{ label-string set-label-string } related-words { label-string set-label-string } related-words
{ <label> <label-control> } related-words { <label> <label-control> } related-words

3
extra/ui/gadgets/labels/labels.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math namespaces USING: arrays hashtables io kernel math namespaces
opengl sequences io.streams.lines strings splitting opengl sequences io.streams.lines strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors ; ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
IN: ui.gadgets.labels IN: ui.gadgets.labels
! A label gadget draws a string. ! A label gadget draws a string.

2
extra/ui/gadgets/lists/lists-docs.factor
View File

@ -7,7 +7,7 @@ HELP: +secondary+
HELP: list HELP: list
{ $class-description { $class-description
"A list " { $link control } " is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects." "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
$nl $nl
"Lists are created by calling " { $link <list> } "." "Lists are created by calling " { $link <list> } "."
{ $command-map list "keyboard-navigation" } { $command-map list "keyboard-navigation" }

2
extra/ui/gadgets/panes/panes-docs.factor
View File

@ -44,7 +44,7 @@ HELP: <scrolling-pane>
HELP: <pane-control> HELP: <pane-control>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } } { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ; { $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
HELP: pane-stream HELP: pane-stream
{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ; { $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;

2
extra/ui/gadgets/panes/panes.factor
View File

@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines tuples ; ui.gadgets.grid-lines tuples models ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls? TUPLE: pane output current prototype scrolls?

24
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -1,7 +1,8 @@
IN: temporary IN: temporary
USING: ui.gadgets ui.gadgets.scrollers USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports math namespaces tools.test kernel models ui.gadgets.viewports
math.vectors arrays sequences ; ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences ;
[ ] [ [ ] [
<gadget> "g" set <gadget> "g" set
@ -22,7 +23,7 @@ math.vectors arrays sequences ;
<viewport> "v" set <viewport> "v" set
] unit-test ] unit-test
[ { 10 20 } ] [ "v" get control-model range-value ] unit-test [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
@ -43,15 +44,15 @@ math.vectors arrays sequences ;
[ ] [ { 0 0 } "s" get scroll ] unit-test [ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get control-model range-min-value ] unit-test [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
[ { 106 106 } ] [ "s" get control-model range-max-value ] unit-test [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test [ ] [ { 10 20 } "s" get scroll ] unit-test
[ { 10 20 } ] [ "s" get control-model range-value ] unit-test [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport control-model range-value ] unit-test [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
@ -74,3 +75,12 @@ dup layout
"s" get scroller-value "s" get scroller-value
] map [ { 3 0 } = ] all? ] map [ { 3 0 } = ] all?
] unit-test ] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test

31
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -29,15 +29,15 @@ scroller H{
} set-gestures } set-gestures
: viewport, ( -- ) : viewport, ( -- )
g control-model <viewport> g gadget-model <viewport>
g-> set-scroller-viewport @center frame, ; g-> set-scroller-viewport @center frame, ;
: <scroller-model> ( -- model ) : <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ; 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: x-model g control-model model-dependencies first ; : x-model g gadget-model model-dependencies first ;
: y-model g control-model model-dependencies second ; : y-model g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller ) : <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [ <scroller-model> <frame> scroller construct-control [
@ -70,11 +70,18 @@ scroller H{
] keep dup scroller-value rot v+ swap scroll ; ] keep dup scroller-value rot v+ swap scroll ;
: relative-scroll-rect ( rect gadget scroller -- newrect ) : relative-scroll-rect ( rect gadget scroller -- newrect )
scroller-viewport gadget-child 2dup swap child? scroller-viewport gadget-child relative-loc offset-rect ;
[ relative-loc offset-rect ] [ 3drop f ] if ;
: find-scroller* ( gadget -- scroller )
dup find-scroller dup [
2dup scroller-viewport gadget-child
swap child? [ nip ] [ 2drop f ] if
] [
2drop f
] if ;
: scroll>rect ( rect gadget -- ) : scroll>rect ( rect gadget -- )
dup find-scroller dup [ dup find-scroller* dup [
[ relative-scroll-rect ] keep [ relative-scroll-rect ] keep
[ set-scroller-follows ] keep [ set-scroller-follows ] keep
relayout relayout
@ -88,7 +95,7 @@ scroller H{
(scroll>rect) ; (scroll>rect) ;
: scroll>gadget ( gadget -- ) : scroll>gadget ( gadget -- )
dup find-scroller dup [ dup find-scroller* dup [
[ set-scroller-follows ] keep [ set-scroller-follows ] keep
relayout relayout
] [ ] [
@ -99,7 +106,7 @@ scroller H{
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ; dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- ) : scroll>bottom ( gadget -- )
find-scroller [ find-scroller* [
t over set-scroller-follows relayout-1 t over set-scroller-follows relayout-1
] when* ; ] when* ;
@ -108,10 +115,10 @@ scroller H{
: update-scroller ( scroller follows -- ) : update-scroller ( scroller follows -- )
{ {
{ [ dup t eq? ] [ drop (scroll>bottom) ] } { [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] }
{ [ dup rect? ] [ swap (scroll>rect) ] } { [ dup rect? ] [ swap (scroll>rect) "B" drop ] }
{ [ dup ] [ swap (scroll>gadget) ] } { [ dup ] [ swap (scroll>gadget) "C" drop ] }
{ [ t ] [ drop dup scroller-value swap scroll ] } { [ t ] [ drop dup scroller-value swap scroll "D" drop ] }
} cond ; } cond ;
M: scroller layout* M: scroller layout*

4
extra/ui/gadgets/sliders/sliders-docs.factor
View File

@ -9,7 +9,7 @@ HELP: find-elevator
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ; { $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
HELP: slider HELP: slider
{ $class-description "A slider is a " { $link control } " for graphically manipulating a " { $link "models-range" } "." { $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl $nl
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ; "Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
@ -56,6 +56,6 @@ ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
{ $subsection slide-by } { $subsection slide-by }
{ $subsection slide-by-line } { $subsection slide-by-line }
{ $subsection slide-by-page } { $subsection slide-by-page }
"Since sliders are controls the value can be get and set by calling " { $link control-model } "." ; "Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
ABOUT: "ui.gadgets.sliders" ABOUT: "ui.gadgets.sliders"

14
extra/ui/gadgets/sliders/sliders.factor
View File

@ -22,13 +22,13 @@ TUPLE: slider elevator thumb saved line ;
: min-thumb-dim 15 ; : min-thumb-dim 15 ;
: slider-value control-model range-value >fixnum ; : slider-value gadget-model range-value >fixnum ;
: slider-page control-model range-page-value ; : slider-page gadget-model range-page-value ;
: slider-max control-model range-max-value ; : slider-max gadget-model range-max-value ;
: slider-max* control-model range-max-value* ; : slider-max* gadget-model range-max-value* ;
: thumb-dim ( slider -- h ) : thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min dup slider-page over slider-max 1 max / 1 min
@ -57,7 +57,7 @@ TUPLE: thumb ;
: do-drag ( thumb -- ) : do-drag ( thumb -- )
find-slider drag-loc over gadget-orientation v. find-slider drag-loc over gadget-orientation v.
over screen>slider swap [ slider-saved + ] keep over screen>slider swap [ slider-saved + ] keep
control-model set-range-value ; gadget-model set-range-value ;
thumb H{ thumb H{
{ T{ button-down } [ begin-drag ] } { T{ button-down } [ begin-drag ] }
@ -75,10 +75,10 @@ thumb H{
[ set-gadget-orientation ] keep ; [ set-gadget-orientation ] keep ;
: slide-by ( amount slider -- ) : slide-by ( amount slider -- )
control-model move-by ; gadget-model move-by ;
: slide-by-page ( amount slider -- ) : slide-by-page ( amount slider -- )
control-model move-by-page ; gadget-model move-by-page ;
: compute-direction ( elevator -- -1/1 ) : compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel dup find-slider swap hand-click-rel

2
extra/ui/gadgets/viewports/viewports-docs.factor
View File

@ -2,7 +2,7 @@ USING: ui.gadgets.viewports help.markup
help.syntax ui.gadgets models ; help.syntax ui.gadgets models ;
HELP: viewport HELP: viewport
{ $class-description "A viewport is a " { $link control } " which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ; { $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
HELP: <viewport> HELP: <viewport>
{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } } { $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }

2
extra/ui/gadgets/viewports/viewports.factor
View File

@ -30,7 +30,7 @@ M: viewport focusable-child*
M: viewport pref-dim* viewport-dim ; M: viewport pref-dim* viewport-dim ;
: scroller-value ( scroller -- loc ) : scroller-value ( scroller -- loc )
control-model range-value [ >fixnum ] map ; gadget-model range-value [ >fixnum ] map ;
M: viewport model-changed M: viewport model-changed
dup relayout-1 dup relayout-1

10
extra/ui/tools/interactor/interactor.factor
View File

@ -19,7 +19,7 @@ help ;
: word-at-loc ( loc interactor -- word ) : word-at-loc ( loc interactor -- word )
over [ over [
[ control-model T{ one-word-elt } elt-string ] keep [ gadget-model T{ one-word-elt } elt-string ] keep
interactor-use assoc-stack interactor-use assoc-stack
] [ ] [
2drop f 2drop f
@ -46,7 +46,7 @@ M: caret-help model-changed
<source-editor> <source-editor>
{ set-interactor-output set-gadget-delegate } { set-interactor-output set-gadget-delegate }
interactor construct interactor construct
dup dup set-control-self dup dup set-editor-self
dup init-interactor-history dup init-interactor-history
dup init-caret-help ; dup init-caret-help ;
@ -79,7 +79,7 @@ M: interactor ungraft*
[ editor-string ] keep [ editor-string ] keep
[ interactor-input. ] 2keep [ interactor-input. ] 2keep
[ add-interactor-history ] keep [ add-interactor-history ] keep
dup control-model clear-doc dup gadget-model clear-doc
interactor-continue ; interactor-continue ;
: interactor-eval ( interactor -- ) : interactor-eval ( interactor -- )
@ -123,7 +123,7 @@ M: interactor stream-read-partial
: go-to-error ( interactor error -- ) : go-to-error ( interactor error -- )
dup parse-error-line 1- swap parse-error-col 2array dup parse-error-line 1- swap parse-error-col 2array
over [ control-model validate-loc ] keep over [ gadget-model validate-loc ] keep
editor-caret set-model editor-caret set-model
mark>caret ; mark>caret ;
@ -156,7 +156,7 @@ M: interactor parse-interactive
M: interactor pref-dim* M: interactor pref-dim*
0 over line-height 4 * 2array swap delegate pref-dim* vmax ; 0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
: clear-input control-model clear-doc ; : clear-input gadget-model clear-doc ;
interactor "interactor" f { interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input } { T{ key-down f f "RET" } evaluate-input }

4
extra/ui/tools/listener/listener-tests.factor
View File

@ -1,6 +1,6 @@
USING: continuations documents ui.tools.interactor USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets.editors timers tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words ; ui.gadgets.panes vocabs words ;
IN: temporary IN: temporary
@ -30,6 +30,6 @@ H{ } "i" get set-interactor-vars
] unit-test ] unit-test
[ t ] [ [ t ] [
"i" get control-model doc-end "i" get gadget-model doc-end
"i" get editor-caret* = "i" get editor-caret* =
] unit-test ] unit-test

2
extra/ui/tools/search/search.factor
View File

@ -44,7 +44,7 @@ search-field H{
} set-gestures } set-gestures
: <search-model> ( producer -- model ) : <search-model> ( producer -- model )
>r g live-search-field control-model 200 <delay> >r g live-search-field gadget-model 200 <delay>
[ "\n" join ] r> append <filter> ; [ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget ) : <search-list> ( seq limited? presenter -- gadget )

4
extra/ui/tools/tools.factor
View File

@ -22,13 +22,13 @@ IN: ui.tools
} ; } ;
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( -- tabs )
g control-model g gadget-model
"tool-switching" workspace command-map "tool-switching" workspace command-map
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( -- gadget ) : <workspace-book> ( -- gadget )
workspace-tabs [ execute ] map g control-model <book> ; workspace-tabs [ execute ] map g gadget-model <book> ;
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [ 0 <model> { 0 1 } <track> workspace construct-control [

6
extra/ui/tools/traceback/traceback.factor
View File

@ -25,10 +25,10 @@ M: traceback-gadget pref-dim* drop { 300 400 } ;
{ 0 1 } <track> traceback-gadget construct-control [ { 0 1 } <track> traceback-gadget construct-control [
[ [
[ [
g control-model <datastack-display> 1/2 track, g gadget-model <datastack-display> 1/2 track,
g control-model <retainstack-display> 1/2 track, g gadget-model <retainstack-display> 1/2 track,
] { 1 0 } make-track 1/3 track, ] { 1 0 } make-track 1/3 track,
g control-model <callstack-display> 2/3 track, g gadget-model <callstack-display> 2/3 track,
] with-gadget ] with-gadget
] keep ; ] keep ;

2
extra/ui/tools/workspace/workspace.factor
View File

@ -28,7 +28,7 @@ M: gadget tool-scroller drop f ;
workspace-book gadget-children [ class eq? ] curry* find ; workspace-book gadget-children [ class eq? ] curry* find ;
: show-tool ( class workspace -- tool ) : show-tool ( class workspace -- tool )
[ find-tool swap ] keep workspace-book control-model [ find-tool swap ] keep workspace-book gadget-model
set-model ; set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ; : select-tool ( workspace class -- ) swap show-tool drop ;