Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-08-31 02:12:21 -05:00
commit b12fe49247
20 changed files with 111 additions and 114 deletions

View File

@ -203,7 +203,7 @@ M: freetype-renderer string-height ( open-font string -- h )
] do-enabled ; ] do-enabled ;
: font-sprites ( font world -- open-font sprites ) : font-sprites ( font world -- open-font sprites )
world-fonts [ open-font H{ } clone 2array ] cache first2 ; fonts>> [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- ) M: freetype-renderer draw-string ( font string loc -- )
>r >r world get font-sprites r> r> (draw-string) ; >r >r world get font-sprites r> r> (draw-string) ;

View File

@ -8,7 +8,7 @@ $nl
$nl $nl
"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words." "Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
$nl $nl
"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ; "Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $snippet "align" } ", " { $snippet "fill" } ", and " { $snippet "gap" } "." } ;
HELP: <incremental> HELP: <incremental>
{ $values { "incremental" "a new instance of " { $link incremental } } } { $values { "incremental" "a new instance of " { $link incremental } } }

View File

@ -22,7 +22,7 @@ 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 set-pane-scrolls? r> >r >r <pane-control> r> over (>>scrolls?) r>
<labelled-scroller> ; <labelled-scroller> ;
: <close-box> ( quot -- button/f ) : <close-box> ( quot -- button/f )

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons USING: accessors arrays ui.commands ui.gadgets ui.gadgets.buttons
ui.gadgets.worlds ui.gestures generic hashtables kernel math ui.gadgets.worlds ui.gestures generic hashtables kernel math
models namespaces opengl sequences math.vectors models namespaces opengl sequences math.vectors
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
@ -20,14 +20,14 @@ TUPLE: menu-glass < gadget ;
M: menu-glass layout* gadget-child prefer ; M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- ) : hide-glass ( world -- )
dup world-glass [ unparent ] when* dup glass>> [ unparent ] when*
f swap set-world-glass ; f swap (>>glass) ;
: show-glass ( gadget world -- ) : show-glass ( gadget world -- )
over hand-clicked set-global over hand-clicked set-global
[ hide-glass ] keep [ hide-glass ] keep
[ swap add-gadget drop ] 2keep [ swap add-gadget drop ] 2keep
set-world-glass ; (>>glass) ;
: show-menu ( gadget owner -- ) : show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ; find-world [ <menu-glass> ] keep show-glass ;

View File

