From d6cf56162fc503936181f1fe8a880aef26f59341 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Nov 2007 01:54:13 -0500 Subject: [PATCH] UI fixes --- extra/ui/gadgets/editors/editors.factor | 2 +- extra/ui/gadgets/gadgets-tests.factor | 20 +++---- extra/ui/gadgets/gadgets.factor | 55 ++++++------------- .../ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/render/render-docs.factor | 2 +- extra/ui/ui.factor | 6 +- extra/ui/windows/windows.factor | 13 ++--- 7 files changed, 38 insertions(+), 62 deletions(-) diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 2221cb2bfd..4250744ea5 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -128,7 +128,7 @@ M: editor model-changed line-height 0 swap 2array ; : scroll>caret ( editor -- ) - dup gadget-status second [ + dup gadget-graft-state second [ dup caret-loc over caret-dim { 1 0 } v+ over scroll>rect ] when drop ; diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index a5a5b36a1b..48bb3718cb 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -139,24 +139,24 @@ M: mock-gadget ungraft* "g" set [ ] [ "g" get queue-graft ] unit-test [ f ] [ graft-queue dlist-empty? ] unit-test - [ { f t } ] [ "g" get gadget-status ] unit-test + [ { f t } ] [ "g" get gadget-graft-state ] unit-test [ ] [ "g" get graft-later ] unit-test - [ { f t } ] [ "g" get gadget-status ] unit-test + [ { f t } ] [ "g" get gadget-graft-state ] unit-test [ ] [ "g" get ungraft-later ] unit-test - [ { f f } ] [ "g" get gadget-status ] unit-test + [ { f f } ] [ "g" get gadget-graft-state ] unit-test [ t ] [ graft-queue dlist-empty? ] unit-test [ ] [ "g" get ungraft-later ] unit-test [ ] [ "g" get graft-later ] unit-test [ ] [ notify-queued ] unit-test - [ { t t } ] [ "g" get gadget-status ] unit-test + [ { t t } ] [ "g" get gadget-graft-state ] unit-test [ t ] [ graft-queue dlist-empty? ] unit-test [ ] [ "g" get graft-later ] unit-test [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test [ ] [ "g" get ungraft-later ] unit-test - [ { t f } ] [ "g" get gadget-status ] unit-test + [ { t f } ] [ "g" get gadget-graft-state ] unit-test [ ] [ notify-queued ] unit-test [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test - [ { f f } ] [ "g" get gadget-status ] unit-test + [ { f f } ] [ "g" get gadget-graft-state ] unit-test ] with-variable : add-some-children @@ -167,7 +167,7 @@ M: mock-gadget ungraft* ] each ; : status-flags - { "g" "1" "2" "3" } [ get gadget-status ] map prune ; + { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ; : notify-combo ( ? ? -- ) nl "===== Combo: " write 2dup 2array . nl @@ -182,9 +182,9 @@ M: mock-gadget ungraft* [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless [ [ ] [ notify-queued ] unit-test ] when [ ] [ add-some-children ] unit-test - [ { f t } ] [ "1" get gadget-status ] unit-test - [ { f t } ] [ "2" get gadget-status ] unit-test - [ { f t } ] [ "3" get gadget-status ] unit-test + [ { f t } ] [ "1" get gadget-graft-state ] unit-test + [ { f t } ] [ "2" get gadget-graft-state ] unit-test + [ { f t } ] [ "3" get gadget-graft-state ] unit-test [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test [ ] [ notify-queued ] unit-test [ V{ { t t } } ] [ status-flags ] unit-test diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ed5c4b935b..fc28d16fdc 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -41,8 +41,8 @@ M: array rect-dim drop { 0 0 } ; (rect-union) ; TUPLE: gadget -pref-dim parent children orientation state focus -visible? root? clipped? status +pref-dim parent children orientation focus +visible? root? clipped? layout-state graft-state interior boundary model ; @@ -63,7 +63,7 @@ M: gadget model-changed drop ; set-delegate set-gadget-orientation set-gadget-visible? - set-gadget-status + set-gadget-graft-state } gadget construct ; : construct-gadget ( class -- tuple ) @@ -170,7 +170,7 @@ M: array gadget-text* : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : invalidate ( gadget -- ) - \ invalidate swap set-gadget-state ; + \ invalidate swap set-gadget-layout-state ; : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; @@ -185,17 +185,17 @@ M: array gadget-text* DEFER: relayout : invalidate* ( gadget -- ) - \ invalidate* over set-gadget-state + \ invalidate* over set-gadget-layout-state dup forget-pref-dim dup gadget-root? [ layout-later ] [ gadget-parent [ relayout ] when* ] if ; : relayout ( gadget -- ) - dup gadget-state \ invalidate* eq? + dup gadget-layout-state \ invalidate* eq? [ drop ] [ invalidate* ] if ; : relayout-1 ( gadget -- ) - dup gadget-state + dup gadget-layout-state [ drop ] [ dup invalidate layout-later ] if ; : show-gadget t swap set-gadget-visible? ; @@ -216,7 +216,8 @@ DEFER: relayout GENERIC: pref-dim* ( gadget -- dim ) : ?set-gadget-pref-dim ( dim gadget -- ) - dup gadget-state [ 2drop ] [ set-gadget-pref-dim ] if ; + dup gadget-layout-state + [ 2drop ] [ set-gadget-pref-dim ] if ; : pref-dim ( gadget -- dim ) dup gadget-pref-dim [ ] [ @@ -233,10 +234,10 @@ M: gadget layout* drop ; : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; -: validate ( gadget -- ) f swap set-gadget-state ; +: validate ( gadget -- ) f swap set-gadget-layout-state ; : layout ( gadget -- ) - dup gadget-state [ + dup gadget-layout-state [ dup validate dup layout* dup [ layout ] each-child @@ -246,19 +247,19 @@ M: gadget layout* drop ; : unqueue-graft ( gadget -- ) dup graft-queue dlist-delete [ "Not queued" throw ] unless - dup gadget-status first { t t } { f f } ? - swap set-gadget-status ; + dup gadget-graft-state first { t t } { f f } ? + swap set-gadget-graft-state ; : queue-graft ( gadget -- ) - { f t } over set-gadget-status + { f t } over set-gadget-graft-state graft-queue push-front ; : queue-ungraft ( gadget -- ) - { t f } over set-gadget-status + { t f } over set-gadget-graft-state graft-queue push-front ; : graft-later ( gadget -- ) - dup gadget-status { + dup gadget-graft-state { { { f t } [ drop ] } { { t t } [ drop ] } { { t f } [ unqueue-graft ] } @@ -266,7 +267,7 @@ M: gadget layout* drop ; } case ; : ungraft-later ( gadget -- ) - dup gadget-status { + dup gadget-graft-state { { { f f } [ drop ] } { { t f } [ drop ] } { { f t } [ unqueue-graft ] } @@ -277,16 +278,6 @@ GENERIC: graft* ( gadget -- ) M: gadget graft* drop ; -! : graft ( gadget -- ) -! dup gadget-grafted? [ -! drop -! ] [ -! t over set-gadget-grafted? -! dup graft* -! dup activate-control -! [ graft ] each-child -! ] if ; - : graft ( gadget -- ) dup graft-later [ graft ] each-child ; @@ -294,16 +285,6 @@ GENERIC: ungraft* ( gadget -- ) M: gadget ungraft* drop ; -! : ungraft ( gadget -- ) -! dup gadget-grafted? [ -! dup [ ungraft ] each-child -! dup deactivate-control -! dup ungraft* -! f swap set-gadget-grafted? -! ] [ -! drop ! "Fuck you" throw -! ] if ; - : ungraft ( gadget -- ) dup [ ungraft ] each-child ungraft-later ; @@ -351,7 +332,7 @@ SYMBOL: in-layout? over unparent dup pick set-gadget-parent [ ((add-gadget)) ] 2keep - gadget-status second [ graft ] [ drop ] if ; + gadget-graft-state second [ graft ] [ drop ] if ; : add-gadget ( gadget parent -- ) not-in-layout diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 5f213bc31a..2cd2c3d13c 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -21,7 +21,7 @@ TUPLE: incremental cursor ; dup delegate pref-dim over set-incremental-cursor ; M: incremental pref-dim* - dup gadget-state [ + dup gadget-layout-state [ dup delegate pref-dim over set-incremental-cursor ] when incremental-cursor ; diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index 3c5ad22e30..2f82d983cc 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -9,7 +9,7 @@ HELP: gadget { { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." } { { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." } { { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." } - { { $link gadget-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." } + { { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." } { { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." } { { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." } { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." } diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 810ccacf80..4d2101997e 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -95,12 +95,12 @@ SYMBOL: ui-hook [ dup update-hand draw-world ] each ; : notify ( gadget -- ) - dup gadget-status { + dup gadget-graft-state { { { f t } [ dup activate-control dup graft* ] } { { t f } [ dup activate-control dup ungraft* ] } } case - dup gadget-status first { f f } { t t } ? - swap set-gadget-status ; + dup gadget-graft-state first { f f } { t t } ? + swap set-gadget-graft-state ; : notify-queued ( -- ) graft-queue [ notify ] dlist-slurp ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 7c1b578981..cd77dc0a98 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -342,23 +342,18 @@ SYMBOL: hWnd : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; -: do-events ( msg -- ) +: event-loop ( msg -- ) { { [ windows get empty? ] [ drop ] } - { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] } + { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] } { [ dup MSG-message WM_QUIT = ] [ drop ] } { [ t ] [ dup TranslateMessage drop dup DispatchMessage drop - do-events + event-loop ] } } cond ; -: event-loop ( -- ) - windows get empty? [ - msg-obj get do-events - ] unless ; - : register-wndclassex ( -- class ) "WNDCLASSEX" f GetModuleHandle @@ -448,7 +443,7 @@ M: windows-ui-backend ui init-clipboard init-win32-ui start-ui - event-loop + msg-obj get event-loop ] [ cleanup-win32-ui ] [ ] cleanup ] ui-running ;