alerts: "ask-user" added (uses functors)
parent
99a1119e3c
commit
a16f96447f
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: macros ui.frp models.product fry
|
USING: macros ui.frp fry
|
||||||
generalizations kernel sequences ;
|
generalizations kernel sequences ;
|
||||||
IN: models.mapped
|
IN: models.mapped
|
||||||
|
|
||||||
MACRO: <n-mapped> ( int -- quot ) dup
|
MACRO: <n-mapped> ( int -- quot ) dup
|
||||||
'[ [ _ narray <product> ] dip [ _ firstn ] prepend <mapped> ] ;
|
'[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend <mapped> ] ;
|
||||||
|
|
||||||
: <2mapped> ( a b quot -- arrow ) 2 <n-mapped> ; inline
|
: <2mapped> ( a b quot -- arrow ) 2 <n-mapped> ; inline
|
||||||
: <3mapped> ( a b c quot -- arrow ) 3 <n-mapped> ; inline
|
: <3mapped> ( a b c quot -- arrow ) 3 <n-mapped> ; inline
|
|
@ -56,6 +56,16 @@ M: mapped-model (model-changed)
|
||||||
set-model ;
|
set-model ;
|
||||||
M: mapped-model model-activated [ model>> ] keep model-changed ;
|
M: mapped-model model-activated [ model>> ] keep model-changed ;
|
||||||
|
|
||||||
|
TUPLE: frp-product < multi-model ;
|
||||||
|
: <frp-product> ( models -- product ) frp-product <multi-model> ;
|
||||||
|
M: frp-product model-changed
|
||||||
|
nip
|
||||||
|
dup dependencies>> [ value>> ] all?
|
||||||
|
[ dup [ value>> ] product-value >>value notify-connections
|
||||||
|
] [ drop ] if ;
|
||||||
|
M: frp-product update-model
|
||||||
|
dup value>> swap [ set-model ] set-product-value ;
|
||||||
|
M: frp-product model-activated dup model-changed ;
|
||||||
|
|
||||||
! Gadgets
|
! Gadgets
|
||||||
: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <basic> >>model ;
|
: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <basic> >>model ;
|
||||||
|
|
|
@ -1,4 +1,15 @@
|
||||||
USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
|
USING: accessors kernel ui ui.frp ui.gadgets ui.gadgets.labels
|
||||||
|
ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
|
||||||
|
|
||||||
IN: ui.gadgets.alerts
|
IN: ui.gadgets.alerts
|
||||||
:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
|
:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
|
||||||
|
string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
|
||||||
"okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
|
"okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
|
||||||
|
|
||||||
|
: ask-user ( string -- model )
|
||||||
|
[ [let | lbl [ <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
|
||||||
|
fldm [ <frp-field> ->% 1 ]
|
||||||
|
btn [ "okay" <frp-button> ] |
|
||||||
|
btn -> [ fldm swap <updates> ]
|
||||||
|
[ [ drop lbl close-window f ] <mapped> , ] bi
|
||||||
|
] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
|
Loading…
Reference in New Issue