@ -23,9 +23,9 @@ HELP: pack
} }
"Packs have the following slots:" "Packs have the following slots:"
{ $list { $list
{ { $link pack-align } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" } { { $snippet "align" } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" }
{ { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" } { { $snippet "fill" } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
{ { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" } { { $snippet "gap" } " a pair of integers, the horizontal and vertical gap between children" }
} }
"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ; "Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;

View File

@ -5,12 +5,12 @@ 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 pack-fill v*n v+ ] with map ; [ over rect-dim over v- rot fill>> v*n v+ ] with map ;
: packed-dims ( gadget sizes -- seq ) : packed-dims ( gadget sizes -- seq )
2dup packed-dim-2 swap orient ; 2dup packed-dim-2 swap orient ;
@ -19,10 +19,10 @@ TUPLE: pack < gadget
{ 0 0 } [ v+ over v+ ] accumulate 2nip ; { 0 0 } [ v+ over v+ ] accumulate 2nip ;
: aligned-locs ( gadget sizes -- seq ) : aligned-locs ( gadget sizes -- seq )
[ >r dup pack-align swap rect-dim r> v- n*v ] with map ; [ >r dup align>> swap rect-dim r> v- n*v ] with map ;
: packed-locs ( gadget sizes -- seq ) : packed-locs ( gadget sizes -- seq )
over pack-gap over gap-locs >r dupd aligned-locs r> orient ; over gap>> over gap-locs >r dupd aligned-locs r> orient ;
: round-dims ( seq -- newseq ) : round-dims ( seq -- newseq )
{ 0 0 } swap { 0 0 } swap
@ -40,7 +40,7 @@ TUPLE: pack < gadget
: <pile> ( -- pack ) { 0 1 } <pack> ; : <pile> ( -- pack ) { 0 1 } <pack> ;
: <filled-pile> ( -- pack ) <pile> 1 over set-pack-fill ; : <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ;
: <shelf> ( -- pack ) { 1 0 } <pack> ; : <shelf> ( -- pack ) { 1 0 } <pack> ;
@ -48,7 +48,7 @@ TUPLE: pack < gadget
[ dim-sum ] keep length 1 [-] rot n*v v+ ; [ dim-sum ] keep length 1 [-] rot n*v v+ ;
: pack-pref-dim ( gadget sizes -- dim ) : pack-pref-dim ( gadget sizes -- dim )
over pack-gap over gap-dims >r max-dim r> over gap>> over gap-dims >r max-dim r>
rot orientation>> set-axis ; rot orientation>> set-axis ;
M: pack pref-dim* M: pack pref-dim*

View File

@ -37,8 +37,8 @@ M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
: pane-clear ( pane -- ) : pane-clear ( pane -- )
clear-selection clear-selection
[ pane-output clear-incremental ] [ output>> clear-incremental ]
[ pane-current clear-gadget ] [ current>> clear-gadget ]
bi ; bi ;
: new-pane ( class -- pane ) : new-pane ( class -- pane )
@ -68,7 +68,7 @@ M: node draw-selection ( loc node -- )
M: pane draw-gadget* M: pane draw-gadget*
dup gadget-selection? [ dup gadget-selection? [
dup pane-selection-color set-color dup selection-color>> set-color
origin get over rect-loc v- swap selected-children origin get over rect-loc v- swap selected-children
[ draw-selection ] with each [ draw-selection ] with each
] [ ] [
@ -76,7 +76,7 @@ M: pane draw-gadget*
] if ; ] if ;
: scroll-pane ( pane -- ) : scroll-pane ( pane -- )
dup pane-scrolls? [ scroll>bottom ] [ drop ] if ; dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
TUPLE: pane-stream pane ; TUPLE: pane-stream pane ;
@ -89,21 +89,21 @@ C: <pane-stream> pane-stream
[ drop ] [ drop ]
} cond ; } cond ;
: smash-pane ( pane -- gadget ) pane-output smash-line ; : smash-pane ( pane -- gadget ) output>> smash-line ;
: pane-nl ( pane -- pane ) : pane-nl ( pane -- pane )
dup pane-current dup unparent smash-line dup current>> dup unparent smash-line
over pane-output add-incremental over output>> add-incremental
prepare-line ; prepare-line ;
: pane-write ( pane seq -- ) : pane-write ( pane seq -- )
[ pane-nl ] [ pane-nl ]
[ over pane-current stream-write ] [ over current>> stream-write ]
interleave drop ; interleave drop ;
: pane-format ( style pane seq -- ) : pane-format ( style pane seq -- )
[ pane-nl ] [ pane-nl ]
[ 2over pane-current stream-format ] [ 2over current>> stream-format ]
interleave 2drop ; interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
@ -121,7 +121,7 @@ M: style-stream write-gadget
output-stream get print-gadget ; output-stream get print-gadget ;
: ?nl ( stream -- ) : ?nl ( stream -- )
dup pane-stream-pane pane-current children>> empty? dup pane>> current>> children>> empty?
[ dup stream-nl ] unless drop ; [ dup stream-nl ] unless drop ;
: with-pane ( pane quot -- ) : with-pane ( pane quot -- )
@ -132,8 +132,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 ) : <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ;
<pane> t over set-pane-scrolls? ;
TUPLE: pane-control < pane quot ; TUPLE: pane-control < pane quot ;
@ -146,13 +145,13 @@ M: pane-control model-changed ( model pane-control -- )
swap >>model ; swap >>model ;
: do-pane-stream ( pane-stream quot -- ) : do-pane-stream ( pane-stream quot -- )
>r pane-stream-pane r> keep scroll-pane ; inline >r pane>> r> keep scroll-pane ; inline
M: pane-stream stream-nl M: pane-stream stream-nl
[ pane-nl drop ] do-pane-stream ; [ pane-nl drop ] do-pane-stream ;
M: pane-stream stream-write1 M: pane-stream stream-write1
[ pane-current stream-write1 ] do-pane-stream ; [ current>> stream-write1 ] do-pane-stream ;
M: pane-stream stream-write M: pane-stream stream-write
[ swap string-lines pane-write ] do-pane-stream ; [ swap string-lines pane-write ] do-pane-stream ;
@ -277,7 +276,7 @@ M: pane-stream make-cell-stream
M: pane-stream stream-write-table M: pane-stream stream-write-table
>r >r
swap [ [ pane-stream-pane smash-pane ] map ] map swap [ [ pane>> smash-pane ] map ] map
styled-grid styled-grid
r> print-gadget ; r> print-gadget ;
@ -353,11 +352,10 @@ M: f sloppy-pick-up*
: move-caret ( pane -- pane ) : move-caret ( pane -- pane )
dup hand-rel dup hand-rel
over sloppy-pick-up over sloppy-pick-up
over set-pane-caret over (>>caret)
dup relayout-1 ; dup relayout-1 ;
: begin-selection ( pane -- ) : begin-selection ( pane -- ) move-caret f swap (>>mark) ;
move-caret f swap set-pane-mark ;
: extend-selection ( pane -- ) : extend-selection ( pane -- )
hand-moved? [ hand-moved? [
@ -371,7 +369,7 @@ M: f sloppy-pick-up*
caret>mark caret>mark
] when ] when
] if ] if
dup dup pane-caret gadget-at-path scroll>gadget dup dup caret>> gadget-at-path scroll>gadget
] when drop ; ] when drop ;
: end-selection ( pane -- ) : end-selection ( pane -- )
@ -383,7 +381,7 @@ M: f sloppy-pick-up*
] if ; ] if ;
: select-to-caret ( pane -- ) : select-to-caret ( pane -- )
dup pane-mark [ caret>mark ] unless dup mark>> [ caret>mark ] unless
move-caret move-caret
dup request-focus dup request-focus
com-copy-selection ; com-copy-selection ;

