diff --git a/basis/tools/test/ui/ui.factor b/basis/tools/test/ui/ui.factor index 666a7d24d9..c37e7799cb 100644 --- a/basis/tools/test/ui/ui.factor +++ b/basis/tools/test/ui/ui.factor @@ -1,5 +1,5 @@ -USING: dlists ui.gadgets kernel ui namespaces io.streams.string -io ; +USING: dlists ui.gadgets ui.gadgets.private +kernel ui namespaces io.streams.string io ; IN: tools.test.ui ! We can't print to output-stream here because that might be a pane diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index e70172bed7..27c2e07d99 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows -sequences ui ui.gadgets ui.gadgets.worlds ui.gestures +sequences ui ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures core-foundation.strings core-graphics core-graphics.types threads combinators math.geometry.rect ; IN: ui.backend.cocoa.views @@ -117,8 +117,8 @@ CONSTANT: key-codes 2bi ; : rect>NSRect ( rect world -- NSRect ) - [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ] - [ drop rect-dim first2 ] + [ [ loc>> first2 ] [ dim>> second ] bi* swap - ] + [ drop dim>> first2 ] 2bi ; CLASS: { @@ -366,7 +366,7 @@ CLASS: { CGLSetParameter drop ; : ( world -- view ) - FactorView over rect-dim + FactorView over dim>> [ sync-refresh-to-screen ] keep [ register-window ] keep ; diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index bdd9ebaf13..37af24ae25 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -17,7 +17,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set [ 2 ] [ "t" get children>> length ] unit-test -[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test +[ "Foo A" ] [ "t" get gadget-child gadget-child string>> ] unit-test [ ] [ 2 { diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 32e124afd7..25a92a6852 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -176,7 +176,7 @@ M: editor ungraft* : first-visible-line ( editor -- n ) [ - [ clip get rect-loc second origin get second - ] dip + [ clip get loc>> second origin get second - ] dip y>line ] keep model>> validate-line ; diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index 169f97f0b9..0312921344 100644 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax opengl kernel strings - classes.tuple classes quotations models math.geometry.rect ; +classes.tuple classes quotations models math.geometry.rect +ui.gadgets.private ; IN: ui.gadgets HELP: gadget-child diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 01d695c281..cf76fb52d2 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -1,7 +1,7 @@ -USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds -tools.test namespaces models kernel dlists deques math sets -math.parser ui sequences hashtables assocs io arrays prettyprint -io.streams.string math.geometry.rect ; +USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs +ui.gadgets.worlds tools.test namespaces models kernel dlists deques +math sets math.parser ui sequences hashtables assocs io arrays +prettyprint io.streams.string math.geometry.rect ; IN: ui.gadgets.tests [ { 300 300 } ] diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 0a439a1a1a..f9cad95251 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting @@ -6,10 +6,6 @@ binary-search vectors dlists deques models threads concurrency.flags math.order math.geometry.rect fry ; IN: ui.gadgets -SYMBOL: ui-notify-flag - -: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; - TUPLE: gadget < rect pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node interior boundary model ; @@ -35,17 +31,6 @@ M: gadget model-changed 2drop ; : ( -- gadget ) gadget new-gadget ; -: activate-control ( gadget -- ) - dup model>> dup [ - 2dup add-connection - swap model-changed - ] [ - 2drop - ] if ; - -: deactivate-control ( gadget -- ) - dup model>> dup [ 2dup remove-connection ] when 2drop ; - : control-value ( control -- value ) model>> value>> ; @@ -56,7 +41,7 @@ M: gadget model-changed 2drop ; 2dup eq? [ 2drop { 0 0 } ] [ - over rect-loc [ [ parent>> ] dip relative-loc ] dip v+ + [ [ parent>> ] dip relative-loc ] [ drop loc>> ] 2bi v+ ] if ; GENERIC: user-input* ( str gadget -- ? ) @@ -67,23 +52,31 @@ GENERIC: children-on ( rect/point gadget -- seq ) M: gadget children-on nip children>> ; + ) [ swap loc>> v- ] dip v. 0 <=> ; : (fast-children-on) ( dim axis children -- i ) -rot '[ _ _ ((fast-children-on)) ] search drop ; +PRIVATE> + : fast-children-on ( rect axis children -- from to ) [ [ rect-loc ] 2dip (fast-children-on) 0 or ] [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ] 3bi ; +> [ intersects? ] [ 2drop f ] if ; : (pick-up) ( point gadget -- gadget ) dupd children-on [ inside? ] with find-last nip ; +PRIVATE> + : pick-up ( point gadget -- child/f ) 2dup (pick-up) dup [ nip [ rect-loc v- ] keep pick-up ] [ drop nip ] if ; @@ -124,6 +117,14 @@ M: array gadget-text* : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; +DEFER: relayout + +>layout-state drop ; @@ -137,14 +138,14 @@ M: array gadget-text* #! invalidation requests. layout-queue [ push-front notify-ui-thread ] [ drop ] if* ; -DEFER: relayout - : invalidate* ( gadget -- ) \ invalidate* >>layout-state dup forget-pref-dim dup root?>> [ layout-later ] [ parent>> [ relayout ] when* ] if ; +PRIVATE> + : relayout ( gadget -- ) dup layout-state>> \ invalidate* eq? [ drop ] [ invalidate* ] if ; @@ -157,13 +158,17 @@ DEFER: relayout : hide-gadget ( gadget -- ) f >>visible? drop ; -DEFER: in-layout? + + M: gadget (>>dim) ( dim gadget -- ) 2dup dim>> = [ 2drop ] @@ -171,18 +176,19 @@ M: gadget (>>dim) ( dim gadget -- ) GENERIC: pref-dim* ( gadget -- dim ) -: ?set-gadget-pref-dim ( dim gadget -- ) - dup layout-state>> - [ 2drop ] [ (>>pref-dim) ] if ; - : pref-dim ( gadget -- dim ) dup pref-dim>> [ ] [ - [ pref-dim* dup ] keep ?set-gadget-pref-dim + [ pref-dim* ] keep dup layout-state>> + [ drop ] [ dupd (>>pref-dim) ] if ] ?if ; : pref-dims ( gadgets -- seq ) [ pref-dim ] map ; -M: gadget pref-dim* rect-dim ; +M: gadget pref-dim* dim>> ; + +GENERIC: baseline ( gadget -- y ) + +M: gadget baseline pref-dim second ; GENERIC: layout* ( gadget -- ) @@ -190,15 +196,23 @@ M: gadget layout* drop ; : prefer ( gadget -- ) dup pref-dim >>dim drop ; -: validate ( gadget -- ) f >>layout-state drop ; - : layout ( gadget -- ) dup layout-state>> [ - dup validate + f >>layout-state dup layout* dup [ layout ] each-child ] when drop ; +GENERIC: graft* ( gadget -- ) + +M: gadget graft* drop ; + +GENERIC: ungraft* ( gadget -- ) + +M: gadget ungraft* drop ; + +> { { { f f } [ drop ] } @@ -232,29 +249,44 @@ M: gadget layout* drop ; { { t t } [ queue-ungraft ] } } case ; -GENERIC: graft* ( gadget -- ) - -M: gadget graft* drop ; - -: graft ( gadget -- ) - dup graft-later [ graft ] each-child ; - -GENERIC: ungraft* ( gadget -- ) - -M: gadget ungraft* drop ; - : ungraft ( gadget -- ) dup [ ungraft ] each-child ungraft-later ; +: activate-control ( gadget -- ) + dup model>> dup [ + 2dup add-connection + swap model-changed + ] [ + 2drop + ] if ; + +: deactivate-control ( gadget -- ) + dup model>> dup [ 2dup remove-connection ] when 2drop ; + +: notify ( gadget -- ) + dup graft-state>> + [ first { f f } { t t } ? >>graft-state ] keep + { + { { f t } [ dup activate-control graft* ] } + { { t f } [ dup deactivate-control ungraft* ] } + } case ; + +: notify-queued ( -- ) + graft-queue [ notify ] slurp-deque ; + : (unparent) ( gadget -- ) dup ungraft dup forget-pref-dim f >>parent drop ; +: (clear-gadget) ( gadget -- ) + dup [ (unparent) ] each-child + f >>focus f >>children drop ; + : unfocus-gadget ( child gadget -- ) [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ; -SYMBOL: in-layout? +PRIVATE> : not-in-layout ( -- ) in-layout? get @@ -273,14 +305,12 @@ SYMBOL: in-layout? ] if ] when* ; -: (clear-gadget) ( gadget -- ) - dup [ (unparent) ] each-child - f >>focus f >>children drop ; - : clear-gadget ( gadget -- ) not-in-layout dup (clear-gadget) relayout ; +> ?push >>children ; @@ -290,6 +320,8 @@ SYMBOL: in-layout? tuck ((add-gadget)) tuck graft-state>> second [ graft ] [ drop ] if ; +PRIVATE> + : add-gadget ( parent child -- parent ) not-in-layout (add-gadget) @@ -310,7 +342,9 @@ SYMBOL: in-layout? [ parents ] dip find nip ; inline : screen-loc ( gadget -- loc ) - parents { 0 0 } [ rect-loc v+ ] reduce ; + parents { 0 0 } [ loc>> v+ ] reduce ; + +> [ @@ -320,6 +354,8 @@ SYMBOL: in-layout? rect-extent ] if* ; +PRIVATE> + : screen-rect ( gadget -- rect ) (screen-rect) ; @@ -347,5 +383,5 @@ M: f request-focus-on 2drop ; : request-focus ( gadget -- ) [ focusable-child ] keep request-focus-on ; -: focus-path ( world -- seq ) +: focus-path ( gadget -- seq ) [ focus>> ] follow ; diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor index 4552fcdd5d..a28f21c3ad 100755 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -19,14 +19,14 @@ SYMBOL: grid-dim [ [ grid-dim get ] 2dip set-axis ] 2bi ; : draw-grid-lines ( gaps orientation -- ) - [ grid get swap grid-positions grid get rect-dim suffix ] dip + [ grid get swap grid-positions grid get dim>> suffix ] dip [ '[ _ v- ] map ] keep '[ _ swap grid-line-from/to gl-line ] each ; M: grid-lines draw-boundary color>> gl-color [ [ grid set ] - [ rect-dim half-gap v- grid-dim set ] + [ dim>> half-gap v- grid-dim set ] [ compute-grid ] tri [ { 1 0 } draw-grid-lines ] [ { 0 1 } draw-grid-lines ] diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index e7a651604c..81c980afbc 100644 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces math.vectors ui.gadgets -ui.gadgets.packs accessors math.geometry.rect combinators ; +ui.gadgets.private ui.gadgets.packs accessors +math.geometry.rect combinators ; IN: ui.gadgets.incremental TUPLE: incremental < pack cursor ; @@ -18,7 +19,7 @@ M: incremental pref-dim* : next-cursor ( gadget incremental -- cursor ) [ - [ rect-dim ] [ cursor>> ] bi* + [ dim>> ] [ cursor>> ] bi* [ vmax ] [ v+ ] 2bi ] keep orientation>> set-axis ; diff --git a/basis/ui/gadgets/labels/labels-docs.factor b/basis/ui/gadgets/labels/labels-docs.factor index ed4278e2cd..066a79b900 100644 --- a/basis/ui/gadgets/labels/labels-docs.factor +++ b/basis/ui/gadgets/labels/labels-docs.factor @@ -8,28 +8,19 @@ HELP: