diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor index 5cd2974dbd..235c74da0b 100644 --- a/basis/ui/clipboards/clipboards.factor +++ b/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 diff --git a/basis/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor index 855df9f564..ef01c6756c 100755 --- a/basis/ui/freetype/freetype-docs.factor +++ b/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 - { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." } - { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." } - { { $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." } - } + +{ $class-description + +"A font which has been loaded by FreeType. Font instances have the following slots:" + +{ + $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 diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 487da931eb..7042811881 100755 --- a/basis/ui/freetype/freetype.factor +++ b/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 ] diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor index 3ff9c63726..161677b56a 100755 --- a/basis/ui/gadgets/books/books.factor +++ b/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 ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 3f52ee9511..09bf036c9a 100755 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/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> diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 301121cdcc..6e09fd73b2 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 9a5f53ac4a..bcf908571c 100755 --- a/basis/ui/gadgets/gadgets.factor +++ b/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 -- ) diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index eb2cdad801..4b60b9e5c8 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/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? [ - 2drop f - ] [ + dup children>> empty? + [ 2drop f ] + [ { 0 1 } swap grid>> [ 0 <column> fast-children-on ] keep <slice> concat - ] if ; + ] + if ; M: grid gadget-text* grid>> diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 8c227d76ce..826be68b97 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/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* ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 077e125b9f..49ccd5aabe 100755 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/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 ; diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor index 10e1f860a7..795307cf25 100755 --- a/basis/ui/gadgets/lists/lists.factor +++ b/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 ) diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 08a034d195..b544b5816b 100755 --- a/basis/ui/gadgets/packs/packs.factor +++ b/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> ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index e7798404f4..dfbeccaad1 100755 --- a/basis/ui/gadgets/panes/panes.factor +++ b/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 ; diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index 1946ff6db6..1f670da92d 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/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 diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index b67edeaea3..294229ddd5 100755 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/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 ; diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index bbe64e7ec5..5a896d8d62 100755 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/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? [ - gadget-parent rect-dim viewport-gap 2 v*n v- - ] [ - rect-dim - ] if ; + dup parent>> viewport? + [ parent>> rect-dim viewport-gap 2 v*n v- ] + [ rect-dim ] + if ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 88ba99201b..8d21eb30bc 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/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? [ - >r >r dup gadget-parent dup r> r> + pick parent>> pick eq? [ + >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 [ diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index f14bc65413..95417ac71f 100755 --- a/basis/ui/gestures/gestures.factor +++ b/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 ; diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index a0a51b09da..e669ec8a52 100644 --- a/basis/ui/render/render.factor +++ b/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 gadget-clipped? not ] [ (draw-gadget) ] } + { [ dup visible?>> not ] [ drop ] } + { [ 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 diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 85b2266159..791bad4e0f 100644 --- a/basis/ui/traverse/traverse.factor +++ b/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 ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0e00627cb9..cd82fcaf33 100755 --- a/basis/ui/ui.factor +++ b/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 ;