View File

@ -18,7 +18,7 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph new-gadget paragraph new-gadget
{ 1 0 } over (>>orientation) { 1 0 } over (>>orientation)
[ set-paragraph-margin ] keep ; [ (>>margin) ] keep ;
SYMBOL: x SYMBOL: max-x SYMBOL: x SYMBOL: max-x
@ -56,7 +56,7 @@ SYMBOL: margin
: wrap-dim ( -- dim ) max-x get max-y get 2array ; : wrap-dim ( -- dim ) max-x get max-y get 2array ;
: init-wrap ( paragraph -- ) : init-wrap ( paragraph -- )
paragraph-margin margin set margin>> margin set
{ x max-x y max-y line-height } zero-vars ; { x max-x y max-y line-height } zero-vars ;
: do-wrap ( paragraph quot -- dim ) : do-wrap ( paragraph quot -- dim )

View File

@ -10,23 +10,23 @@ $nl
$nl $nl
"Presentations have two slots:" "Presentations have two slots:"
{ $list { $list
{ { $link presentation-object } " - the object being presented." } { { $snippet "object" } " - the object being presented." }
{ { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." } { { $snippet "hook" } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
} } ; } } ;
HELP: invoke-presentation HELP: invoke-presentation
{ $values { "presentation" presentation } { "command" "a command" } } { $values { "presentation" presentation } { "command" "a command" } }
{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." } ; { $description "Calls the " { $snippet "hook" } " and then invokes the command on the " { $snippet "object" } "." } ;
{ invoke-presentation invoke-primary invoke-secondary } related-words { invoke-presentation invoke-primary invoke-secondary } related-words
HELP: invoke-primary HELP: invoke-primary
{ $values { "presentation" presentation } } { $values { "presentation" presentation } }
{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." } ; { $description "Invokes the " { $link primary-operation } " associated to the " { $snippet "object" } ". This word is executed when the presentation is clicked with the left mouse button." } ;
HELP: invoke-secondary HELP: invoke-secondary
{ $values { "presentation" presentation } } { $values { "presentation" presentation } }
{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ; { $description "Invokes the " { $link secondary-operation } " associated to the " { $snippet "object" } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ;
HELP: <presentation> HELP: <presentation>
{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } } { $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
@ -41,7 +41,7 @@ HELP: <presentation>
HELP: show-mouse-help HELP: show-mouse-help
{ $values { "presentation" presentation } } { $values { "presentation" presentation } }
{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ; { $description "Displays a " { $link summary } " of the " { $snippet "object" } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;
ARTICLE: "ui.gadgets.presentations" "Presentation gadgets" ARTICLE: "ui.gadgets.presentations" "Presentation gadgets"
"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")." "Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."

View File

@ -11,19 +11,19 @@ IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ; TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- ) : invoke-presentation ( presentation command -- )
over dup presentation-hook call over dup hook>> call
>r presentation-object r> invoke-command ; >r object>> r> invoke-command ;
: invoke-primary ( presentation -- ) : invoke-primary ( presentation -- )
dup presentation-object primary-operation dup object>> primary-operation
invoke-presentation ; invoke-presentation ;
: invoke-secondary ( presentation -- ) : invoke-secondary ( presentation -- )
dup presentation-object secondary-operation dup object>> secondary-operation
invoke-presentation ; invoke-presentation ;
: show-mouse-help ( presentation -- ) : show-mouse-help ( presentation -- )
dup presentation-object over show-summary button-update ; dup object>> over show-summary button-update ;
: <presentation> ( label object -- button ) : <presentation> ( label object -- button )
swap [ invoke-primary ] presentation new-button swap [ invoke-primary ] presentation new-button
@ -36,8 +36,8 @@ M: presentation ungraft*
call-next-method ; call-next-method ;
: <operations-menu> ( presentation -- menu ) : <operations-menu> ( presentation -- menu )
dup dup presentation-hook curry dup dup hook>> curry
swap presentation-object swap object>>
dup object-operations <commands-menu> ; dup object-operations <commands-menu> ;
: operations-menu ( presentation -- ) : operations-menu ( presentation -- )

View File

@ -22,8 +22,8 @@ TUPLE: scroller < frame viewport x y follows ;
: do-mouse-scroll ( scroller -- ) : do-mouse-scroll ( scroller -- )
scroll-direction get-global first2 scroll-direction get-global first2
pick scroller-y slide-by-line pick y>> slide-by-line
swap scroller-x slide-by-line ; swap x>> slide-by-line ;
scroller H{ scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] } { T{ mouse-scroll } [ do-mouse-scroll ] }
@ -48,8 +48,8 @@ scroller H{
: scroll ( value scroller -- ) : scroll ( value scroller -- )
[ [
dup scroller-viewport rect-dim { 0 0 } dup viewport>> rect-dim { 0 0 }
rot scroller-viewport viewport-dim 4array flip rot viewport>> viewport-dim 4array flip
] keep ] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ; 2dup control-value = [ 2drop ] [ set-control-value ] if ;
@ -61,9 +61,9 @@ scroller H{
scroller-value vneg offset-rect scroller-value vneg offset-rect
viewport-gap offset-rect viewport-gap offset-rect
] keep ] keep
[ scroller-viewport rect-min ] keep [ viewport>> rect-min ] keep
[ [
scroller-viewport 2rect-extent viewport>> 2rect-extent
>r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+ >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
] keep dup scroller-value rot v+ swap scroll ; ] keep dup scroller-value rot v+ swap scroll ;
@ -72,7 +72,7 @@ scroller H{
: find-scroller* ( gadget -- scroller ) : find-scroller* ( gadget -- scroller )
dup find-scroller dup [ dup find-scroller dup [
2dup scroller-viewport gadget-child 2dup viewport>> gadget-child
swap child? [ nip ] [ 2drop f ] if swap child? [ nip ] [ 2drop f ] if
] [ ] [
2drop f 2drop f
@ -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
[ set-scroller-follows ] keep [ (>>follows) ] keep
relayout relayout
] [ ] [
3drop 3drop
@ -94,18 +94,18 @@ scroller H{
: scroll>gadget ( gadget -- ) : scroll>gadget ( gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
[ set-scroller-follows ] keep [ (>>follows) ] keep
relayout relayout
] [ ] [
2drop 2drop
] if ; ] if ;
: (scroll>bottom) ( scroller -- ) : (scroll>bottom) ( scroller -- )
dup scroller-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 over set-scroller-follows relayout-1 t over (>>follows) relayout-1
] when* ; ] when* ;
: scroll>top ( gadget -- ) : scroll>top ( gadget -- )
@ -123,15 +123,15 @@ M: f update-scroller drop dup scroller-value swap scroll ;
M: scroller layout* M: scroller layout*
dup call-next-method dup call-next-method
dup scroller-follows dup follows>>
[ update-scroller ] 2keep [ update-scroller ] 2keep
swap set-scroller-follows ; swap (>>follows) ;
M: scroller focusable-child* M: scroller focusable-child*
scroller-viewport ; viewport>> ;
M: scroller model-changed M: scroller model-changed
nip f swap set-scroller-follows ; nip f swap (>>follows) ;
TUPLE: limited-scroller < scroller fixed-dim ; TUPLE: limited-scroller < scroller fixed-dim ;

View File

@ -30,7 +30,7 @@ HELP: slide-by-page
HELP: slide-by-line HELP: slide-by-line
{ $values { "amount" "an integer" } { "slider" slider } } { $values { "amount" "an integer" } { "slider" slider } }
{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." } ; { $description "Adds the amount multiplied by the " { $snippet "line" } " slot to the slider's current position." } ;
HELP: <slider> HELP: <slider>
{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } } { $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }

View File

@ -28,7 +28,7 @@ TUPLE: slider < frame elevator thumb saved line ;
: 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
over elevator-length * min-thumb-dim max over elevator-length * min-thumb-dim max
over slider-elevator rect-dim over elevator>> rect-dim
rot orientation>> v. min ; rot orientation>> v. min ;
: slider-scale ( slider -- n ) : slider-scale ( slider -- n )
@ -41,16 +41,16 @@ TUPLE: slider < frame elevator thumb saved line ;
: slider>screen ( m scale -- n ) slider-scale * ; : slider>screen ( m scale -- n ) slider-scale * ;
: screen>slider ( m scale -- n ) slider-scale / ; : screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ; M: slider model-changed nip elevator>> relayout-1 ;
TUPLE: thumb < gadget ; TUPLE: thumb < gadget ;
: begin-drag ( thumb -- ) : begin-drag ( thumb -- )
find-slider dup slider-value swap set-slider-saved ; find-slider dup slider-value swap (>>saved) ;
: do-drag ( thumb -- ) : do-drag ( thumb -- )
find-slider drag-loc over orientation>> v. find-slider drag-loc over orientation>> v.
over screen>slider swap [ slider-saved + ] keep over screen>slider swap [ saved>> + ] keep
model>> set-range-value ; model>> set-range-value ;
thumb H{ thumb H{
@ -80,10 +80,10 @@ thumb H{
swap slider-value - sgn ; swap slider-value - sgn ;
: elevator-hold ( elevator -- ) : elevator-hold ( elevator -- )
dup elevator-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 set-elevator-direction dup compute-direction over (>>direction)
elevator-hold ; elevator-hold ;
elevator H{ elevator H{
@ -97,7 +97,7 @@ elevator H{
lowered-gradient >>interior ; lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb ) : (layout-thumb) ( slider n -- n thumb )
over orientation>> n*v swap slider-thumb ; over orientation>> n*v swap thumb>> ;
: thumb-loc ( slider -- loc ) : thumb-loc ( slider -- loc )
dup slider-value swap slider>screen ; dup slider-value swap slider>screen ;
@ -118,8 +118,7 @@ elevator H{
M: elevator layout* M: elevator layout*
find-slider layout-thumb ; find-slider layout-thumb ;
: slide-by-line ( amount slider -- ) : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
[ slider-line * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- button ) : <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r> >r gray swap <polygon-gadget> r>

View File

@ -16,8 +16,8 @@ TUPLE: edit-slot ;
TUPLE: slot-editor < track ref text ; TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- ) : revert ( slot-editor -- )
dup slot-editor-ref get-ref unparse-use dup ref>> get-ref unparse-use
swap slot-editor-text set-editor-string ; swap text>> set-editor-string ;
\ revert H{ \ revert H{
{ +description+ "Revert any uncomitted changes." } { +description+ "Revert any uncomitted changes." }
@ -32,21 +32,21 @@ M: value-ref finish-editing
drop T{ update-slot } swap send-gesture drop ; drop T{ update-slot } swap send-gesture drop ;
: slot-editor-value ( slot-editor -- object ) : slot-editor-value ( slot-editor -- object )
slot-editor-text control-value parse-fresh ; text>> control-value parse-fresh ;
: commit ( slot-editor -- ) : commit ( slot-editor -- )
dup slot-editor-text control-value parse-fresh first dup text>> control-value parse-fresh first
over slot-editor-ref set-ref over ref>> set-ref
dup slot-editor-ref finish-editing ; dup ref>> finish-editing ;
\ commit H{ \ commit H{
{ +description+ "Parse the object being edited, and store the result back into the edited slot." } { +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command } define-command
: com-eval ( slot-editor -- ) : com-eval ( slot-editor -- )
[ slot-editor-text editor-string eval ] keep [ text>> editor-string eval ] keep
[ slot-editor-ref set-ref ] keep [ ref>> set-ref ] keep
dup slot-editor-ref finish-editing ; dup ref>> finish-editing ;
\ com-eval H{ \ com-eval H{
{ +listener+ t } { +listener+ t }
@ -54,7 +54,7 @@ M: value-ref finish-editing
} define-command } define-command
: delete ( slot-editor -- ) : delete ( slot-editor -- )
dup slot-editor-ref delete-ref dup ref>> delete-ref
T{ update-object } swap send-gesture drop ; T{ update-object } swap send-gesture drop ;
\ delete H{ \ delete H{

View File

@ -11,7 +11,7 @@ HELP: hand-world
HELP: set-title HELP: set-title
{ $values { "string" string } { "world" world } } { $values { "string" string } { "world" world } }
{ $description "Sets the title bar of the native window containing the world." } { $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; { $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
HELP: select-gl-context HELP: select-gl-context
{ $values { "handle" "a backend-specific handle" } } { $values { "handle" "a backend-specific handle" } }

View File

@ -30,7 +30,7 @@ M: f world-status ;
M: world request-focus-on ( child gadget -- ) M: world request-focus-on ( child gadget -- )
2dup eq? 2dup eq?
[ 2drop ] [ dup world-focused? (request-focus) ] if ; [ 2drop ] [ dup focused?>> (request-focus) ] if ;
: <world> ( gadget title status -- world ) : <world> ( gadget title status -- world )
{ 0 1 } world new-track { 0 1 } world new-track
@ -45,7 +45,7 @@ M: world request-focus-on ( child gadget -- )
M: world layout* M: world layout*
dup call-next-method dup call-next-method
dup world-glass [ dup glass>> [
>r dup rect-dim r> (>>dim) >r dup rect-dim r> (>>dim)
] when* drop ; ] when* drop ;
@ -54,15 +54,15 @@ M: world focusable-child* gadget-child ;
M: world children-on nip children>> ; M: world children-on nip children>> ;
: (draw-world) ( world -- ) : (draw-world) ( world -- )
dup world-handle [ dup handle>> [
[ dup init-gl ] keep draw-gadget [ dup init-gl ] keep draw-gadget
] with-gl-context ; ] with-gl-context ;
: draw-world? ( world -- ? ) : draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size. #! We don't draw deactivated worlds, or those with 0 size.
#! On Windows, the latter case results in GL errors. #! On Windows, the latter case results in GL errors.
dup world-active? dup active?>>
over world-handle over handle>>
rot rect-dim [ 0 > ] all? and and ; rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error error world ; TUPLE: world-error error world ;
@ -83,7 +83,7 @@ SYMBOL: ui-error-hook
(draw-world) (draw-world)
] [ ] [
over <world-error> ui-error over <world-error> ui-error
f swap set-world-active? f swap (>>active?)
] recover ] recover
] with-variable ] with-variable
] [ ] [

View File

@ -44,7 +44,7 @@ IN: ui.tools
dup <toolbar> f track-add ; dup <toolbar> f track-add ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [ dup sizes>> over control-value zero? [
1/5 1 pick set-nth 1/5 1 pick set-nth
4/5 2 rot set-nth 4/5 2 rot set-nth
] [ ] [

View File

@ -172,7 +172,7 @@ $nl
ARTICLE: "ui-backend-windows" "UI backend window management" ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:" "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
{ $subsection open-world-window } { $subsection open-world-window }
"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:" "This word should create a native window, store some kind of handle in the " { $snippet "handle" } " slot, then call two words:"
{ $subsection register-window } { $subsection register-window }
"The following words must also be implemented:" "The following words must also be implemented:"
{ $subsection set-title } { $subsection set-title }

View File

@ -51,31 +51,31 @@ 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 set-world-focused? t over (>>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 set-world-focused? f over (>>focused?)
focus-path f swap focus-gestures ; focus-path f swap focus-gestures ;
M: world graft* M: world graft*
dup (open-window) dup (open-window)
dup world-title over set-title dup title>> over set-title
request-focus ; request-focus ;
: reset-world ( world -- ) : reset-world ( world -- )
#! This is used when a window is being closed, but also #! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup. #! when restoring saved worlds on image startup.
dup world-fonts clear-assoc dup fonts>> clear-assoc
dup unfocus-world dup unfocus-world
f swap set-world-handle ; f swap (>>handle) ;
M: world ungraft* M: world ungraft*
dup free-fonts dup free-fonts
dup hand-clicked close-global dup hand-clicked close-global
dup hand-gadget close-global dup hand-gadget close-global
dup world-handle (close-window) dup handle>> (close-window)
reset-world ; reset-world ;
: find-window ( quot -- world ) : find-window ( quot -- world )

View File

@ -69,7 +69,7 @@ M: world configure-event
: key-down-event>gesture ( event world -- string gesture ) : key-down-event>gesture ( event world -- string gesture )
dupd dupd
world-handle x11-handle-xic lookup-string handle>> x11-handle-xic lookup-string
>r swap event-modifiers r> key-code <key-down> ; >r swap event-modifiers r> key-code <key-down> ;
M: world key-down-event M: world key-down-event
@ -116,14 +116,14 @@ M: world motion-event
M: world focus-in-event M: world focus-in-event
nip nip
dup world-handle x11-handle-xic XSetICFocus focus-world ; dup handle>> x11-handle-xic XSetICFocus focus-world ;
M: world focus-out-event M: world focus-out-event
nip nip
dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ; dup handle>> x11-handle-xic XUnsetICFocus unfocus-world ;
M: world selection-notify-event M: world selection-notify-event
[ world-handle x11-handle-window selection-from-event ] keep [ handle>> x11-handle-window selection-from-event ] keep
world-focus user-input ; world-focus user-input ;
: supported-type? ( atom -- ? ) : supported-type? ( atom -- ? )
@ -173,7 +173,7 @@ M: world client-event
dup window-loc>> over rect-dim glx-window dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle> over "Factor" create-xic <x11-handle>
2dup x11-handle-window register-window 2dup x11-handle-window register-window
swap set-world-handle ; swap (>>handle) ;
: wait-event ( -- event ) : wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [ QueuedAfterFlush events-queued 0 > [
@ -189,14 +189,14 @@ M: x11-ui-backend do-events
: x-clipboard@ ( gadget clipboard -- prop win ) : x-clipboard@ ( gadget clipboard -- prop win )
x-clipboard-atom swap x-clipboard-atom swap
find-world world-handle x11-handle-window ; find-world handle>> x11-handle-window ;
M: x-clipboard copy-clipboard M: x-clipboard copy-clipboard
[ x-clipboard@ own-selection ] keep [ x-clipboard@ own-selection ] keep
set-x-clipboard-contents ; set-x-clipboard-contents ;
M: x-clipboard paste-clipboard M: x-clipboard paste-clipboard
>r find-world world-handle x11-handle-window >r find-world handle>> x11-handle-window
r> x-clipboard-atom convert-selection ; r> x-clipboard-atom convert-selection ;
: init-clipboard ( -- ) : init-clipboard ( -- )
@ -212,11 +212,11 @@ M: x-clipboard paste-clipboard
r> utf8 encode dup length XChangeProperty drop ; r> utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- ) M: x11-ui-backend set-title ( string world -- )
world-handle x11-handle-window swap dpy get -rot handle>> x11-handle-window swap dpy get -rot
3dup set-title-old set-title-new ; 3dup set-title-old set-title-new ;
M: x11-ui-backend set-fullscreen* ( ? world -- ) M: x11-ui-backend set-fullscreen* ( ? world -- )
world-handle x11-handle-window "XClientMessageEvent" <c-object> handle>> x11-handle-window "XClientMessageEvent" <c-object>
tuck set-XClientMessageEvent-window tuck set-XClientMessageEvent-window
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
over set-XClientMessageEvent-data0 over set-XClientMessageEvent-data0
@ -230,10 +230,10 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
M: x11-ui-backend (open-window) ( world -- ) M: x11-ui-backend (open-window) ( world -- )
dup gadget-window dup gadget-window
world-handle x11-handle-window dup set-closable map-window ; handle>> x11-handle-window dup set-closable map-window ;
M: x11-ui-backend raise-window* ( world -- ) M: x11-ui-backend raise-window* ( world -- )
world-handle [ handle>> [
dpy get swap x11-handle-window XRaiseWindow drop dpy get swap x11-handle-window XRaiseWindow drop
] when* ; ] when* ;