ui.*: Use new accessors

basis/ui/clipboards/clipboards.factor

@@ -1,6 +1,8 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+
 USING: kernel accessors ui.gadgets ui.gestures namespaces ;
+
 IN: ui.clipboards
 
 ! Two text transfer buffers
@@ -14,7 +16,7 @@ M: object paste-clipboard
 
 GENERIC: copy-clipboard ( string gadget clipboard -- )
 
-M: object copy-clipboard nip (>>contents) ;
+M: object copy-clipboard nip set-clipboard-contents ;
 
 SYMBOL: clipboard
 SYMBOL: selection

basis/ui/freetype/freetype-docs.factor

@@ -16,12 +16,35 @@ HELP: init-freetype
 { $notes "Do not call this word if you are using the UI." } ;
 
 HELP: font
-{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
+
-    { $list
+{ $class-description
-        { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
+
-        { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
+"A font which has been loaded by FreeType. Font instances have the following slots:"
-        { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
+
-    }
+{
+  $list
+  {
+    { $snippet "ascent"  } ", "
+    { $snippet "descent" } ", "
+    { $snippet "height"  } " - metrics."
+  }
+
+  {
+    { $snippet "handle" }
+    " - alien pointer to an "
+    { $snippet "FT_Face" } "."
+  }
+
+  {
+    { $snippet "widths" }
+    " - sequence of character widths. Use "
+    { $snippet "width" }
+    " and "
+    { $snippet "width" }
+    " to compute string widths instead of reading this sequence directly."
+  }
+}
+
 } ;
 
 HELP: close-freetype

basis/ui/freetype/freetype.factor

@@ -33,7 +33,7 @@ ascent descent height handle widths ;
 
 M: font hashcode* drop font hashcode* ;
 
-: close-font ( font -- ) font-handle FT_Done_Face ;
+: close-font ( font -- ) handle>> FT_Done_Face ;
 
 : close-freetype ( -- )
     global [
@@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font )
     freetype drop open-fonts get [ <font> ] cache ;
 
 : load-glyph ( font char -- glyph )
-    >r font-handle dup r> 0 FT_Load_Char
+    >r handle>> dup r> 0 FT_Load_Char
     freetype-error face-glyph ;
 
 : char-width ( open-font char -- w )
-    over font-widths [
+    over widths>> [
         dupd load-glyph glyph-hori-advance ft-ceil
     ] cache nip ;
 
@@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w )
     0 -rot [ char-width + ] with each ;
 
 M: freetype-renderer string-height ( open-font string -- h )
-    drop font-height ;
+    drop height>> ;
 
 : glyph-size ( glyph -- dim )
     dup glyph-hori-advance ft-ceil
@@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h )
 
 : glyph-texture-loc ( glyph font -- loc )
     over glyph-hori-bearing-x ft-floor -rot
-    font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
+    ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
 
 : glyph-texture-size ( glyph -- dim )
     [ glyph-bitmap-width next-power-of-2 ]

basis/ui/gadgets/books/books.factor

@@ -5,7 +5,7 @@ IN: ui.gadgets.books
 
 TUPLE: book < gadget ;
 
-: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
+: hide-all ( book -- ) children>> [ hide-gadget ] each ;
 
 : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
 

basis/ui/gadgets/buttons/buttons.factor

@@ -119,9 +119,9 @@ M: checkmark-paint draw-interior
     black <solid>
     black <checkmark-paint>
     <button-paint>
-    over set-gadget-interior
+    over (>>interior)
     black <solid>
-    swap set-gadget-boundary ;
+    swap (>>boundary) ;
 
 : <checkmark> ( -- gadget )
     <gadget>
@@ -165,9 +165,9 @@ M: radio-paint draw-boundary
     black <radio-paint>
     black <radio-paint>
     <button-paint>
-    over set-gadget-interior
+    over (>>interior)
     black <radio-paint>
-    swap set-gadget-boundary ;
+    swap (>>boundary) ;
 
 : <radio-knob> ( -- gadget )
     <gadget>

basis/ui/gadgets/editors/editors.factor

@@ -121,7 +121,7 @@ M: editor ungraft*
     line-height 0 swap 2array ;
 
 : scroll>caret ( editor -- )
-    dup gadget-graft-state second [
+    dup graft-state>> second [
         dup caret-loc over caret-dim { 1 0 } v+ <rect>
         over scroll>rect
     ] when drop ;

basis/ui/gadgets/gadgets.factor

@@ -150,7 +150,7 @@ DEFER: relayout
 : invalidate* ( gadget -- )
     \ invalidate* over (>>layout-state)
     dup forget-pref-dim
-    dup gadget-root?
+    dup root?>>
     [ layout-later ] [ parent>> [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )

basis/ui/gadgets/grids/grids.factor

@@ -77,13 +77,14 @@ M: grid pref-dim*
 M: grid layout* dup compute-grid grid-layout ;
 
 M: grid children-on ( rect gadget -- seq )
-    dup gadget-children empty? [
+    dup children>> empty?
-        2drop f
+      [ 2drop f ]
-    ] [
+      [
         { 0 1 } swap grid>>
         [ 0 <column> fast-children-on ] keep
         <slice> concat
-    ] if ;
+      ]
+    if ;
 
 M: grid gadget-text*
     grid>>

basis/ui/gadgets/incremental/incremental.factor

@@ -23,7 +23,7 @@ TUPLE: incremental < pack cursor ;
         { 0 0 } >>cursor ;
 
 M: incremental pref-dim*
-    dup gadget-layout-state [
+    dup layout-state>> [
         dup call-next-method over set-incremental-cursor
     ] when incremental-cursor ;
 
@@ -31,13 +31,13 @@ M: incremental pref-dim*
     [
         swap rect-dim swap incremental-cursor
         2dup v+ >r vmax r>
-    ] keep gadget-orientation set-axis ;
+    ] keep orientation>> set-axis ;
 
 : update-cursor ( gadget incremental -- )
     [ next-cursor ] keep set-incremental-cursor ;
 
 : incremental-loc ( gadget incremental -- )
-    dup incremental-cursor swap gadget-orientation v*
+    dup incremental-cursor swap orientation>> v*
     swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )
@@ -51,11 +51,11 @@ M: incremental pref-dim*
     2dup incremental-loc
     tuck update-cursor
     dup prefer-incremental
-    gadget-parent [ invalidate* ] when* ;
+    parent>> [ invalidate* ] when* ;
 
 : clear-incremental ( incremental -- )
     not-in-layout
     dup (clear-gadget)
     dup forget-pref-dim
     { 0 0 } over set-incremental-cursor
-    gadget-parent [ relayout ] when* ;
+    parent>> [ relayout ] when* ;

basis/ui/gadgets/labelled/labelled.factor

@@ -29,11 +29,11 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
     gray close-box <polygon-gadget> swap <bevel-button> ;
 
 : title-theme ( gadget -- )
-    { 1 0 } over set-gadget-orientation
+    { 1 0 } over (>>orientation)
     T{ gradient f {
         T{ rgba f 0.65 0.65 1.0 1.0 }
         T{ rgba f 0.65 0.45 1.0 1.0 }
-    } } swap set-gadget-interior ;
+    } } swap (>>interior) ;
 
 : <title-label> ( text -- label ) <label> dup title-theme ;
 

basis/ui/gadgets/lists/lists.factor

@@ -53,7 +53,7 @@ M: list model-changed
     bound-index ;
 
 : selected-rect ( list -- rect )
-    dup list-index swap gadget-children ?nth ;
+    dup list-index swap children>> ?nth ;
 
 M: list draw-gadget*
     origin get [
@@ -98,7 +98,7 @@ M: list focusable-child* drop t ;
     ] if ;
 
 : select-gadget ( gadget list -- )
-    swap over gadget-children index
+    swap over children>> index
     [ swap select-index ] [ drop ] if* ;
 
 : clamp-loc ( point max -- point )

basis/ui/gadgets/packs/packs.factor

@@ -30,7 +30,7 @@ TUPLE: pack < gadget
     nip ;
 
 : pack-layout ( pack sizes -- )
-    round-dims over gadget-children
+    round-dims over children>>
     >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
     >r packed-locs r> [ set-rect-loc ] 2each ;
 
@@ -49,14 +49,14 @@ TUPLE: pack < gadget
 
 : pack-pref-dim ( gadget sizes -- dim )
     over pack-gap over gap-dims >r max-dim r>
-    rot gadget-orientation set-axis ;
+    rot orientation>> set-axis ;
 
 M: pack pref-dim*
-    dup gadget-children pref-dims pack-pref-dim ;
+    dup children>> pref-dims pack-pref-dim ;
 
 M: pack layout*
-    dup gadget-children pref-dims pack-layout ;
+    dup children>> pref-dims pack-layout ;
 
 M: pack children-on ( rect gadget -- seq )
-    dup gadget-orientation swap gadget-children
+    dup orientation>> swap children>>
     [ fast-children-on ] keep <slice> ;

basis/ui/gadgets/panes/panes.factor

@@ -83,7 +83,7 @@ TUPLE: pane-stream pane ;
 C: <pane-stream> pane-stream
 
 : smash-line ( current -- gadget )
-    dup gadget-children {
+    dup children>> {
         { [ dup empty? ] [ 2drop "" <label> ] }
         { [ dup length 1 = ] [ nip first ] }
         [ drop ]
@@ -121,7 +121,7 @@ M: style-stream write-gadget
     output-stream get print-gadget ;
 
 : ?nl ( stream -- )
-    dup pane-stream-pane pane-current gadget-children empty?
+    dup pane-stream-pane pane-current children>> empty?
     [ dup stream-nl ] unless drop ;
 
 : with-pane ( pane quot -- )
@@ -258,7 +258,7 @@ M: pane-stream make-block-stream
     table-gap [ over set-grid-gap ] apply-style ;
 
 : apply-table-border-style ( style grid -- style grid )
-    table-border [ <grid-lines> over set-gadget-boundary ]
+    table-border [ <grid-lines> over (>>boundary) ]
     apply-style ;
 
 : styled-grid ( style grid -- grid )
@@ -336,7 +336,7 @@ M: pack sloppy-pick-up* ( loc gadget -- n )
    [ orientation>> ] [ children>> ] bi (fast-children-on) ;
 
 M: gadget sloppy-pick-up*
-    gadget-children [ inside? ] with find-last drop ;
+    children>> [ inside? ] with find-last drop ;
 
 M: f sloppy-pick-up*
     2drop f ;

basis/ui/gadgets/paragraphs/paragraphs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
+USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render kernel math
 namespaces sequences math.order math.geometry.rect ;
 IN: ui.gadgets.paragraphs
 
@@ -17,7 +17,7 @@ TUPLE: paragraph < gadget margin ;
 
 : <paragraph> ( margin -- gadget )
     paragraph new-gadget
-    { 1 0 } over set-gadget-orientation
+    { 1 0 } over (>>orientation)
     [ set-paragraph-margin ] keep ;
 
 SYMBOL: x SYMBOL: max-x

basis/ui/gadgets/sliders/sliders.factor

@@ -29,7 +29,7 @@ TUPLE: slider < frame elevator thumb saved line ;
     dup slider-page over slider-max 1 max / 1 min
     over elevator-length * min-thumb-dim max
     over slider-elevator rect-dim
-    rot gadget-orientation v. min ;
+    rot orientation>> v. min ;
 
 : slider-scale ( slider -- n )
     #! A scaling factor such that if x is a slider co-ordinate,
@@ -49,7 +49,7 @@ TUPLE: thumb < gadget ;
     find-slider dup slider-value swap set-slider-saved ;
 
 : do-drag ( thumb -- )
-    find-slider drag-loc over gadget-orientation v.
+    find-slider drag-loc over orientation>> v.
     over screen>slider swap [ slider-saved + ] keep
     gadget-model set-range-value ;
 
@@ -75,7 +75,7 @@ thumb H{
 
 : compute-direction ( elevator -- -1/1 )
     dup find-slider swap hand-click-rel
-    over gadget-orientation v.
+    over orientation>> v.
     over screen>slider
     swap slider-value - sgn ;
 
@@ -97,7 +97,7 @@ elevator H{
     lowered-gradient >>interior ;
 
 : (layout-thumb) ( slider n -- n thumb )
-    over gadget-orientation n*v swap slider-thumb ;
+    over orientation>> n*v swap slider-thumb ;
 
 : thumb-loc ( slider -- loc )
     dup slider-value swap slider>screen ;
@@ -109,7 +109,7 @@ elevator H{
 : layout-thumb-dim ( slider -- )
     dup dup thumb-dim (layout-thumb) >r
     >r dup rect-dim r>
-    rot gadget-orientation set-axis [ ceiling ] map
+    rot orientation>> set-axis [ ceiling ] map
     r> (>>dim) ;
 
 : layout-thumb ( slider -- )
@@ -124,7 +124,7 @@ M: elevator layout*
 : <slide-button> ( vector polygon amount -- button )
     >r gray swap <polygon-gadget> r>
     [ swap find-slider slide-by-line ] curry <repeat-button>
-    [ set-gadget-orientation ] keep ;
+    [ (>>orientation) ] keep ;
 
 : elevator, ( gadget orientation -- gadget )
   tuck <elevator> >>elevator
@@ -157,5 +157,5 @@ M: elevator layout*
 
 M: slider pref-dim*
     dup call-next-method
-    swap gadget-orientation [ 40 v*n ] keep
+    swap orientation>> [ 40 v*n ] keep
     set-axis ;

basis/ui/gadgets/viewports/viewports.factor

@@ -41,8 +41,7 @@ M: viewport model-changed
     swap gadget-child set-rect-loc ;
 
 : visible-dim ( gadget -- dim )
-    dup gadget-parent viewport? [
+    dup parent>> viewport?
-        gadget-parent rect-dim viewport-gap 2 v*n v-
+      [ parent>> rect-dim viewport-gap 2 v*n v- ]
-    ] [
+      [ rect-dim ]
-        rect-dim
+    if ;
-    ] if ;

basis/ui/gadgets/worlds/worlds.factor

@@ -23,8 +23,8 @@ M: f world-status ;
 : hide-status ( gadget -- ) f swap show-status ;
 
 : (request-focus) ( child world ? -- )
-    pick gadget-parent pick eq? [
+    pick parent>> pick eq? [
-        >r >r dup gadget-parent dup r> r>
+        >r >r dup parent>> dup r> r>
         [ (request-focus) ] keep
     ] unless focus-child ;
 
@@ -51,7 +51,7 @@ M: world layout*
 
 M: world focusable-child* gadget-child ;
 
-M: world children-on nip gadget-children ;
+M: world children-on nip children>> ;
 
 : (draw-world) ( world -- )
     dup world-handle [

basis/ui/gestures/gestures.factor

@@ -157,15 +157,15 @@ SYMBOL: drag-timer
 
 : focus-child ( child gadget ? -- )
     [
-        dup gadget-focus [
+        dup focus>> [
             dup send-lose-focus
             f swap t focus-child
         ] when*
-        dupd set-gadget-focus [
+        dupd (>>focus) [
             send-gain-focus
         ] when*
     ] [
-        set-gadget-focus
+        (>>focus)
     ] if ;
 
 : modifier ( mod modifiers -- seq )
@@ -244,7 +244,7 @@ SYMBOL: drag-timer
     drop ;
 
 : world-focus ( world -- gadget )
-    dup gadget-focus [ world-focus ] [ ] ?if ;
+    dup focus>> [ world-focus ] [ ] ?if ;
 
 : send-action ( world gesture -- )
     swap world-focus send-gesture drop ;

basis/ui/render/render.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays hashtables io kernel math namespaces opengl
+USING: accessors alien arrays hashtables io kernel math namespaces opengl
 opengl.gl opengl.glu sequences strings io.styles vectors
 combinators math.vectors ui.gadgets colors
 math.order math.geometry.rect ;
@@ -60,7 +60,7 @@ DEFER: draw-gadget
 : (draw-gadget) ( gadget -- )
     [
         dup translate
-        dup dup gadget-interior draw-interior
+        dup dup interior>> draw-interior
         dup draw-gadget*
         dup visible-children [ draw-gadget ] each
         dup gadget-boundary draw-boundary
@@ -79,8 +79,8 @@ DEFER: draw-gadget
 
 : draw-gadget ( gadget -- )
     {
-        { [ dup gadget-visible? not ] [ drop ] }
+        { [ dup visible?>> not ] [ drop ] }
-        { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
+        { [ dup clipped?>> not ] [ (draw-gadget) ] }
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
@@ -108,7 +108,7 @@ C: <gradient> gradient
 
 M: gradient draw-interior
     origin get [
-        over gadget-orientation
+        over orientation>>
         swap gradient-colors
         rot rect-dim
         gl-gradient
@@ -139,7 +139,7 @@ M: polygon draw-interior
 : <polygon-gadget> ( color points -- gadget )
     dup max-dim
     >r <polygon> <gadget> r> over set-rect-dim
-    [ set-gadget-interior ] keep ;
+    [ (>>interior) ] keep ;
 
 ! Font rendering
 SYMBOL: font-renderer

basis/ui/traverse/traverse.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel math arrays io ui.gadgets
+USING: accessors namespaces sequences kernel math arrays io ui.gadgets
 generic combinators ;
 IN: ui.traverse
 
 TUPLE: node value children ;
 
 : traverse-step ( path gadget -- path' gadget' )
-    >r unclip r> gadget-children ?nth ;
+    >r unclip r> children>> ?nth ;
 
 : make-node ( quot -- ) { } make node boa , ; inline
 
@@ -19,7 +19,7 @@ TUPLE: node value children ;
             nip ,
         ] [
             [
-                2dup gadget-children swap first head-slice %
+                2dup children>> swap first head-slice %
                 tuck traverse-step traverse-to-path
             ] make-node
         ] if
@@ -34,7 +34,7 @@ TUPLE: node value children ;
         ] [
             [
                 2dup traverse-step traverse-from-path
-                tuck gadget-children swap first 1+ tail-slice %
+                tuck children>> swap first 1+ tail-slice %
             ] make-node
         ] if
     ] if ;
@@ -43,7 +43,7 @@ TUPLE: node value children ;
     traverse-step traverse-from-path ;
 
 : (traverse-middle) ( frompath topath gadget -- )
-    >r >r first 1+ r> first r> gadget-children <slice> % ;
+    >r >r first 1+ r> first r> children>> <slice> % ;
 
 : traverse-post ( topath gadget -- )
     traverse-step traverse-to-path ;

basis/ui/ui.factor

@@ -90,21 +90,21 @@ SYMBOL: ui-hook
     V{ } clone windows set-global ;
 
 : restore-gadget-later ( gadget -- )
-    dup gadget-graft-state {
+    dup graft-state>> {
         { { f f } [ ] }
         { { f t } [ ] }
         { { t t } [
-            { f f } over set-gadget-graft-state
+            { f f } over (>>graft-state)
         ] }
         { { t f } [
             dup unqueue-graft
-            { f f } over set-gadget-graft-state
+            { f f } over (>>graft-state)
         ] }
     } case graft-later ;
 
 : restore-gadget ( gadget -- )
     dup restore-gadget-later
-    gadget-children [ restore-gadget ] each ;
+    children>> [ restore-gadget ] each ;
 
 : restore-world ( world -- )
     dup reset-world restore-gadget ;
@@ -133,9 +133,9 @@ SYMBOL: ui-hook
     [ dup update-hand draw-world ] each ;
 
 : notify ( gadget -- )
-    dup gadget-graft-state
+    dup graft-state>>
     dup first { f f } { t t } ?
-    pick set-gadget-graft-state {
+    pick (>>graft-state) {
         { { f t } [ dup activate-control graft* ] }
         { { t f } [ dup deactivate-control ungraft* ] }
     } case ;