steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

UI fixes

release
Slava Pestov 2007-11-16 01:54:13 -05:00
parent 9d7b1ac4dc
commit d6cf56162f
7 changed files with 38 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/ui/gadgets/editors/editors.factor
View File

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

20
extra/ui/gadgets/gadgets-tests.factor
View File

@ -139,24 +139,24 @@ M: mock-gadget ungraft*
<mock-gadget> "g" set <mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test [ ] [ "g" get queue-graft ] unit-test
[ f ] [ graft-queue dlist-empty? ] 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 [ ] [ "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 [ ] [ "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 [ t ] [ graft-queue dlist-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test [ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test [ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] 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 [ t ] [ graft-queue dlist-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test [ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ ] [ "g" get ungraft-later ] 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 [ ] [ notify-queued ] unit-test
[ 1 ] [ "g" get mock-gadget-ungraft-called ] 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 ] with-variable
: add-some-children : add-some-children
@ -167,7 +167,7 @@ M: mock-gadget ungraft*
] each ; ] each ;
: status-flags : status-flags
{ "g" "1" "2" "3" } [ get gadget-status ] map prune ; { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
: notify-combo ( ? ? -- ) : notify-combo ( ? ? -- )
nl "===== Combo: " write 2dup 2array . nl nl "===== Combo: " write 2dup 2array . nl
@ -182,9 +182,9 @@ M: mock-gadget ungraft*
[ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
[ [ ] [ notify-queued ] unit-test ] when [ [ ] [ notify-queued ] unit-test ] when
[ ] [ add-some-children ] unit-test [ ] [ add-some-children ] unit-test
[ { f t } ] [ "1" get gadget-status ] unit-test [ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-status ] unit-test [ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-status ] unit-test [ { f t } ] [ "3" get gadget-graft-state ] unit-test
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
[ ] [ notify-queued ] unit-test [ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test [ V{ { t t } } ] [ status-flags ] unit-test

55
extra/ui/gadgets/gadgets.factor
View File

@ -41,8 +41,8 @@ M: array rect-dim drop { 0 0 } ;
(rect-union) <extent-rect> ; (rect-union) <extent-rect> ;
TUPLE: gadget TUPLE: gadget
pref-dim parent children orientation state focus pref-dim parent children orientation focus
visible? root? clipped? status visible? root? clipped? layout-state graft-state
interior boundary interior boundary
model ; model ;
@ -63,7 +63,7 @@ M: gadget model-changed drop ;
set-delegate set-delegate
set-gadget-orientation set-gadget-orientation
set-gadget-visible? set-gadget-visible?
set-gadget-status set-gadget-graft-state
} gadget construct ; } gadget construct ;
: construct-gadget ( class -- tuple ) : construct-gadget ( class -- tuple )
@ -170,7 +170,7 @@ M: array gadget-text*
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- ) : invalidate ( gadget -- )
\ invalidate swap set-gadget-state ; \ invalidate swap set-gadget-layout-state ;
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
@ -185,17 +185,17 @@ M: array gadget-text*
DEFER: relayout DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over set-gadget-state \ invalidate* over set-gadget-layout-state
dup forget-pref-dim dup forget-pref-dim
dup gadget-root? dup gadget-root?
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ; [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
: relayout ( gadget -- ) : relayout ( gadget -- )
dup gadget-state \ invalidate* eq? dup gadget-layout-state \ invalidate* eq?
[ drop ] [ invalidate* ] if ; [ drop ] [ invalidate* ] if ;
: relayout-1 ( gadget -- ) : relayout-1 ( gadget -- )
dup gadget-state dup gadget-layout-state
[ drop ] [ dup invalidate layout-later ] if ; [ drop ] [ dup invalidate layout-later ] if ;
: show-gadget t swap set-gadget-visible? ; : show-gadget t swap set-gadget-visible? ;
@ -216,7 +216,8 @@ DEFER: relayout
GENERIC: pref-dim* ( gadget -- dim ) GENERIC: pref-dim* ( gadget -- dim )
: ?set-gadget-pref-dim ( dim gadget -- ) : ?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 ) : pref-dim ( gadget -- dim )
dup gadget-pref-dim [ ] [ dup gadget-pref-dim [ ] [
@ -233,10 +234,10 @@ M: gadget layout* drop ;
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; : 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 -- ) : layout ( gadget -- )
dup gadget-state [ dup gadget-layout-state [
dup validate dup validate
dup layout* dup layout*
dup [ layout ] each-child dup [ layout ] each-child
@ -246,19 +247,19 @@ M: gadget layout* drop ;
: unqueue-graft ( gadget -- ) : unqueue-graft ( gadget -- )
dup graft-queue dlist-delete [ "Not queued" throw ] unless dup graft-queue dlist-delete [ "Not queued" throw ] unless
dup gadget-status first { t t } { f f } ? dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-status ; swap set-gadget-graft-state ;
: queue-graft ( gadget -- ) : queue-graft ( gadget -- )
{ f t } over set-gadget-status { f t } over set-gadget-graft-state
graft-queue push-front ; graft-queue push-front ;
: queue-ungraft ( gadget -- ) : queue-ungraft ( gadget -- )
{ t f } over set-gadget-status { t f } over set-gadget-graft-state
graft-queue push-front ; graft-queue push-front ;
: graft-later ( gadget -- ) : graft-later ( gadget -- )
dup gadget-status { dup gadget-graft-state {
{ { f t } [ drop ] } { { f t } [ drop ] }
{ { t t } [ drop ] } { { t t } [ drop ] }
{ { t f } [ unqueue-graft ] } { { t f } [ unqueue-graft ] }
@ -266,7 +267,7 @@ M: gadget layout* drop ;
} case ; } case ;
: ungraft-later ( gadget -- ) : ungraft-later ( gadget -- )
dup gadget-status { dup gadget-graft-state {
{ { f f } [ drop ] } { { f f } [ drop ] }
{ { t f } [ drop ] } { { t f } [ drop ] }
{ { f t } [ unqueue-graft ] } { { f t } [ unqueue-graft ] }
@ -277,16 +278,6 @@ GENERIC: graft* ( gadget -- )
M: gadget graft* drop ; 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 -- ) : graft ( gadget -- )
dup graft-later [ graft ] each-child ; dup graft-later [ graft ] each-child ;
@ -294,16 +285,6 @@ GENERIC: ungraft* ( gadget -- )
M: gadget ungraft* drop ; 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 -- ) : ungraft ( gadget -- )
dup [ ungraft ] each-child ungraft-later ; dup [ ungraft ] each-child ungraft-later ;
@ -351,7 +332,7 @@ SYMBOL: in-layout?
over unparent over unparent
dup pick set-gadget-parent dup pick set-gadget-parent
[ ((add-gadget)) ] 2keep [ ((add-gadget)) ] 2keep
gadget-status second [ graft ] [ drop ] if ; gadget-graft-state second [ graft ] [ drop ] if ;
: add-gadget ( gadget parent -- ) : add-gadget ( gadget parent -- )
not-in-layout not-in-layout

2
extra/ui/gadgets/incremental/incremental.factor
View File

@ -21,7 +21,7 @@ TUPLE: incremental cursor ;
dup delegate pref-dim over set-incremental-cursor ; dup delegate pref-dim over set-incremental-cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup gadget-state [ dup gadget-layout-state [
dup delegate pref-dim over set-incremental-cursor dup delegate pref-dim over set-incremental-cursor
] when incremental-cursor ; ] when incremental-cursor ;

2
extra/ui/render/render-docs.factor
View File

@ -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-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-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-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-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-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." } { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }

6
extra/ui/ui.factor
View File

@ -95,12 +95,12 @@ SYMBOL: ui-hook
[ dup update-hand draw-world ] each ; [ dup update-hand draw-world ] each ;
: notify ( gadget -- ) : notify ( gadget -- )
dup gadget-status { dup gadget-graft-state {
{ { f t } [ dup activate-control dup graft* ] } { { f t } [ dup activate-control dup graft* ] }
{ { t f } [ dup activate-control dup ungraft* ] } { { t f } [ dup activate-control dup ungraft* ] }
} case } case
dup gadget-status first { f f } { t t } ? dup gadget-graft-state first { f f } { t t } ?
swap set-gadget-status ; swap set-gadget-graft-state ;
: notify-queued ( -- ) : notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ; graft-queue [ notify ] dlist-slurp ;

13
extra/ui/windows/windows.factor
View File

@ -342,23 +342,18 @@ SYMBOL: hWnd
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
: do-events ( msg -- ) : event-loop ( msg -- )
{ {
{ [ windows get empty? ] [ drop ] } { [ 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 ] } { [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [ { [ t ] [
dup TranslateMessage drop dup TranslateMessage drop
dup DispatchMessage drop dup DispatchMessage drop
do-events event-loop
] } ] }
} cond ; } cond ;
: event-loop ( -- )
windows get empty? [
msg-obj get do-events
] unless ;
: register-wndclassex ( -- class ) : register-wndclassex ( -- class )
"WNDCLASSEX" <c-object> "WNDCLASSEX" <c-object>
f GetModuleHandle f GetModuleHandle
@ -448,7 +443,7 @@ M: windows-ui-backend ui
init-clipboard init-clipboard
init-win32-ui init-win32-ui
start-ui start-ui
event-loop msg-obj get event-loop
] [ cleanup-win32-ui ] [ ] cleanup ] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ; ] ui-running ;