Merge branch 'master' of git://factorcode.org/git/factor
commit
5a5aeafa9f
|
@ -38,6 +38,18 @@ HELP: adjoin
|
||||||
}
|
}
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
|
HELP: conjoin
|
||||||
|
{ $values { "elt" object } { "assoc" "an assoc" } }
|
||||||
|
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
|
||||||
|
{ $examples
|
||||||
|
{ $example
|
||||||
|
"USING: kernel prettyprint sets ;"
|
||||||
|
"H{ } clone 1 over conjoin ."
|
||||||
|
"H{ { 1 1 } }"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
HELP: unique
|
HELP: unique
|
||||||
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
||||||
{ $description "Outputs a new assoc where the keys and values are equal." }
|
{ $description "Outputs a new assoc where the keys and values are equal." }
|
||||||
|
|
|
@ -1,13 +1,8 @@
|
||||||
USING: arrays assocs kernel vectors sequences namespaces
|
USING: arrays assocs kernel vectors sequences namespaces
|
||||||
random math.parser math fry ;
|
random math.parser math fry ;
|
||||||
|
|
||||||
IN: assocs.lib
|
IN: assocs.lib
|
||||||
|
|
||||||
: ref-at ( table key -- value ) swap at ;
|
|
||||||
|
|
||||||
: put-at* ( table key value -- ) swap rot set-at ;
|
|
||||||
|
|
||||||
: put-at ( table key value -- table ) swap pick set-at ;
|
|
||||||
|
|
||||||
: set-assoc-stack ( value key seq -- )
|
: set-assoc-stack ( value key seq -- )
|
||||||
dupd [ key? ] with find-last nip set-at ;
|
dupd [ key? ] with find-last nip set-at ;
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
||||||
! step-wrapped-line
|
! step-wrapped-line
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: pattern>state ( {_a_b_c_} -- state ) >array rule> at ;
|
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
|
||||||
|
|
||||||
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
||||||
|
|
||||||
|
|
|
@ -14,13 +14,25 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
||||||
ui.gadgets.packs
|
ui.gadgets.packs
|
||||||
ui.gadgets.grids
|
ui.gadgets.grids
|
||||||
ui.gadgets.theme
|
ui.gadgets.theme
|
||||||
|
accessors
|
||||||
|
qualified
|
||||||
namespaces.lib assocs.lib vars
|
namespaces.lib assocs.lib vars
|
||||||
rewrite-closures automata math.geometry.rect ;
|
rewrite-closures automata math.geometry.rect newfx ;
|
||||||
|
|
||||||
IN: automata.ui
|
IN: automata.ui
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
QUALIFIED: ui.gadgets
|
||||||
|
QUALIFIED: ui.gadgets.grids
|
||||||
|
|
||||||
|
: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ;
|
||||||
|
|
||||||
|
: grid-add ( grid child i j -- grid )
|
||||||
|
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
|
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
|
||||||
|
|
||||||
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
|
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
|
||||||
|
@ -57,29 +69,40 @@ slate> relayout-1 ;
|
||||||
|
|
||||||
DEFER: automata-window
|
DEFER: automata-window
|
||||||
|
|
||||||
: automata-window* ( -- ) init-rule set-interesting <frame>
|
: automata-window* ( -- )
|
||||||
|
init-rule
|
||||||
|
set-interesting
|
||||||
|
|
||||||
{
|
<frame>
|
||||||
[ "1 - Center" [ start-center ] view-button ]
|
|
||||||
[ "2 - Random" [ start-random ] view-button ]
|
|
||||||
[ "3 - Continue" [ run-rule ] view-button ]
|
|
||||||
[ "5 - Random Rule" [ random-rule ] view-button ]
|
|
||||||
[ "n - New" [ automata-window ] view-button ]
|
|
||||||
} make*
|
|
||||||
[ [ gadget, ] curry ] map concat ! Hack
|
|
||||||
make-shelf over @top grid-add
|
|
||||||
|
|
||||||
[ display ] closed-quot <slate> { 400 400 } over set-slate-dim dup >slate
|
<shelf>
|
||||||
over @center grid-add
|
|
||||||
|
|
||||||
{
|
"1 - Center" [ start-center ] view-button add-gadget
|
||||||
{ T{ key-down f f "1" } [ [ start-center ] view-action ] }
|
"2 - Random" [ start-random ] view-button add-gadget
|
||||||
{ T{ key-down f f "2" } [ [ start-random ] view-action ] }
|
"3 - Continue" [ run-rule ] view-button add-gadget
|
||||||
{ T{ key-down f f "3" } [ [ run-rule ] view-action ] }
|
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
||||||
{ T{ key-down f f "5" } [ [ random-rule ] view-action ] }
|
"n - New" [ automata-window ] view-button add-gadget
|
||||||
{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
|
|
||||||
} [ make* ] map >hashtable <handler> tuck set-gadget-delegate
|
@top grid-add
|
||||||
"Automata" open-window ;
|
|
||||||
|
C[ display ] <slate>
|
||||||
|
{ 400 400 } >>dim
|
||||||
|
dup >slate
|
||||||
|
|
||||||
|
@center grid-add
|
||||||
|
|
||||||
|
H{ }
|
||||||
|
T{ key-down f f "1" } [ start-center ] view-action is
|
||||||
|
T{ key-down f f "2" } [ start-random ] view-action is
|
||||||
|
T{ key-down f f "3" } [ run-rule ] view-action is
|
||||||
|
T{ key-down f f "5" } [ random-rule ] view-action is
|
||||||
|
T{ key-down f f "n" } [ automata-window ] view-action is
|
||||||
|
|
||||||
|
<handler>
|
||||||
|
|
||||||
|
tuck set-gadget-delegate
|
||||||
|
|
||||||
|
"Automata" open-window ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
|
@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces
|
||||||
ui.gadgets.grids
|
ui.gadgets.grids
|
||||||
ui.gestures
|
ui.gestures
|
||||||
assocs.lib vars rewrite-closures boids accessors
|
assocs.lib vars rewrite-closures boids accessors
|
||||||
math.geometry.rect ;
|
math.geometry.rect
|
||||||
|
newfx ;
|
||||||
|
|
||||||
IN: boids.ui
|
IN: boids.ui
|
||||||
|
|
||||||
|
@ -145,20 +146,20 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
||||||
slate> over @center grid-add
|
slate> over @center grid-add
|
||||||
|
|
||||||
H{ } clone
|
H{ } clone
|
||||||
T{ key-down f f "1" } C[ drop randomize ] put-at
|
T{ key-down f f "1" } C[ drop randomize ] is
|
||||||
T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
|
T{ key-down f f "2" } C[ drop sub-10-boids ] is
|
||||||
T{ key-down f f "3" } C[ drop add-10-boids ] put-at
|
T{ key-down f f "3" } C[ drop add-10-boids ] is
|
||||||
|
|
||||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
|
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
|
||||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
|
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
|
||||||
|
|
||||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
|
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
|
||||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
|
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
|
||||||
|
|
||||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
|
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
|
||||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
|
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
||||||
|
|
||||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
|
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||||
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
||||||
|
|
||||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||||
|
|
|
@ -12,10 +12,10 @@ SYMBOL: ui-notify-flag
|
||||||
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
||||||
|
|
||||||
TUPLE: gadget < rect
|
TUPLE: gadget < rect
|
||||||
pref-dim parent children orientation focus
|
pref-dim parent children orientation focus
|
||||||
visible? root? clipped? layout-state graft-state graft-node
|
visible? root? clipped? layout-state graft-state graft-node
|
||||||
interior boundary
|
interior boundary
|
||||||
model ;
|
model ;
|
||||||
|
|
||||||
M: gadget equal? 2drop f ;
|
M: gadget equal? 2drop f ;
|
||||||
|
|
||||||
|
@ -23,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ;
|
||||||
|
|
||||||
M: gadget model-changed 2drop ;
|
M: gadget model-changed 2drop ;
|
||||||
|
|
||||||
: gadget-child ( gadget -- child ) gadget-children first ;
|
: gadget-child ( gadget -- child ) children>> first ;
|
||||||
|
|
||||||
: nth-gadget ( n gadget -- child ) gadget-children nth ;
|
: nth-gadget ( n gadget -- child ) children>> nth ;
|
||||||
|
|
||||||
: new-gadget ( class -- gadget )
|
: new-gadget ( class -- gadget )
|
||||||
new
|
new
|
||||||
|
@ -37,7 +37,7 @@ M: gadget model-changed 2drop ;
|
||||||
gadget new-gadget ;
|
gadget new-gadget ;
|
||||||
|
|
||||||
: activate-control ( gadget -- )
|
: activate-control ( gadget -- )
|
||||||
dup gadget-model dup [
|
dup model>> dup [
|
||||||
2dup add-connection
|
2dup add-connection
|
||||||
swap model-changed
|
swap model-changed
|
||||||
] [
|
] [
|
||||||
|
@ -45,20 +45,20 @@ M: gadget model-changed 2drop ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: deactivate-control ( gadget -- )
|
: deactivate-control ( gadget -- )
|
||||||
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
|
dup model>> dup [ 2dup remove-connection ] when 2drop ;
|
||||||
|
|
||||||
: control-value ( control -- value )
|
: control-value ( control -- value )
|
||||||
gadget-model model-value ;
|
model>> model-value ;
|
||||||
|
|
||||||
: set-control-value ( value control -- )
|
: set-control-value ( value control -- )
|
||||||
gadget-model set-model ;
|
model>> set-model ;
|
||||||
|
|
||||||
: relative-loc ( fromgadget togadget -- loc )
|
: relative-loc ( fromgadget togadget -- loc )
|
||||||
2dup eq? [
|
2dup eq? [
|
||||||
2drop { 0 0 }
|
2drop { 0 0 }
|
||||||
] [
|
] [
|
||||||
over rect-loc >r
|
over rect-loc >r
|
||||||
>r gadget-parent r> relative-loc
|
>r parent>> r> relative-loc
|
||||||
r> v+
|
r> v+
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
@ -68,22 +68,18 @@ M: gadget user-input* 2drop t ;
|
||||||
|
|
||||||
GENERIC: children-on ( rect/point gadget -- seq )
|
GENERIC: children-on ( rect/point gadget -- seq )
|
||||||
|
|
||||||
M: gadget children-on nip gadget-children ;
|
M: gadget children-on nip children>> ;
|
||||||
|
|
||||||
: (fast-children-on) ( dim axis gadgets -- i )
|
: (fast-children-on) ( dim axis gadgets -- i )
|
||||||
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
|
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
|
||||||
|
|
||||||
: fast-children-on ( rect axis children -- from to )
|
: fast-children-on ( rect axis children -- from to )
|
||||||
3dup
|
[ >r >r rect-loc r> r> (fast-children-on) 0 or ]
|
||||||
>r >r dup rect-loc swap rect-dim v+
|
[ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
|
||||||
r> r> (fast-children-on) ?1+
|
3bi ;
|
||||||
>r
|
|
||||||
>r >r rect-loc
|
|
||||||
r> r> (fast-children-on) 0 or
|
|
||||||
r> ;
|
|
||||||
|
|
||||||
: inside? ( bounds gadget -- ? )
|
: inside? ( bounds gadget -- ? )
|
||||||
dup gadget-visible? [ intersects? ] [ 2drop f ] if ;
|
dup visible?>> [ intersects? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: (pick-up) ( point gadget -- gadget )
|
: (pick-up) ( point gadget -- gadget )
|
||||||
dupd children-on [ inside? ] with find-last nip ;
|
dupd children-on [ inside? ] with find-last nip ;
|
||||||
|
@ -97,10 +93,10 @@ M: gadget children-on nip gadget-children ;
|
||||||
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
|
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
|
||||||
|
|
||||||
: orient ( gadget seq1 seq2 -- seq )
|
: orient ( gadget seq1 seq2 -- seq )
|
||||||
>r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
|
>r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
|
||||||
|
|
||||||
: each-child ( gadget quot -- )
|
: each-child ( gadget quot -- )
|
||||||
>r gadget-children r> each ; inline
|
>r children>> r> each ; inline
|
||||||
|
|
||||||
! Selection protocol
|
! Selection protocol
|
||||||
GENERIC: gadget-selection? ( gadget -- ? )
|
GENERIC: gadget-selection? ( gadget -- ? )
|
||||||
|
@ -117,14 +113,14 @@ GENERIC: gadget-text* ( gadget -- )
|
||||||
GENERIC: gadget-text-separator ( gadget -- str )
|
GENERIC: gadget-text-separator ( gadget -- str )
|
||||||
|
|
||||||
M: gadget gadget-text-separator
|
M: gadget gadget-text-separator
|
||||||
gadget-orientation { 0 1 } = "\n" "" ? ;
|
orientation>> { 0 1 } = "\n" "" ? ;
|
||||||
|
|
||||||
: gadget-seq-text ( seq gadget -- )
|
: gadget-seq-text ( seq gadget -- )
|
||||||
gadget-text-separator swap
|
gadget-text-separator swap
|
||||||
[ dup % ] [ gadget-text* ] interleave drop ;
|
[ dup % ] [ gadget-text* ] interleave drop ;
|
||||||
|
|
||||||
M: gadget gadget-text*
|
M: gadget gadget-text*
|
||||||
dup gadget-children swap gadget-seq-text ;
|
dup children>> swap gadget-seq-text ;
|
||||||
|
|
||||||
M: array gadget-text*
|
M: array gadget-text*
|
||||||
[ gadget-text* ] each ;
|
[ gadget-text* ] each ;
|
||||||
|
@ -132,9 +128,9 @@ 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-layout-state ;
|
\ invalidate swap (>>layout-state) ;
|
||||||
|
|
||||||
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
|
: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
|
||||||
|
|
||||||
: layout-queue ( -- queue ) \ layout-queue get ;
|
: layout-queue ( -- queue ) \ layout-queue get ;
|
||||||
|
|
||||||
|
@ -147,22 +143,22 @@ M: array gadget-text*
|
||||||
DEFER: relayout
|
DEFER: relayout
|
||||||
|
|
||||||
: invalidate* ( gadget -- )
|
: invalidate* ( gadget -- )
|
||||||
\ invalidate* over set-gadget-layout-state
|
\ invalidate* over (>>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 ] [ parent>> [ relayout ] when* ] if ;
|
||||||
|
|
||||||
: relayout ( gadget -- )
|
: relayout ( gadget -- )
|
||||||
dup gadget-layout-state \ invalidate* eq?
|
dup layout-state>> \ invalidate* eq?
|
||||||
[ drop ] [ invalidate* ] if ;
|
[ drop ] [ invalidate* ] if ;
|
||||||
|
|
||||||
: relayout-1 ( gadget -- )
|
: relayout-1 ( gadget -- )
|
||||||
dup gadget-layout-state
|
dup layout-state>>
|
||||||
[ drop ] [ dup invalidate layout-later ] if ;
|
[ drop ] [ dup invalidate layout-later ] if ;
|
||||||
|
|
||||||
: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
|
: show-gadget ( gadget -- ) t swap (>>visible?) ;
|
||||||
|
|
||||||
: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
|
: hide-gadget ( gadget -- ) f swap (>>visible?) ;
|
||||||
|
|
||||||
: (set-rect-dim) ( dim gadget quot -- )
|
: (set-rect-dim) ( dim gadget quot -- )
|
||||||
>r 2dup rect-dim =
|
>r 2dup rect-dim =
|
||||||
|
@ -178,11 +174,11 @@ 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-layout-state
|
dup layout-state>>
|
||||||
[ 2drop ] [ set-gadget-pref-dim ] if ;
|
[ 2drop ] [ (>>pref-dim) ] if ;
|
||||||
|
|
||||||
: pref-dim ( gadget -- dim )
|
: pref-dim ( gadget -- dim )
|
||||||
dup gadget-pref-dim [ ] [
|
dup pref-dim>> [ ] [
|
||||||
[ pref-dim* dup ] keep ?set-gadget-pref-dim
|
[ pref-dim* dup ] keep ?set-gadget-pref-dim
|
||||||
] ?if ;
|
] ?if ;
|
||||||
|
|
||||||
|
@ -196,10 +192,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-layout-state ;
|
: validate ( gadget -- ) f swap (>>layout-state) ;
|
||||||
|
|
||||||
: layout ( gadget -- )
|
: layout ( gadget -- )
|
||||||
dup gadget-layout-state [
|
dup layout-state>> [
|
||||||
dup validate
|
dup validate
|
||||||
dup layout*
|
dup layout*
|
||||||
dup [ layout ] each-child
|
dup [ layout ] each-child
|
||||||
|
@ -223,7 +219,7 @@ M: gadget layout* drop ;
|
||||||
{ t f } (queue-graft) ;
|
{ t f } (queue-graft) ;
|
||||||
|
|
||||||
: graft-later ( gadget -- )
|
: graft-later ( gadget -- )
|
||||||
dup gadget-graft-state {
|
dup graft-state>> {
|
||||||
{ { f t } [ drop ] }
|
{ { f t } [ drop ] }
|
||||||
{ { t t } [ drop ] }
|
{ { t t } [ drop ] }
|
||||||
{ { t f } [ unqueue-graft ] }
|
{ { t f } [ unqueue-graft ] }
|
||||||
|
@ -231,7 +227,7 @@ M: gadget layout* drop ;
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: ungraft-later ( gadget -- )
|
: ungraft-later ( gadget -- )
|
||||||
dup gadget-graft-state {
|
dup graft-state>> {
|
||||||
{ { f f } [ drop ] }
|
{ { f f } [ drop ] }
|
||||||
{ { t f } [ drop ] }
|
{ { t f } [ drop ] }
|
||||||
{ { f t } [ unqueue-graft ] }
|
{ { f t } [ unqueue-graft ] }
|
||||||
|
@ -255,11 +251,11 @@ M: gadget ungraft* drop ;
|
||||||
: (unparent) ( gadget -- )
|
: (unparent) ( gadget -- )
|
||||||
dup ungraft
|
dup ungraft
|
||||||
dup forget-pref-dim
|
dup forget-pref-dim
|
||||||
f swap set-gadget-parent ;
|
f swap (>>parent) ;
|
||||||
|
|
||||||
: unfocus-gadget ( child gadget -- )
|
: unfocus-gadget ( child gadget -- )
|
||||||
tuck gadget-focus eq?
|
tuck focus>> eq?
|
||||||
[ f swap set-gadget-focus ] [ drop ] if ;
|
[ f swap (>>focus) ] [ drop ] if ;
|
||||||
|
|
||||||
SYMBOL: in-layout?
|
SYMBOL: in-layout?
|
||||||
|
|
||||||
|
@ -270,10 +266,10 @@ SYMBOL: in-layout?
|
||||||
: unparent ( gadget -- )
|
: unparent ( gadget -- )
|
||||||
not-in-layout
|
not-in-layout
|
||||||
[
|
[
|
||||||
dup gadget-parent dup [
|
dup parent>> dup [
|
||||||
over (unparent)
|
over (unparent)
|
||||||
[ unfocus-gadget ] 2keep
|
[ unfocus-gadget ] 2keep
|
||||||
[ gadget-children delete ] keep
|
[ children>> delete ] keep
|
||||||
relayout
|
relayout
|
||||||
] [
|
] [
|
||||||
2drop
|
2drop
|
||||||
|
@ -282,21 +278,21 @@ SYMBOL: in-layout?
|
||||||
|
|
||||||
: (clear-gadget) ( gadget -- )
|
: (clear-gadget) ( gadget -- )
|
||||||
dup [ (unparent) ] each-child
|
dup [ (unparent) ] each-child
|
||||||
f over set-gadget-focus
|
f over (>>focus)
|
||||||
f swap set-gadget-children ;
|
f swap (>>children) ;
|
||||||
|
|
||||||
: clear-gadget ( gadget -- )
|
: clear-gadget ( gadget -- )
|
||||||
not-in-layout
|
not-in-layout
|
||||||
dup (clear-gadget) relayout ;
|
dup (clear-gadget) relayout ;
|
||||||
|
|
||||||
: ((add-gadget)) ( gadget box -- )
|
: ((add-gadget)) ( gadget box -- )
|
||||||
[ gadget-children ?push ] keep set-gadget-children ;
|
[ children>> ?push ] keep (>>children) ;
|
||||||
|
|
||||||
: (add-gadget) ( gadget box -- )
|
: (add-gadget) ( gadget box -- )
|
||||||
over unparent
|
over unparent
|
||||||
dup pick set-gadget-parent
|
dup pick (>>parent)
|
||||||
[ ((add-gadget)) ] 2keep
|
[ ((add-gadget)) ] 2keep
|
||||||
gadget-graft-state second [ graft ] [ drop ] if ;
|
graft-state>> second [ graft ] [ drop ] if ;
|
||||||
|
|
||||||
: add-gadget ( gadget parent -- )
|
: add-gadget ( gadget parent -- )
|
||||||
not-in-layout
|
not-in-layout
|
||||||
|
@ -307,7 +303,7 @@ SYMBOL: in-layout?
|
||||||
swap [ over (add-gadget) ] each relayout ;
|
swap [ over (add-gadget) ] each relayout ;
|
||||||
|
|
||||||
: parents ( gadget -- seq )
|
: parents ( gadget -- seq )
|
||||||
[ gadget-parent ] follow ;
|
[ parent>> ] follow ;
|
||||||
|
|
||||||
: each-parent ( gadget quot -- ? )
|
: each-parent ( gadget quot -- ? )
|
||||||
>r parents r> all? ; inline
|
>r parents r> all? ; inline
|
||||||
|
@ -319,7 +315,7 @@ SYMBOL: in-layout?
|
||||||
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
||||||
|
|
||||||
: (screen-rect) ( gadget -- loc ext )
|
: (screen-rect) ( gadget -- loc ext )
|
||||||
dup gadget-parent [
|
dup parent>> [
|
||||||
>r rect-extent r> (screen-rect)
|
>r rect-extent r> (screen-rect)
|
||||||
>r tuck v+ r> vmin >r v+ r>
|
>r tuck v+ r> vmin >r v+ r>
|
||||||
] [
|
] [
|
||||||
|
@ -333,7 +329,7 @@ SYMBOL: in-layout?
|
||||||
{
|
{
|
||||||
{ [ 2dup eq? ] [ 2drop t ] }
|
{ [ 2dup eq? ] [ 2drop t ] }
|
||||||
{ [ dup not ] [ 2drop f ] }
|
{ [ dup not ] [ 2drop f ] }
|
||||||
[ gadget-parent child? ]
|
[ parent>> child? ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
GENERIC: focusable-child* ( gadget -- child/t )
|
GENERIC: focusable-child* ( gadget -- child/t )
|
||||||
|
@ -346,7 +342,7 @@ M: gadget focusable-child* drop t ;
|
||||||
|
|
||||||
GENERIC: request-focus-on ( child gadget -- )
|
GENERIC: request-focus-on ( child gadget -- )
|
||||||
|
|
||||||
M: gadget request-focus-on gadget-parent request-focus-on ;
|
M: gadget request-focus-on parent>> request-focus-on ;
|
||||||
|
|
||||||
M: f request-focus-on 2drop ;
|
M: f request-focus-on 2drop ;
|
||||||
|
|
||||||
|
@ -354,7 +350,7 @@ M: f request-focus-on 2drop ;
|
||||||
[ focusable-child ] keep request-focus-on ;
|
[ focusable-child ] keep request-focus-on ;
|
||||||
|
|
||||||
: focus-path ( world -- seq )
|
: focus-path ( world -- seq )
|
||||||
[ gadget-focus ] follow ;
|
[ focus>> ] follow ;
|
||||||
|
|
||||||
: gadget, ( gadget -- ) gadget get add-gadget ;
|
: gadget, ( gadget -- ) gadget get add-gadget ;
|
||||||
|
|
||||||
|
@ -371,7 +367,7 @@ M: f request-focus-on 2drop ;
|
||||||
! Deprecated
|
! Deprecated
|
||||||
: set-gadget-delegate ( gadget tuple -- )
|
: set-gadget-delegate ( gadget tuple -- )
|
||||||
over [
|
over [
|
||||||
dup pick [ set-gadget-parent ] with each-child
|
dup pick [ (>>parent) ] with each-child
|
||||||
] when set-delegate ;
|
] when set-delegate ;
|
||||||
|
|
||||||
: construct-gadget ( class -- tuple )
|
: construct-gadget ( class -- tuple )
|
||||||
|
|
Loading…
Reference in New Issue