] do-enabled ;
: 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 -- )
>r >r world get font-sprites r> r> (draw-string) ;
$nl
"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
$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>
{ $values { "incremental" "a new instance of " { $link incremental } } }
>r <scroller> r> <labelled-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> ;
: <close-box> ( quot -- button/f )
! Copyright (C) 2005, 2007 Slava Pestov.
! 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
models namespaces opengl sequences math.vectors
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- )
- dup world-glass [ unparent ] when*
- f swap set-world-glass ;
+ dup glass>> [ unparent ] when*
+ f swap (>>glass) ;
: show-glass ( gadget world -- )
over hand-clicked set-global
[ hide-glass ] keep
[ swap add-gadget drop ] 2keep
- set-world-glass ;
+ (>>glass) ;
: show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ;
}
"Packs have the following slots:"
{ $list
- { { $link pack-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" }
- { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
+ { { $snippet "align" } " a rational number between 0 and 1, the alignment of gadgets along the axis 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" }
+ { { $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 } "." } ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
-{ align initial: 0 }
-{ fill initial: 0 }
-{ gap initial: { 0 0 } } ;
+ { align initial: 0 }
+ { fill initial: 0 }
+ { gap initial: { 0 0 } } ;
: 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 )
2dup packed-dim-2 swap orient ;
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
: 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 )
- 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 )
{ 0 0 } swap
: <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> ;
[ dim-sum ] keep length 1 [-] rot n*v v+ ;
: 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 ;
M: pack pref-dim*
: pane-clear ( pane -- )
clear-selection
- [ pane-output clear-incremental ]
- [ pane-current clear-gadget ]
+ [ output>> clear-incremental ]
+ [ current>> clear-gadget ]
bi ;
: new-pane ( class -- pane )
M: pane draw-gadget*
dup gadget-selection? [
- dup pane-selection-color set-color
+ dup selection-color>> set-color
origin get over rect-loc v- swap selected-children
[ draw-selection ] with each
] [
] if ;
: scroll-pane ( pane -- )
- dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
+ dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
TUPLE: pane-stream pane ;
[ drop ]
} cond ;
-: smash-pane ( pane -- gadget ) pane-output smash-line ;
+: smash-pane ( pane -- gadget ) output>> smash-line ;
: pane-nl ( pane -- pane )
- dup pane-current dup unparent smash-line
- over pane-output add-incremental
+ dup current>> dup unparent smash-line
+ over output>> add-incremental
prepare-line ;
: pane-write ( pane seq -- )
[ pane-nl ]
- [ over pane-current stream-write ]
+ [ over current>> stream-write ]
interleave drop ;
: pane-format ( style pane seq -- )
[ pane-nl ]
- [ 2over pane-current stream-format ]
+ [ 2over current>> stream-format ]
interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- )
output-stream get print-gadget ;
: ?nl ( stream -- )
- dup pane-stream-pane pane-current children>> empty?
+ dup pane>> current>> children>> empty?
[ dup stream-nl ] unless drop ;
: with-pane ( pane quot -- )
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
-: <scrolling-pane> ( -- pane )
- <pane> t over set-pane-scrolls? ;
+: <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ;
TUPLE: pane-control < pane quot ;
swap >>model ;
: 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
[ pane-nl drop ] do-pane-stream ;
M: pane-stream stream-write1
- [ pane-current stream-write1 ] do-pane-stream ;
+ [ current>> stream-write1 ] do-pane-stream ;
M: pane-stream stream-write
[ swap string-lines pane-write ] do-pane-stream ;
M: pane-stream stream-write-table
>r
- swap [ [ pane-stream-pane smash-pane ] map ] map
+ swap [ [ pane>> smash-pane ] map ] map
styled-grid
r> print-gadget ;
: move-caret ( pane -- pane )
dup hand-rel
over sloppy-pick-up
- over set-pane-caret
+ over (>>caret)
dup relayout-1 ;
-: begin-selection ( pane -- )
- move-caret f swap set-pane-mark ;
+: begin-selection ( pane -- ) move-caret f swap (>>mark) ;
: extend-selection ( pane -- )
hand-moved? [
caret>mark
] when
] if
- dup dup pane-caret gadget-at-path scroll>gadget
+ dup dup caret>> gadget-at-path scroll>gadget
] when drop ;
: end-selection ( pane -- )
] if ;
: select-to-caret ( pane -- )
- dup pane-mark [ caret>mark ] unless
+ dup mark>> [ caret>mark ] unless
move-caret
dup request-focus
com-copy-selection ;
: <paragraph> ( margin -- gadget )
paragraph new-gadget
{ 1 0 } over (>>orientation)
- [ set-paragraph-margin ] keep ;
+ [ (>>margin) ] keep ;
SYMBOL: x SYMBOL: max-x
: wrap-dim ( -- dim ) max-x get max-y get 2array ;
: init-wrap ( paragraph -- )
- paragraph-margin margin set
+ margin>> margin set
{ x max-x y max-y line-height } zero-vars ;
: do-wrap ( paragraph quot -- dim )
$nl
"Presentations have two slots:"
{ $list
- { { $link presentation-object } " - the object being presented." }
- { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
+ { { $snippet "object" } " - the object being presented." }
+ { { $snippet "hook" } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
} } ;
HELP: invoke-presentation
{ $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
HELP: invoke-primary
{ $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
{ $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>
{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
HELP: show-mouse-help
{ $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"
"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
- over dup presentation-hook call
- >r presentation-object r> invoke-command ;
+ over dup hook>> call
+ >r object>> r> invoke-command ;
: invoke-primary ( presentation -- )
- dup presentation-object primary-operation
+ dup object>> primary-operation
invoke-presentation ;
: invoke-secondary ( presentation -- )
- dup presentation-object secondary-operation
+ dup object>> secondary-operation
invoke-presentation ;
: show-mouse-help ( presentation -- )
- dup presentation-object over show-summary button-update ;
+ dup object>> over show-summary button-update ;
: <presentation> ( label object -- button )
swap [ invoke-primary ] presentation new-button
call-next-method ;
: <operations-menu> ( presentation -- menu )
- dup dup presentation-hook curry
- swap presentation-object
+ dup dup hook>> curry
+ swap object>>
dup object-operations <commands-menu> ;
: operations-menu ( presentation -- )
: do-mouse-scroll ( scroller -- )
scroll-direction get-global first2
- pick scroller-y slide-by-line
- swap scroller-x slide-by-line ;
+ pick y>> slide-by-line
+ swap x>> slide-by-line ;
scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
: scroll ( value scroller -- )
[
- dup scroller-viewport rect-dim { 0 0 }
- rot scroller-viewport viewport-dim 4array flip
+ dup viewport>> rect-dim { 0 0 }
+ rot viewport>> viewport-dim 4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
scroller-value vneg offset-rect
viewport-gap offset-rect
] 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+
] keep dup scroller-value rot v+ swap scroll ;
: find-scroller* ( gadget -- scroller )
dup find-scroller dup [
- 2dup scroller-viewport gadget-child
+ 2dup viewport>> gadget-child
swap child? [ nip ] [ 2drop f ] if
] [
2drop f
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
- [ set-scroller-follows ] keep
+ [ (>>follows) ] keep
relayout
] [
3drop
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
- [ set-scroller-follows ] keep
+ [ (>>follows) ] keep
relayout
] [
2drop
] if ;
: (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 -- )
find-scroller [
- t over set-scroller-follows relayout-1
+ t over (>>follows) relayout-1
] when* ;
: scroll>top ( gadget -- )
M: scroller layout*
dup call-next-method
- dup scroller-follows
+ dup follows>>
[ update-scroller ] 2keep
- swap set-scroller-follows ;
+ swap (>>follows) ;
M: scroller focusable-child*
- scroller-viewport ;
+ viewport>> ;
M: scroller model-changed
- nip f swap set-scroller-follows ;
+ nip f swap (>>follows) ;
TUPLE: limited-scroller < scroller fixed-dim ;
HELP: slide-by-line
{ $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>
{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
over elevator-length * min-thumb-dim max
- over slider-elevator rect-dim
+ over elevator>> rect-dim
rot orientation>> v. min ;
: slider-scale ( slider -- n )
: slider>screen ( 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 ;
: begin-drag ( thumb -- )
- find-slider dup slider-value swap set-slider-saved ;
+ find-slider dup slider-value swap (>>saved) ;
: do-drag ( thumb -- )
find-slider drag-loc over orientation>> v.
- over screen>slider swap [ slider-saved + ] keep
+ over screen>slider swap [ saved>> + ] keep
model>> set-range-value ;
thumb H{
swap slider-value - sgn ;
: elevator-hold ( elevator -- )
- dup elevator-direction swap find-slider slide-by-page ;
+ dup direction>> swap find-slider slide-by-page ;
: elevator-click ( elevator -- )
- dup compute-direction over set-elevator-direction
+ dup compute-direction over (>>direction)
elevator-hold ;
elevator H{
lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb )
- over orientation>> n*v swap slider-thumb ;
+ over orientation>> n*v swap thumb>> ;
: thumb-loc ( slider -- loc )
dup slider-value swap slider>screen ;
M: elevator layout*
find-slider layout-thumb ;
-: slide-by-line ( amount slider -- )
- [ slider-line * ] keep slide-by ;
+: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- )
- dup slot-editor-ref get-ref unparse-use
- swap slot-editor-text set-editor-string ;
+ dup ref>> get-ref unparse-use
+ swap text>> set-editor-string ;
\ revert H{
{ +description+ "Revert any uncomitted changes." }
drop T{ update-slot } swap send-gesture drop ;
: slot-editor-value ( slot-editor -- object )
- slot-editor-text control-value parse-fresh ;
+ text>> control-value parse-fresh ;
: commit ( slot-editor -- )
- dup slot-editor-text control-value parse-fresh first
- over slot-editor-ref set-ref
- dup slot-editor-ref finish-editing ;
+ dup text>> control-value parse-fresh first
+ over ref>> set-ref
+ dup ref>> finish-editing ;
\ commit H{
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command
: com-eval ( slot-editor -- )
- [ slot-editor-text editor-string eval ] keep
- [ slot-editor-ref set-ref ] keep
- dup slot-editor-ref finish-editing ;
+ [ text>> editor-string eval ] keep
+ [ ref>> set-ref ] keep
+ dup ref>> finish-editing ;
\ com-eval H{
{ +listener+ t }
} define-command
: delete ( slot-editor -- )
- dup slot-editor-ref delete-ref
+ dup ref>> delete-ref
T{ update-object } swap send-gesture drop ;
\ delete H{
HELP: set-title
{ $values { "string" string } { "world" 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
{ $values { "handle" "a backend-specific handle" } }
M: world request-focus-on ( child gadget -- )
2dup eq?
- [ 2drop ] [ dup world-focused? (request-focus) ] if ;
+ [ 2drop ] [ dup focused?>> (request-focus) ] if ;
: <world> ( gadget title status -- world )
{ 0 1 } world new-track
M: world layout*
dup call-next-method
- dup world-glass [
+ dup glass>> [
>r dup rect-dim r> (>>dim)
] when* drop ;
M: world children-on nip children>> ;
: (draw-world) ( world -- )
- dup world-handle [
+ dup handle>> [
[ dup init-gl ] keep draw-gadget
] with-gl-context ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
#! On Windows, the latter case results in GL errors.
- dup world-active?
- over world-handle
+ dup active?>>
+ over handle>>
rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error error world ;
(draw-world)
] [
over <world-error> ui-error
- f swap set-world-active?
+ f swap (>>active?)
] recover
] with-variable
] [
dup <toolbar> f track-add ;
: resize-workspace ( workspace -- )
- dup track-sizes over control-value zero? [
+ dup sizes>> over control-value zero? [
1/5 1 pick set-nth
4/5 2 rot set-nth
] [
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:"
{ $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 }
"The following words must also be implemented:"
{ $subsection set-title }
T{ gain-focus } swap each-gesture ;
: focus-world ( world -- )
- t over set-world-focused?
+ t over (>>focused?)
dup raised-window
focus-path f focus-gestures ;
: unfocus-world ( world -- )
- f over set-world-focused?
+ f over (>>focused?)
focus-path f swap focus-gestures ;
M: world graft*
dup (open-window)
- dup world-title over set-title
+ dup title>> over set-title
request-focus ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
- dup world-fonts clear-assoc
+ dup fonts>> clear-assoc
dup unfocus-world
- f swap set-world-handle ;
+ f swap (>>handle) ;
M: world ungraft*
dup free-fonts
dup hand-clicked close-global
dup hand-gadget close-global
- dup world-handle (close-window)
+ dup handle>> (close-window)
reset-world ;
: find-window ( quot -- world )
: key-down-event>gesture ( event world -- string gesture )
dupd
- world-handle x11-handle-xic lookup-string
+ handle>> x11-handle-xic lookup-string
>r swap event-modifiers r> key-code <key-down> ;
M: world key-down-event
M: world focus-in-event
nip
- dup world-handle x11-handle-xic XSetICFocus focus-world ;
+ dup handle>> x11-handle-xic XSetICFocus focus-world ;
M: world focus-out-event
nip
- dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
+ dup handle>> x11-handle-xic XUnsetICFocus unfocus-world ;
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 ;
: supported-type? ( atom -- ? )
dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle>
2dup x11-handle-window register-window
- swap set-world-handle ;
+ swap (>>handle) ;
: wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [
: x-clipboard@ ( gadget clipboard -- prop win )
x-clipboard-atom swap
- find-world world-handle x11-handle-window ;
+ find-world handle>> x11-handle-window ;
M: x-clipboard copy-clipboard
[ x-clipboard@ own-selection ] keep
set-x-clipboard-contents ;
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 ;
: init-clipboard ( -- )
r> utf8 encode dup length XChangeProperty drop ;
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 ;
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
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
over set-XClientMessageEvent-data0
M: x11-ui-backend (open-window) ( world -- )
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 -- )
- world-handle [
+ handle>> [
dpy get swap x11-handle-window XRaiseWindow drop
] when* ;
projects / factor.git / commitdiff