Fix ridiculous indentation, over (>>foo), and other crap in UI

db4
Slava Pestov 2008-09-27 14:36:04 -05:00
parent 016a1ed817
commit b7610e0bf7
38 changed files with 299 additions and 321 deletions

View File

@ -16,15 +16,15 @@ M: book model-changed ( model book -- )
relayout ; relayout ;
: new-book ( pages model class -- book ) : new-book ( pages model class -- book )
new-gadget new-gadget
swap >>model swap >>model
swap add-gadgets ; inline swap add-gadgets ; inline
: <book> ( pages model -- book ) book new-book ; : <book> ( pages model -- book ) book new-book ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ; M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- ) M: book layout* ( book -- )
[ dim>> ] [ children>> ] bi [ (>>dim) ] with each ; [ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
M: book focusable-child* ( book -- child/t ) current-page ; M: book focusable-child* ( book -- child/t ) current-page ;

View File

@ -10,7 +10,7 @@ TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ; { align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border ) : new-border ( child class -- border )
new-gadget [ swap add-gadget drop ] keep ; inline new-gadget swap add-gadget ; inline
: <border> ( child gap -- border ) : <border> ( child gap -- border )
swap border new-border swap border new-border

View File

@ -25,7 +25,7 @@ TUPLE: button < border pressed? selected? quot ;
dup mouse-clicked? dup mouse-clicked?
over button-rollover? and over button-rollover? and
buttons-down? and buttons-down? and
over (>>pressed?) >>pressed?
relayout-1 ; relayout-1 ;
: if-clicked ( button quot -- ) : if-clicked ( button quot -- )
@ -115,20 +115,18 @@ M: checkmark-paint draw-interior
dup { 0 1 } v* swap { 1 0 } v* gl-line dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ; ] with-translation ;
: checkmark-theme ( gadget -- ) : checkmark-theme ( gadget -- gadget )
f f
f f
black <solid> black <solid>
black <checkmark-paint> black <checkmark-paint>
<button-paint> <button-paint> >>interior
over (>>interior) black <solid> >>boundary ;
black <solid>
swap (>>boundary) ;
: <checkmark> ( -- gadget ) : <checkmark> ( -- gadget )
<gadget> <gadget>
dup checkmark-theme checkmark-theme
{ 14 14 } over (>>dim) ; { 14 14 } >>dim ;
: toggle-model ( model -- ) : toggle-model ( model -- )
[ not ] change-model ; [ not ] change-model ;
@ -148,7 +146,7 @@ TUPLE: checkbox < button ;
align-left ; align-left ;
M: checkbox model-changed M: checkbox model-changed
swap value>> over (>>selected?) relayout-1 ; swap value>> >>selected? relayout-1 ;
TUPLE: radio-paint color ; TUPLE: radio-paint color ;
@ -162,20 +160,18 @@ M: radio-paint draw-boundary
color>> set-color color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- ) : radio-knob-theme ( gadget -- gadget )
f f
f f
black <radio-paint> black <radio-paint>
black <radio-paint> black <radio-paint>
<button-paint> <button-paint> >>interior
over (>>interior) black <radio-paint> >>boundary ;
black <radio-paint>
swap (>>boundary) ;
: <radio-knob> ( -- gadget ) : <radio-knob> ( -- gadget )
<gadget> <gadget>
dup radio-knob-theme radio-knob-theme
{ 16 16 } over (>>dim) ; { 16 16 } >>dim ;
TUPLE: radio-control < button value ; TUPLE: radio-control < button value ;
@ -188,13 +184,12 @@ TUPLE: radio-control < button value ;
M: radio-control model-changed M: radio-control model-changed
swap value>> swap value>>
over value>> = over value>> = >>selected?
over (>>selected?)
relayout-1 ; relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent ) : <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- ) #! quot has stack effect ( value model label -- )
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -204,18 +199,18 @@ M: radio-control model-changed
<radio-knob> label-on-right radio-button-theme <radio-control> ; <radio-knob> label-on-right radio-button-theme <radio-control> ;
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
<filled-pile> <filled-pile>
-rot -rot
[ <radio-button> ] <radio-controls> [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ; { 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ; <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
<shelf> <shelf>
-rot -rot
[ <toggle-button> ] <radio-controls> ; [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ; [ invoke-command drop ] 2curry ;
@ -227,7 +222,7 @@ M: radio-control model-changed
<bevel-button> ; <bevel-button> ;
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
<shelf> <shelf>
swap swap
"toolbar" over class command-map commands>> swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ; [ -rot <command-button> add-gadget ] curry assoc-each ;

View File

@ -96,9 +96,9 @@ M: editor ungraft*
: click-loc ( editor model -- ) : click-loc ( editor model -- )
>r clicked-loc r> set-model ; >r clicked-loc r> set-model ;
: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ; : focus-editor ( editor -- ) t >>focused? relayout-1 ;
: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ; : unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: (offset>x) ( font col# str -- x ) : (offset>x) ( font col# str -- x )
swap head-slice string-width ; swap head-slice string-width ;

View File

@ -9,9 +9,9 @@ IN: ui.gadgets.tests
! c contains b contains a ! c contains b contains a
<gadget> "a" set <gadget> "a" set
<gadget> "b" set <gadget> "b" set
"a" get "b" get swap add-gadget drop "b" get "a" get add-gadget drop
<gadget> "c" set <gadget> "c" set
"b" get "c" get swap add-gadget drop "c" get "b" get add-gadget drop
! position a and b ! position a and b
"a" get { 100 200 } >>loc drop "a" get { 100 200 } >>loc drop
@ -33,8 +33,8 @@ IN: ui.gadgets.tests
<gadget> "g3" set <gadget> "g3" set
"g3" get { 100 200 } >>dim drop "g3" get { 100 200 } >>dim drop
"g1" get "g2" get swap add-gadget drop "g2" get "g1" get add-gadget drop
"g2" get "g3" get swap add-gadget drop "g3" get "g2" get add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@ -49,11 +49,11 @@ IN: ui.gadgets.tests
<gadget> "g1" set <gadget> "g1" set
"g1" get { 300 300 } >>dim drop "g1" get { 300 300 } >>dim drop
<gadget> "g2" set <gadget> "g2" set
"g2" get "g1" get swap add-gadget drop "g1" get "g2" get add-gadget drop
"g2" get { 20 20 } >>loc "g2" get { 20 20 } >>loc
{ 20 20 } >>dim drop { 20 20 } >>dim drop
<gadget> "g3" set <gadget> "g3" set
"g3" get "g1" get swap add-gadget drop "g1" get "g3" get add-gadget drop
"g3" get { 100 100 } >>loc "g3" get { 100 100 } >>loc
{ 20 20 } >>dim drop { 20 20 } >>dim drop
@ -66,7 +66,7 @@ IN: ui.gadgets.tests
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set <gadget> "g4" set
"g4" get "g2" get swap add-gadget drop "g2" get "g4" get add-gadget drop
"g4" get { 5 5 } >>loc "g4" get { 5 5 } >>loc
{ 1 1 } >>dim drop { 1 1 } >>dim drop
@ -121,7 +121,7 @@ M: mock-gadget ungraft*
: add-some-children : add-some-children
3 [ 3 [
<mock-gadget> over <model> >>model <mock-gadget> over <model> >>model
dup "g" get swap add-gadget drop "g" get over add-gadget drop
swap 1+ number>string set swap 1+ number>string set
] each ; ] each ;

View File

@ -27,10 +27,10 @@ M: gadget model-changed 2drop ;
: nth-gadget ( n gadget -- child ) children>> nth ; : nth-gadget ( n gadget -- child ) children>> nth ;
: init-gadget ( gadget -- gadget ) : init-gadget ( gadget -- gadget )
init-rect init-rect
{ 0 1 } >>orientation { 0 1 } >>orientation
t >>visible? t >>visible?
{ f f } >>graft-state ; inline { f f } >>graft-state ; inline
: new-gadget ( class -- gadget ) new init-gadget ; inline : new-gadget ( class -- gadget ) new init-gadget ; inline
@ -147,7 +147,7 @@ M: array gadget-text*
DEFER: relayout DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over (>>layout-state) \ invalidate* >>layout-state
dup forget-pref-dim dup forget-pref-dim
dup root?>> dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ; [ layout-later ] [ parent>> [ relayout ] when* ] if ;
@ -167,7 +167,7 @@ DEFER: relayout
DEFER: in-layout? DEFER: in-layout?
: do-invalidate ( gadget -- gadget ) : do-invalidate ( gadget -- gadget )
in-layout? get [ dup invalidate ] [ dup invalidate* ] if ; in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- ) M: gadget (>>dim) ( dim gadget -- )
2dup dim>> = 2dup dim>> =
@ -282,8 +282,7 @@ SYMBOL: in-layout?
: (clear-gadget) ( gadget -- ) : (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child dup [ (unparent) ] each-child
f over (>>focus) f >>focus f >>children drop ;
f swap (>>children) ;
: clear-gadget ( gadget -- ) : clear-gadget ( gadget -- )
not-in-layout not-in-layout

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect ; math.geometry.rect locals ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
TUPLE: grid < gadget TUPLE: grid < gadget
@ -12,18 +12,18 @@ grid
: new-grid ( children class -- grid ) : new-grid ( children class -- grid )
new-gadget new-gadget
[ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ; swap >>grid
inline dup grid>> concat add-gadgets ; inline
: <grid> ( children -- grid ) : <grid> ( children -- grid )
grid new-grid ; grid new-grid ;
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( grid child i j -- grid ) :: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> grid i j grid-child unparent
>r >r 2dup swap add-gadget drop r> r> grid child add-gadget
3dup grid-child unparent rot grid>> nth set-nth ; child i j grid grid>> nth set-nth ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ; : grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
@ -33,10 +33,10 @@ grid
: (compute-grid) ( grid -- seq ) [ max-dim ] map ; : (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert ) : compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ; pref-dim-grid [ flip (compute-grid) ] [ (compute-grid) ] bi ;
: (pair-up) ( horiz vert -- dim ) : (pair-up) ( horiz vert -- dim )
>r first r> second 2array ; [ first ] [ second ] bi* 2array ;
: pair-up ( horiz vert -- dims ) : pair-up ( horiz vert -- dims )
[ [ (pair-up) ] curry map ] with map ; [ [ (pair-up) ] curry map ] with map ;

View File

@ -24,7 +24,7 @@ TUPLE: incremental < pack cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup layout-state>> [ dup layout-state>> [
dup call-next-method over (>>cursor) dup call-next-method >>cursor
] when cursor>> ; ] when cursor>> ;
: next-cursor ( gadget incremental -- cursor ) : next-cursor ( gadget incremental -- cursor )
@ -57,5 +57,5 @@ M: incremental pref-dim*
not-in-layout not-in-layout
dup (clear-gadget) dup (clear-gadget)
dup forget-pref-dim dup forget-pref-dim
{ 0 0 } over (>>cursor) { 0 0 } >>cursor
parent>> [ relayout ] when* ; parent>> [ relayout ] when* ;

View File

@ -11,10 +11,10 @@ IN: ui.gadgets.labelled
TUPLE: labelled-gadget < track content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
swap <label> reverse-video-theme f track-add swap <label> reverse-video-theme f track-add
swap >>content swap >>content
dup content>> 1 track-add ; dup content>> 1 track-add ;
M: labelled-gadget focusable-child* content>> ; M: labelled-gadget focusable-child* content>> ;
@ -22,25 +22,25 @@ M: labelled-gadget focusable-child* content>> ;
>r <scroller> r> <labelled-gadget> ; >r <scroller> r> <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget ) : <labelled-pane> ( model quot scrolls? title -- gadget )
>r >r <pane-control> r> over (>>scrolls?) r> >r >r <pane-control> r> >>scrolls? r>
<labelled-scroller> ; <labelled-scroller> ;
: <close-box> ( quot -- button/f ) : <close-box> ( quot -- button/f )
gray close-box <polygon-gadget> swap <bevel-button> ; gray close-box <polygon-gadget> swap <bevel-button> ;
: title-theme ( gadget -- ) : title-theme ( gadget -- gadget )
{ 1 0 } over (>>orientation) { 1 0 } >>orientation
T{ gradient f { T{ gradient f {
T{ rgba f 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 }
} } swap (>>interior) ; } } >>interior ;
: <title-label> ( text -- label ) <label> dup title-theme ; : <title-label> ( text -- label ) <label> title-theme ;
: <title-bar> ( title quot -- gadget ) : <title-bar> ( title quot -- gadget )
<frame> <frame>
swap dup [ <close-box> @left grid-add ] [ drop ] if swap dup [ <close-box> @left grid-add ] [ drop ] if
swap <title-label> @center grid-add ; swap <title-label> @center grid-add ;
TUPLE: closable-gadget < frame content ; TUPLE: closable-gadget < frame content ;
@ -48,9 +48,9 @@ TUPLE: closable-gadget < frame content ;
[ closable-gadget? ] find-parent ; [ closable-gadget? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame closable-gadget new-frame
-rot <title-bar> @top grid-add -rot <title-bar> @top grid-add
swap >>content swap >>content
dup content>> @center grid-add ; dup content>> @center grid-add ;
M: closable-gadget focusable-child* content>> ; M: closable-gadget focusable-child* content>> ;

View File

@ -63,11 +63,11 @@ M: object >label ;
M: f >label drop <gadget> ; M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button ) : label-on-left ( gadget label -- button )
{ 1 0 } <track> { 1 0 } <track>
swap >label f track-add swap >label f track-add
swap 1 track-add ; swap 1 track-add ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
{ 1 0 } <track> { 1 0 } <track>
swap f track-add swap f track-add
swap >label 1 track-add ; swap >label 1 track-add ;

View File

@ -49,7 +49,7 @@ TUPLE: list < pack index presenter color hook ;
M: list model-changed M: list model-changed
nip nip
dup clear-gadget dup clear-gadget
dup <list-items> over swap add-gadgets drop dup <list-items> add-gadgets
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )
@ -79,8 +79,8 @@ M: list focusable-child* drop t ;
2drop 2drop
] [ ] [
[ control-value length rem ] keep [ control-value length rem ] keep
[ (>>index) ] keep swap >>index
[ relayout-1 ] keep dup relayout-1
scroll>selected scroll>selected
] if ; ] if ;

View File

@ -15,19 +15,17 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass ) : <menu-glass> ( menu world -- glass )
menu-glass new-gadget menu-glass new-gadget
>r over menu-loc >>loc r> >r over menu-loc >>loc r>
[ swap add-gadget drop ] keep ; swap add-gadget ;
M: menu-glass layout* gadget-child prefer ; M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- ) : hide-glass ( world -- )
dup glass>> [ unparent ] when* [ [ unparent ] when* f ] change-glass drop ;
f swap (>>glass) ;
: show-glass ( gadget world -- ) : show-glass ( gadget world -- )
over hand-clicked set-global dup hide-glass
[ hide-glass ] keep swap [ hand-clicked set-global ] [ >>glass ] bi
[ swap add-gadget drop ] 2keep dup glass>> add-gadget drop ;
(>>glass) ;
: show-menu ( gadget owner -- ) : show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ; find-world [ <menu-glass> ] keep show-glass ;
@ -48,7 +46,7 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ; faint-boundary ;
: <commands-menu> ( hook target commands -- gadget ) : <commands-menu> ( hook target commands -- gadget )
<filled-pile> <filled-pile>
-roll -roll
[ <menu-item> add-gadget ] with with each [ <menu-item> add-gadget ] with with each
5 <border> menu-theme ; 5 <border> menu-theme ;

View File

@ -5,9 +5,9 @@ math.vectors namespaces math.order accessors math.geometry.rect ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
TUPLE: pack < gadget TUPLE: pack < gadget
{ align initial: 0 } { align initial: 0 }
{ fill initial: 0 } { fill initial: 0 }
{ gap initial: { 0 0 } } ; { gap initial: { 0 0 } } ;
: packed-dim-2 ( gadget sizes -- list ) : packed-dim-2 ( gadget sizes -- list )
[ over rect-dim over v- rot fill>> v*n v+ ] with map ; [ over rect-dim over v- rot fill>> v*n v+ ] with map ;
@ -40,7 +40,7 @@ TUPLE: pack < gadget
: <pile> ( -- pack ) { 0 1 } <pack> ; : <pile> ( -- pack ) { 0 1 } <pack> ;
: <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ; : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
: <shelf> ( -- pack ) { 1 0 } <pack> ; : <shelf> ( -- pack ) { 1 0 } <pack> ;

View File

@ -1,45 +1,51 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render ui.clipboards ui.gestures ui.traverse ui.render hashtables io
hashtables io kernel namespaces sequences io.styles strings kernel namespaces sequences io.styles strings quotations math
quotations math opengl combinators math.vectors opengl combinators math.vectors sorting splitting
sorting splitting io.streams.nested assocs io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
ui.gadgets.grid-lines classes.tuple models continuations classes.tuple models continuations destructors accessors
destructors accessors math.geometry.rect ; math.geometry.rect ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane < pack TUPLE: pane < pack
output current prototype scrolls? output current prototype scrolls?
selection-color caret mark selecting? ; selection-color caret mark selecting? ;
: clear-selection ( pane -- pane ) f >>caret f >>mark ; : clear-selection ( pane -- pane )
f >>caret f >>mark ;
: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ; : add-output ( pane current -- pane )
: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ; [ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane )
[ >>current ] [ add-gadget ] bi ;
: prepare-line ( pane -- pane ) : prepare-line ( pane -- pane )
clear-selection clear-selection
dup prototype>> clone add-current ; dup prototype>> clone add-current ;
: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; : pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq ) : selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ; [ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ; M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ; M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
: pane-clear ( pane -- ) : pane-clear ( pane -- )
clear-selection clear-selection
[ output>> clear-incremental ] [ output>> clear-incremental ]
[ current>> clear-gadget ] [ current>> clear-gadget ]
bi ; bi ;
: new-pane ( class -- pane ) : new-pane ( class -- pane )
new-gadget new-gadget
@ -132,7 +138,7 @@ M: style-stream write-gadget
: make-pane ( quot -- gadget ) : make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline <pane> [ swap with-pane ] keep smash-pane ; inline
: <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ; : <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
TUPLE: pane-control < pane quot ; TUPLE: pane-control < pane quot ;
@ -172,7 +178,7 @@ M: pane-stream make-span-stream
>r pick at r> when* ; inline >r pick at r> when* ; inline
: apply-foreground-style ( style gadget -- style gadget ) : apply-foreground-style ( style gadget -- style gadget )
foreground [ over (>>color) ] apply-style ; foreground [ >>color ] apply-style ;
: apply-background-style ( style gadget -- style gadget ) : apply-background-style ( style gadget -- style gadget )
background [ solid-interior ] apply-style ; background [ solid-interior ] apply-style ;
@ -183,7 +189,7 @@ M: pane-stream make-span-stream
font-size swap at 12 or 3array ; font-size swap at 12 or 3array ;
: apply-font-style ( style gadget -- style gadget ) : apply-font-style ( style gadget -- style gadget )
over specified-font over (>>font) ; over specified-font >>font ;
: apply-presentation-style ( style gadget -- style gadget ) : apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ; presented [ <presentation> ] apply-style ;
@ -254,15 +260,15 @@ M: pane-stream make-block-stream
! Tables ! Tables
: apply-table-gap-style ( style grid -- style grid ) : apply-table-gap-style ( style grid -- style grid )
table-gap [ over (>>gap) ] apply-style ; table-gap [ >>gap ] apply-style ;
: apply-table-border-style ( style grid -- style grid ) : apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> over (>>boundary) ] table-border [ <grid-lines> >>boundary ]
apply-style ; apply-style ;
: styled-grid ( style grid -- grid ) : styled-grid ( style grid -- grid )
<grid> <grid>
f over (>>fill?) f >>fill?
apply-table-gap-style apply-table-gap-style
apply-table-border-style apply-table-border-style
nip ; nip ;
@ -286,13 +292,13 @@ M: pack dispose drop ;
M: paragraph dispose drop ; M: paragraph dispose drop ;
: gadget-write ( string gadget -- ) : gadget-write ( string gadget -- )
over empty? swap dup empty?
[ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ; [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
M: pack stream-write gadget-write ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : gadget-bl ( style stream -- )
>r " " <word-break-gadget> style-label r> swap add-gadget drop ; swap " " <word-break-gadget> style-label add-gadget drop ;
M: paragraph stream-write M: paragraph stream-write
swap " " split swap " " split
@ -309,8 +315,8 @@ M: paragraph stream-write1
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ; [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
: gadget-format ( string style stream -- ) : gadget-format ( string style stream -- )
pick empty? spin dup empty?
[ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ; [ 3drop ] [ <styled-label> add-gadget drop ] if ;
M: pack stream-format M: pack stream-format
gadget-format ; gadget-format ;
@ -326,8 +332,8 @@ M: paragraph stream-format
] if ; ] if ;
: caret>mark ( pane -- pane ) : caret>mark ( pane -- pane )
dup caret>> >>mark dup caret>> >>mark
dup relayout-1 ; dup relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n ) GENERIC: sloppy-pick-up* ( loc gadget -- n )
@ -350,12 +356,10 @@ M: f sloppy-pick-up*
if ; if ;
: move-caret ( pane -- pane ) : move-caret ( pane -- pane )
dup hand-rel dup hand-rel over sloppy-pick-up >>caret
over sloppy-pick-up dup relayout-1 ;
over (>>caret)
dup relayout-1 ;
: begin-selection ( pane -- ) move-caret f swap (>>mark) ; : begin-selection ( pane -- ) move-caret f >>mark drop ;
: extend-selection ( pane -- ) : extend-selection ( pane -- )
hand-moved? [ hand-moved? [

View File

@ -17,8 +17,8 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph new-gadget paragraph new-gadget
{ 1 0 } over (>>orientation) { 1 0 } >>orientation
[ (>>margin) ] keep ; swap >>margin ;
SYMBOL: x SYMBOL: max-x SYMBOL: x SYMBOL: max-x

View File

@ -61,7 +61,7 @@ IN: ui.gadgets.scrollers.tests
<gadget> { 600 400 } >>dim "g1" set <gadget> { 600 400 } >>dim "g1" set
<gadget> { 600 10 } >>dim "g2" set <gadget> { 600 10 } >>dim "g2" set
"g2" get "g1" get swap add-gadget drop "g1" get "g2" get add-gadget drop
"g1" get <scroller> "g1" get <scroller>
{ 300 300 } >>dim { 300 300 } >>dim

View File

@ -33,16 +33,16 @@ scroller H{
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ; 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: new-scroller ( gadget class -- scroller ) : new-scroller ( gadget class -- scroller )
new-frame new-frame
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary faint-boundary
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
swap over model>> <viewport> >>viewport swap over model>> <viewport> >>viewport
dup viewport>> @center grid-add ; dup viewport>> @center grid-add ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ; : <scroller> ( gadget -- scroller ) scroller new-scroller ;
@ -81,7 +81,7 @@ scroller H{
: scroll>rect ( rect gadget -- ) : scroll>rect ( rect gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
[ relative-scroll-rect ] keep [ relative-scroll-rect ] keep
[ (>>follows) ] keep swap >>follows
relayout relayout
] [ ] [
3drop 3drop
@ -94,7 +94,7 @@ scroller H{
: scroll>gadget ( gadget -- ) : scroll>gadget ( gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
[ (>>follows) ] keep swap >>follows
relayout relayout
] [ ] [
2drop 2drop
@ -104,9 +104,7 @@ scroller H{
dup viewport>> viewport-dim { 0 1 } v* swap scroll ; dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- ) : scroll>bottom ( gadget -- )
find-scroller [ find-scroller [ t >>follows relayout-1 ] when* ;
t over (>>follows) relayout-1
] when* ;
: scroll>top ( gadget -- ) : scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ; <zero-rect> swap scroll>rect ;

View File

@ -83,7 +83,7 @@ thumb H{
dup direction>> swap find-slider slide-by-page ; dup direction>> swap find-slider slide-by-page ;
: elevator-click ( elevator -- ) : elevator-click ( elevator -- )
dup compute-direction over (>>direction) dup compute-direction >>direction
elevator-hold ; elevator-hold ;
elevator H{ elevator H{
@ -123,13 +123,13 @@ M: elevator layout*
: <slide-button> ( vector polygon amount -- button ) : <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r> >r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button> [ swap find-slider slide-by-line ] curry <repeat-button>
[ (>>orientation) ] keep ; swap >>orientation ;
: elevator, ( gadget orientation -- gadget ) : elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator tuck <elevator> >>elevator
swap <thumb> >>thumb swap <thumb> >>thumb
dup elevator>> over thumb>> add-gadget dup elevator>> over thumb>> add-gadget
@center grid-add ; @center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ; : <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ; : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
@ -143,16 +143,16 @@ M: elevator layout*
32 >>line ; 32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> { 1 0 } <slider>
<left-button> @left grid-add <left-button> @left grid-add
{ 0 1 } elevator, { 0 1 } elevator,
<right-button> @right grid-add ; <right-button> @right grid-add ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
{ 0 1 } <slider> { 0 1 } <slider>
<up-button> @top grid-add <up-button> @top grid-add
{ 1 0 } elevator, { 1 0 } elevator,
<down-button> @bottom grid-add ; <down-button> @bottom grid-add ;
M: slider pref-dim* M: slider pref-dim*
dup call-next-method dup call-next-method

View File

@ -69,12 +69,12 @@ M: value-ref finish-editing
} define-command } define-command
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
dup <toolbar> f track-add dup <toolbar> f track-add
<source-editor> >>text <source-editor> >>text
dup text>> <scroller> 1 track-add dup text>> <scroller> 1 track-add
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;

View File

@ -3,14 +3,14 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test
IN: ui.gadgets.tracks.tests IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [ [ { 100 100 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 100 110 } ] [ [ { 100 110 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add <gadget> { 10 10 } >>dim f track-add
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test

View File

@ -9,23 +9,23 @@ IN: ui.gadgets.tracks
TUPLE: track < pack sizes ; TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq ) : normalized-sizes ( track -- seq )
sizes>> dup sift sum '[ dup [ _ / ] when ] map ; sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
: init-track ( track -- track ) : init-track ( track -- track )
init-gadget init-gadget
V{ } clone >>sizes V{ } clone >>sizes
1 >>fill ; 1 >>fill ;
: new-track ( orientation class -- track ) : new-track ( orientation class -- track )
new new
init-track init-track
swap >>orientation ; swap >>orientation ;
: <track> ( orientation -- track ) track new-track ; : <track> ( orientation -- track ) track new-track ;
: alloted-dim ( track -- dim ) : alloted-dim ( track -- dim )
[ children>> ] [ sizes>> ] bi { 0 0 } [ children>> ] [ sizes>> ] bi { 0 0 }
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ; [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ; : available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
@ -38,10 +38,10 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ; : track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
: track-pref-dims-2 ( track -- dim ) : track-pref-dims-2 ( track -- dim )
[ children>> pref-dims ] [ normalized-sizes ] bi [ children>> pref-dims ] [ normalized-sizes ] bi
[ [ v/n ] when* ] 2map [ [ v/n ] when* ] 2map
max-dim max-dim
[ >fixnum ] map ; [ >fixnum ] map ;
M: track pref-dim* ( gadget -- dim ) M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ] [ track-pref-dims-1 ]
@ -51,16 +51,13 @@ M: track pref-dim* ( gadget -- dim )
set-axis ; set-axis ;
: track-add ( track gadget constraint -- track ) : track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ; pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track ) : track-remove ( track gadget -- track )
dupd dup dupd dup [
[ [ swap children>> index ]
[ swap children>> index ] [ unparent sizes>> ] 2bi
[ unparent sizes>> ] 2bi delete-nth
delete-nth ] [ 2drop ] if ;
]
[ 2drop ]
if ;
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ; : clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;

View File

@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
viewport new-gadget viewport new-gadget
swap >>model swap >>model
t >>clipped? t >>clipped?
[ swap add-gadget drop ] keep ; swap add-gadget ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- dup rect-dim viewport-gap 2 v*n v-

View File

@ -18,7 +18,7 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
"g1" get "g2" get swap add-gadget drop "g2" get "g1" get add-gadget drop
[ ] [ [ ] [
"g2" get <test-world> "w" set "g2" get <test-world> "w" set
@ -33,8 +33,8 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
<gadget> "g3" set <gadget> "g3" set
"g1" get "g3" get swap add-gadget drop "g3" get "g1" get add-gadget drop
"g2" get "g3" get swap add-gadget drop "g3" get "g2" get add-gadget drop
[ ] [ [ ] [
"g3" get <test-world> "w" set "g3" get <test-world> "w" set
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
: <focus-test> : <focus-test>
focus-test new-gadget focus-test new-gadget
<focusing> over swap add-gadget drop ; dup <focusing> add-gadget drop ;
M: focus-test focusable-child* gadget-child ; M: focus-test focusable-child* gadget-child ;

View File

@ -19,8 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
swap >>predicate ; swap >>predicate ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
dup command>> listener-command? [ command>> listener-command? ] [ listener?>> ] bi or ;
swap listener?>> or ;
M: operation command-name M: operation command-name
command>> command-name ; command>> command-name ;
@ -59,15 +58,15 @@ SYMBOL: operations
: modify-operation ( hook translator operation -- operation ) : modify-operation ( hook translator operation -- operation )
clone clone
tuck (>>translator) swap >>translator
tuck (>>hook) swap >>hook
t over (>>listener?) ; t >>listener? ;
: modify-operations ( operations hook translator -- operations ) : modify-operations ( operations hook translator -- operations )
rot [ >r 2dup r> modify-operation ] map 2nip ; rot [ modify-operation ] with with map ;
: operations>commands ( object hook translator -- pairs ) : operations>commands ( object hook translator -- pairs )
>r >r object-operations r> r> modify-operations [ object-operations ] 2dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ; [ [ operation-gesture ] keep ] { } map>assoc ;
: define-operation-map ( class group blurb object hook translator -- ) : define-operation-map ( class group blurb object hook translator -- )

View File

@ -139,7 +139,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget ) : <polygon-gadget> ( color points -- gadget )
dup max-dim dup max-dim
>r <polygon> <gadget> r> >>dim >r <polygon> <gadget> r> >>dim
[ (>>interior) ] keep ; swap >>interior ;
! Font rendering ! Font rendering
SYMBOL: font-renderer SYMBOL: font-renderer

View File

@ -20,11 +20,11 @@ TUPLE: browser-gadget < track pane history ;
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
dup <toolbar> f track-add dup <toolbar> f track-add
dup <help-pane> >>pane dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

View File

@ -42,8 +42,8 @@ TUPLE: deploy-gadget < pack vocab settings ;
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ; deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
: deploy-settings-theme ( gadget -- gadget ) : deploy-settings-theme ( gadget -- gadget )
{ 10 10 } >>gap { 10 10 } >>gap
1 >>fill ; 1 >>fill ;
: <deploy-settings> ( vocab -- control ) : <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map default-config [ <model> ] assoc-map
@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
advanced-settings advanced-settings
deploy-settings-theme deploy-settings-theme
namespace <mapping> over (>>model) namespace <mapping> >>model
] ]
bind ; bind ;

View File

@ -16,10 +16,10 @@ TUPLE: inspector-gadget < track object pane ;
] with-pane ; ] with-pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
dup <toolbar> f track-add dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
: inspect-object ( obj mirror keys inspector -- ) : inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ; 2nip swap >>object refresh ;

View File

@ -13,8 +13,8 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ; TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener ) : listener-output, ( listener -- listener )
<scrolling-pane> >>output <scrolling-pane> >>output
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ; dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -23,11 +23,11 @@ TUPLE: listener-gadget < track input output stack ;
output>> <pane-stream> <interactor> ; output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener ) : listener-input, ( listener -- listener )
dup <listener-input> >>input dup <listener-input> >>input
dup input>> dup input>>
{ 0 100 } <limited-scroller> { 0 100 } <limited-scroller>
"Input" <labelled-gadget> "Input" <labelled-gadget>
f track-add ; f track-add ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
@ -121,11 +121,10 @@ M: engine-word word-completion-string
TUPLE: stack-display < track ; TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget ) : <stack-display> ( workspace -- gadget )
listener>> listener>>
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
over <toolbar> f track-add over <toolbar> f track-add
swap swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ; 1 track-add ;
M: stack-display tool-scroller M: stack-display tool-scroller
@ -169,10 +168,10 @@ M: stack-display tool-scroller
f <model> swap (>>stack) ; f <model> swap (>>stack) ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
dup init-listener dup init-listener
listener-output, listener-output,
listener-input, ; listener-input, ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;

View File

@ -8,10 +8,10 @@ IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ; TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
dup <toolbar> f track-add dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r pane>> r> with-pane ; >r pane>> r> with-pane ;

View File

@ -60,15 +60,14 @@ search-field H{
swap <list> ; swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
<search-field> >>field <search-field> >>field
dup field>> f track-add dup field>> f track-add
-roll <search-list> >>list -roll <search-list> >>list
dup list>> <scroller> 1 track-add dup list>> <scroller> 1 track-add
swap
swap over field>> set-editor-string
over field>> set-editor-string dup field>> end-of-document ;
dup field>> end-of-document ;
M: live-search focusable-child* field>> ; M: live-search focusable-child* field>> ;

View File

@ -7,7 +7,7 @@ IN: ui.tools.tests
[ f ] [ f ]
[ [
<gadget> 0 <model> >>model <workspace-tabs> children>> empty? <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
] unit-test ] unit-test
[ ] [ <workspace> "w" set ] unit-test [ ] [ <workspace> "w" set ] unit-test

View File

@ -13,35 +13,30 @@ mirrors ;
IN: ui.tools IN: ui.tools
: <workspace-tabs> ( workspace -- tabs ) : <workspace-tabs> ( workspace -- tabs )
model>> model>>
"tool-switching" workspace command-map commands>> "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( workspace -- gadget ) : <workspace-book> ( workspace -- gadget )
dup
dup <stack-display>
<stack-display> <browser-gadget>
<browser-gadget> <inspector-gadget>
<inspector-gadget> <profiler-gadget>
<profiler-gadget> 4array
4array swap model>> <book> ;
swap model>>
<book> ;
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
{ 0 1 } workspace new-track { 0 1 } workspace new-track
0 <model> >>model
<listener-gadget> >>listener
dup <workspace-book> >>book
0 <model> >>model dup <workspace-tabs> f track-add
<listener-gadget> >>listener dup book>> 1/5 track-add
dup <workspace-book> >>book dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
dup <workspace-tabs> f track-add
dup book>> 1/5 track-add
dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [ dup sizes>> over control-value zero? [

View File

@ -25,14 +25,14 @@ TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ; M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget ) : <traceback-gadget> ( model -- gadget )
{ 0 1 } traceback-gadget new-track { 0 1 } traceback-gadget new-track
swap >>model swap >>model
dup model>> dup model>>
{ 1 0 } <track> { 1 0 } <track>
over <datastack-display> 1/2 track-add over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 track-add swap <retainstack-display> 1/2 track-add
1/3 track-add 1/3 track-add
dup model>> <callstack-display> 2/3 track-add dup model>> <callstack-display> 2/3 track-add

View File

@ -26,7 +26,7 @@ GENERIC: tool-scroller ( tool -- scroller )
M: gadget tool-scroller drop f ; M: gadget tool-scroller drop f ;
: find-tool ( class workspace -- index tool ) : find-tool ( class workspace -- index tool )
book>> children>> [ class eq? ] with find ; book>> children>> [ class eq? ] with find ;
: show-tool ( class workspace -- tool ) : show-tool ( class workspace -- tool )
[ find-tool swap ] keep book>> model>> [ find-tool swap ] keep book>> model>>
@ -55,15 +55,15 @@ M: gadget tool-scroller drop f ;
article-title open-window ; article-title open-window ;
: hide-popup ( workspace -- ) : hide-popup ( workspace -- )
dup popup>> track-remove dup popup>> track-remove
f >>popup f >>popup
request-focus ; request-focus ;
: show-popup ( gadget workspace -- ) : show-popup ( gadget workspace -- )
dup hide-popup dup hide-popup
over >>popup over >>popup
over f track-add drop over f track-add drop
request-focus ; request-focus ;
: show-titled-popup ( workspace gadget title -- ) : show-titled-popup ( workspace gadget title -- )
[ find-workspace hide-popup ] <closable-gadget> [ find-workspace hide-popup ] <closable-gadget>

View File

@ -51,12 +51,12 @@ SYMBOL: stop-after-last-window?
T{ gain-focus } swap each-gesture ; T{ gain-focus } swap each-gesture ;
: focus-world ( world -- ) : focus-world ( world -- )
t over (>>focused?) t >>focused?
dup raised-window dup raised-window
focus-path f focus-gestures ; focus-path f focus-gestures ;
: unfocus-world ( world -- ) : unfocus-world ( world -- )
f over (>>focused?) f >>focused?
focus-path f swap focus-gestures ; focus-path f swap focus-gestures ;
M: world graft* M: world graft*
@ -93,13 +93,8 @@ SYMBOL: ui-hook
dup graft-state>> { dup graft-state>> {
{ { f f } [ ] } { { f f } [ ] }
{ { f t } [ ] } { { f t } [ ] }
{ { t t } [ { { t t } [ { f f } >>graft-state ] }
{ f f } over (>>graft-state) { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
] }
{ { t f } [
dup unqueue-graft
{ f f } over (>>graft-state)
] }
} case graft-later ; } case graft-later ;
: restore-gadget ( gadget -- ) : restore-gadget ( gadget -- )
@ -172,7 +167,7 @@ SYMBOL: ui-thread
"UI update" spawn drop ; "UI update" spawn drop ;
: open-world-window ( world -- ) : open-world-window ( world -- )
dup pref-dim over (>>dim) dup relayout graft ; dup pref-dim >>dim dup relayout graft ;
: open-window ( gadget title -- ) : open-window ( gadget title -- )
f <world> open-world-window ; f <world> open-world-window ;

View File

@ -21,8 +21,8 @@ C: <x11-handle> x11-handle
M: world expose-event nip relayout ; M: world expose-event nip relayout ;
M: world configure-event M: world configure-event
over configured-loc over (>>window-loc) over configured-loc >>window-loc
swap configured-dim over (>>dim) swap configured-dim >>dim
! In case dimensions didn't change ! In case dimensions didn't change
relayout-1 ; relayout-1 ;