Merge branch 'master' of git://factorcode.org/git/factor
commit
b12fe49247
|
@ -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) ;
|
||||||
|
|
|
@ -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 } } }
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 } "." } ;
|
||||||
|
|
||||||
|
|
|
@ -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*
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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" } ")."
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 } } }
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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{
|
||||||
|
|
|
@ -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" } }
|
||||||
|
|
|
@ -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
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -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
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -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 }
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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* ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue