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

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

db4
Slava Pestov 2008-08-31 02:12:21 -05:00
parent 01e1092c8d df85ac4b5d
commit b12fe49247
20 changed files with 111 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/ui/freetype/freetype.factor
View File

@ -203,7 +203,7 @@ M: freetype-renderer string-height ( open-font string -- h )
] 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) ;

2
basis/ui/gadgets/incremental/incremental-docs.factor
View File

@ -8,7 +8,7 @@ $nl
$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 } } }

2
basis/ui/gadgets/labelled/labelled.factor
View File

@ -22,7 +22,7 @@ M: labelled-gadget focusable-child* content>> ;
>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 )

8
basis/ui/gadgets/menus/menus.factor
View File

@ -1,6 +1,6 @@
! 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
@ -20,14 +20,14 @@ TUPLE: menu-glass < gadget ;
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 ;

6
basis/ui/gadgets/packs/packs-docs.factor
View File

@ -23,9 +23,9 @@ HELP: pack
}
"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 } "." } ;

16
basis/ui/gadgets/packs/packs.factor
View File

@ -5,12 +5,12 @@ math.vectors namespaces math.order accessors math.geometry.rect ;
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 ;
@ -19,10 +19,10 @@ TUPLE: pack < gadget
{ 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
@ -40,7 +40,7 @@ TUPLE: pack < gadget
: <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> ;
@ -48,7 +48,7 @@ TUPLE: pack < gadget
[ 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*

38
basis/ui/gadgets/panes/panes.factor
View File

@ -37,8 +37,8 @@ M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
: pane-clear ( pane -- )
clear-selection
[ pane-output clear-incremental ]
[ pane-current clear-gadget ]
[ output>> clear-incremental ]
[ current>> clear-gadget ]
bi ;
: new-pane ( class -- pane )
@ -68,7 +68,7 @@ M: node draw-selection ( loc node -- )
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
] [
@ -76,7 +76,7 @@ M: pane draw-gadget*
] if ;
: scroll-pane ( pane -- )
dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
TUPLE: pane-stream pane ;
@ -89,21 +89,21 @@ C: <pane-stream> pane-stream
[ 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 -- )
@ -121,7 +121,7 @@ M: style-stream write-gadget
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 -- )
@ -132,8 +132,7 @@ M: style-stream write-gadget
: 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 ;
@ -146,13 +145,13 @@ M: pane-control model-changed ( model pane-control -- )
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 ;
@ -277,7 +276,7 @@ M: pane-stream make-cell-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 ;
@ -353,11 +352,10 @@ M: f sloppy-pick-up*
: 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? [
@ -371,7 +369,7 @@ M: f sloppy-pick-up*
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 -- )
@ -383,7 +381,7 @@ M: f sloppy-pick-up*
] if ;
: select-to-caret ( pane -- )
dup pane-mark [ caret>mark ] unless
dup mark>> [ caret>mark ] unless
move-caret
dup request-focus
com-copy-selection ;

4
basis/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -18,7 +18,7 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget )
paragraph new-gadget
{ 1 0 } over (>>orientation)
[ set-paragraph-margin ] keep ;
[ (>>margin) ] keep ;
SYMBOL: x SYMBOL: max-x
@ -56,7 +56,7 @@ SYMBOL: margin
: 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 )

12
basis/ui/gadgets/presentations/presentations-docs.factor
View File

@ -10,23 +10,23 @@ $nl
$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 } } }
@ -41,7 +41,7 @@ HELP: <presentation>
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" } ")."

14
basis/ui/gadgets/presentations/presentations.factor
View File

@ -11,19 +11,19 @@ IN: ui.gadgets.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
@ -36,8 +36,8 @@ M: presentation ungraft*
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 -- )

30
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -22,8 +22,8 @@ TUPLE: scroller < frame viewport x y follows ;
: 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 ] }
@ -48,8 +48,8 @@ scroller H{
: 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 ;
@ -61,9 +61,9 @@ scroller H{
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 ;
@ -72,7 +72,7 @@ scroller H{
: 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
@ -81,7 +81,7 @@ scroller H{
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
[ set-scroller-follows ] keep
[ (>>follows) ] keep
relayout
] [
3drop
@ -94,18 +94,18 @@ scroller H{
: 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 -- )
@ -123,15 +123,15 @@ M: f update-scroller drop dup scroller-value swap scroll ;
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 ;

2
basis/ui/gadgets/sliders/sliders-docs.factor
View File

@ -30,7 +30,7 @@ HELP: slide-by-page
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 } } }

17
basis/ui/gadgets/sliders/sliders.factor
View File

@ -28,7 +28,7 @@ TUPLE: slider < frame elevator thumb saved line ;
: 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 )
@ -41,16 +41,16 @@ TUPLE: slider < frame elevator thumb saved line ;
: 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{
@ -80,10 +80,10 @@ 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{
@ -97,7 +97,7 @@ 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 ;
@ -118,8 +118,7 @@ elevator H{
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>

20
basis/ui/gadgets/slots/slots.factor
View File

@ -16,8 +16,8 @@ TUPLE: edit-slot ;
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." }
@ -32,21 +32,21 @@ M: value-ref finish-editing
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 }
@ -54,7 +54,7 @@ M: value-ref finish-editing
} define-command
: delete ( slot-editor -- )
dup slot-editor-ref delete-ref
dup ref>> delete-ref
T{ update-object } swap send-gesture drop ;
\ delete H{

2
basis/ui/gadgets/worlds/worlds-docs.factor
View File

@ -11,7 +11,7 @@ HELP: hand-world
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" } }

12
basis/ui/gadgets/worlds/worlds.factor
View File

@ -30,7 +30,7 @@ M: f world-status ;
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
@ -45,7 +45,7 @@ M: world request-focus-on ( child gadget -- )
M: world layout*
dup call-next-method
dup world-glass [
dup glass>> [
>r dup rect-dim r> (>>dim)
] when* drop ;
@ -54,15 +54,15 @@ M: world focusable-child* gadget-child ;
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 ;
@ -83,7 +83,7 @@ SYMBOL: ui-error-hook
(draw-world)
] [
over <world-error> ui-error
f swap set-world-active?
f swap (>>active?)
] recover
] with-variable
] [

2
basis/ui/tools/tools.factor
View File

@ -44,7 +44,7 @@ IN: ui.tools
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
] [

2
basis/ui/ui-docs.factor
View File

@ -172,7 +172,7 @@ $nl
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 }

12
basis/ui/ui.factor
View File

@ -51,31 +51,31 @@ SYMBOL: stop-after-last-window?
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 )

22
basis/ui/x11/x11.factor
View File

@ -69,7 +69,7 @@ M: world configure-event
: 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
@ -116,14 +116,14 @@ M: world motion-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 -- ? )
@ -173,7 +173,7 @@ M: world client-event
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 > [
@ -189,14 +189,14 @@ M: x11-ui-backend do-events
: 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 ( -- )
@ -212,11 +212,11 @@ M: x-clipboard paste-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
@ -230,10 +230,10 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
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* ;