2007-09-20 18:09:08 -04:00
|
|
|
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
|
2009-05-04 10:44:26 -04:00
|
|
|
namespaces models kernel accessors arrays ;
|
2008-09-02 02:52:22 -04:00
|
|
|
IN: ui.gadgets.worlds.tests
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
! Test focus behavior
|
|
|
|
|
<gadget> "g1" set
|
|
|
|
|
|
|
|
|
|
: <test-world> ( gadget -- world )
|
2009-05-04 10:44:26 -04:00
|
|
|
<world-attributes> "Hi" >>title swap 1array >>gadgets <world> ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ ] [
|
|
|
|
|
"g1" get <test-world> "w" set
|
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
|
|
[ ] [ "g1" get request-focus ] unit-test
|
|
|
|
|
|
2008-09-02 02:52:22 -04:00
|
|
|
[ t ] [ "w" get focus>> "g1" get eq? ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
<gadget> "g1" set
|
|
|
|
|
<gadget> "g2" set
|
2008-09-27 15:36:04 -04:00
|
|
|
"g2" get "g1" get add-gadget drop
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ ] [
|
|
|
|
|
"g2" get <test-world> "w" set
|
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
|
|
[ ] [ "g1" get request-focus ] unit-test
|
|
|
|
|
|
2008-09-02 02:52:22 -04:00
|
|
|
[ t ] [ "w" get focus>> "g2" get eq? ] unit-test
|
|
|
|
|
[ t ] [ "g2" get focus>> "g1" get eq? ] unit-test
|
|
|
|
|
[ f ] [ "g1" get focus>> ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
<gadget> "g1" set
|
|
|
|
|
<gadget> "g2" set
|
|
|
|
|
<gadget> "g3" set
|
2008-09-27 15:36:04 -04:00
|
|
|
"g3" get "g1" get add-gadget drop
|
|
|
|
|
"g3" get "g2" get add-gadget drop
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ ] [
|
|
|
|
|
"g3" get <test-world> "w" set
|
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
|
|
[ ] [ "g1" get request-focus ] unit-test
|
|
|
|
|
[ ] [ "g2" get unparent ] unit-test
|
2008-09-02 02:52:22 -04:00
|
|
|
[ t ] [ "g3" get focus>> "g1" get eq? ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
|
|
|
|
|
|
2008-07-10 21:32:17 -04:00
|
|
|
TUPLE: focusing < gadget ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-02-18 20:25:34 -05:00
|
|
|
: <focusing> ( -- gadget ) focusing new ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-07-10 21:32:17 -04:00
|
|
|
TUPLE: focus-test < gadget ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-02-18 20:25:34 -05:00
|
|
|
: <focus-test> ( -- gadget )
|
|
|
|
|
focus-test new <focusing> add-gadget ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
M: focus-test focusable-child* gadget-child ;
|
|
|
|
|
|
|
|
|
|
<focus-test> "f" set
|
|
|
|
|
|
|
|
|
|
[ ] [ "f" get <test-world> request-focus ] unit-test
|
|
|
|
|
|
2008-09-02 02:52:22 -04:00
|
|
|
[ t ] [ "f" get focus>> "f" get gadget-child eq? ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ t ] [ "f" get gadget-child focusing? ] unit-test
|
