From 7535c1d256efd61b02fae0b67f08739ffd2435de Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 31 Aug 2008 01:42:30 -0500 Subject: [PATCH] Another big accessors batch update --- basis/ui/freetype/freetype.factor | 2 +- .../incremental/incremental-docs.factor | 2 +- basis/ui/gadgets/labelled/labelled.factor | 2 +- basis/ui/gadgets/menus/menus.factor | 8 ++-- basis/ui/gadgets/packs/packs-docs.factor | 6 +-- basis/ui/gadgets/packs/packs.factor | 16 ++++---- basis/ui/gadgets/panes/panes.factor | 38 +++++++++---------- basis/ui/gadgets/paragraphs/paragraphs.factor | 4 +- .../presentations/presentations-docs.factor | 12 +++--- .../presentations/presentations.factor | 14 +++---- basis/ui/gadgets/scrollers/scrollers.factor | 30 +++++++-------- basis/ui/gadgets/sliders/sliders-docs.factor | 2 +- basis/ui/gadgets/sliders/sliders.factor | 17 ++++----- basis/ui/gadgets/slots/slots.factor | 20 +++++----- basis/ui/gadgets/worlds/worlds-docs.factor | 2 +- basis/ui/gadgets/worlds/worlds.factor | 12 +++--- basis/ui/tools/tools.factor | 2 +- basis/ui/ui-docs.factor | 2 +- basis/ui/ui.factor | 12 +++--- basis/ui/x11/x11.factor | 22 +++++------ 20 files changed, 111 insertions(+), 114 deletions(-) diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 7042811881..7bda548a26 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -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) ; diff --git a/basis/ui/gadgets/incremental/incremental-docs.factor b/basis/ui/gadgets/incremental/incremental-docs.factor index a568875b18..28c28be3a7 100755 --- a/basis/ui/gadgets/incremental/incremental-docs.factor +++ b/basis/ui/gadgets/incremental/incremental-docs.factor @@ -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: { $values { "incremental" "a new instance of " { $link incremental } } } diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 6c7d463b0b..64020c7626 100755 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -22,7 +22,7 @@ M: labelled-gadget focusable-child* content>> ; >r r> ; : ( model quot scrolls? title -- gadget ) - >r >r r> over set-pane-scrolls? r> + >r >r r> over (>>scrolls?) r> ; : ( quot -- button/f ) diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 2d7af47396..932353e428 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -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 [ ] keep show-glass ; diff --git a/basis/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor index 32f4fe1a36..14a229067b 100755 --- a/basis/ui/gadgets/packs/packs-docs.factor +++ b/basis/ui/gadgets/packs/packs-docs.factor @@ -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 } "." } ; diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index b544b5816b..ed64c1e990 100755 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -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 : ( -- pack ) { 0 1 } ; -: ( -- pack ) 1 over set-pack-fill ; +: ( -- pack ) 1 over (>>fill) ; : ( -- pack ) { 1 0 } ; @@ -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* diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index b17c66768a..0fca412d1f 100755 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -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 [ 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 ) [ swap with-pane ] keep smash-pane ; inline -: ( -- pane ) - t over set-pane-scrolls? ; +: ( -- 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 ; diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index 1f670da92d..5e87484b2d 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs.factor @@ -18,7 +18,7 @@ TUPLE: paragraph < gadget margin ; : ( 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 ) diff --git a/basis/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor index f45eb8e79c..c651e849a2 100755 --- a/basis/ui/gadgets/presentations/presentations-docs.factor +++ b/basis/ui/gadgets/presentations/presentations-docs.factor @@ -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: { $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } } @@ -41,7 +41,7 @@ HELP: 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" } ")." diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index de8177f474..c5f078e82e 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -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 ; : ( label object -- button ) swap [ invoke-primary ] presentation new-button @@ -36,8 +36,8 @@ M: presentation ungraft* call-next-method ; : ( presentation -- menu ) - dup dup presentation-hook curry - swap presentation-object + dup dup hook>> curry + swap object>> dup object-operations ; : operations-menu ( presentation -- ) diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 516f555a70..70e56fc31c 100755 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -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 ; diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 55e1751be5..63284f135d 100755 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -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: { $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } } diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 92e287a032..08551f3834 100755 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -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 ; : ( vector polygon amount -- button ) >r gray swap r> diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index 43e0c0bca9..b111caa179 100755 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -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{ diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 50b100bee7..f3b85a2861 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -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" } } diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 8d21eb30bc..80228691ec 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -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 ; : ( 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 ui-error - f swap set-world-active? + f swap (>>active?) ] recover ] with-variable ] [ diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 4bfb209e3a..a437c2dbb6 100755 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -44,7 +44,7 @@ IN: ui.tools dup 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 ] [ diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 2bc2a7ec5d..344b9caa76 100755 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -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 } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index cd82fcaf33..22abfc8f21 100755 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -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 ) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b1ec3864a4..b34a349d3a 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -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 ; 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 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" + handle>> x11-handle-window "XClientMessageEvent" 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* ;