diff --git a/extra/models/mapped/mapped.factor b/extra/models/mapped/mapped.factor deleted file mode 100644 index 698da935e5..0000000000 --- a/extra/models/mapped/mapped.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: macros ui.frp fry -generalizations kernel sequences ; -IN: models.mapped - -MACRO: ( int -- quot ) dup - '[ [ _ narray ] dip [ _ firstn ] prepend ] ; - -: <2mapped> ( a b quot -- arrow ) 2 ; inline -: <3mapped> ( a b c quot -- arrow ) 3 ; inline \ No newline at end of file diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index 4f9f2da139..f59361a0ec 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,8 +1,8 @@ -USING: accessors arrays colors fonts fry kernel math models -models.product monads sequences ui.gadgets ui.gadgets.buttons -ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ui.gadgets.scrollers -math.parser lexer ; +USING: accessors arrays colors fonts fry generalizations kernel +lexer macros math math.parser models models.product monads +sequences ui.gadgets ui.gadgets.buttons ui.gadgets.buttons.private +ui.gadgets.editors ui.gadgets.line-support ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.render ; QUALIFIED: make IN: ui.frp @@ -56,6 +56,14 @@ M: mapped-model (model-changed) set-model ; M: mapped-model model-activated [ model>> ] keep model-changed ; +TUPLE: side-effect-model < mapped-model ; +M: side-effect-model (model-changed) [ value>> ] [ quot>> ] bi* call( old -- ) ; +: <$ ( model quot -- side-effect-model ) + f side-effect-model new-model + swap >>quot + over >>model + [ add-dependency ] keep ; + TUPLE: frp-product < multi-model ; : ( models -- product ) frp-product ; M: frp-product model-changed @@ -68,7 +76,11 @@ M: frp-product update-model M: frp-product model-activated dup model-changed ; ! Gadgets -: ( text -- button ) [ t swap set-control-value ] f >>model ; +TUPLE: frp-button < button hook ; +: ( text -- button ) [ [ t swap set-control-value ] keep + dup hook>> [ call( button -- ) ] [ drop ] if* ] + frp-button new-button border-button-theme f >>model ; + TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ; M: frp-table column-titles column-titles>> ; M: frp-table column-alignment column-alignment>> ; @@ -124,4 +136,18 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; + +! Macros + +MACRO: liftA-n ( int -- quot ) dup + '[ [ _ narray ] dip [ _ firstn ] prepend ] ; + +MACRO: <$-n ( int -- quot ) dup + '[ [ _ narray ] dip [ _ firstn ] prepend <$ ] ; + +: liftA2 ( a b quot -- arrow ) 2 liftA-n ; inline +: liftA3 ( a b c quot -- arrow ) 3 liftA-n ; inline + +: <$2 ( a b quot -- arrow ) 2 <$-n ; inline +: <$3 ( a b c quot -- arrow ) 3 <$-n ; inline \ No newline at end of file diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor index ec8335e0d3..0c4a4fbd67 100644 --- a/extra/ui/gadgets/alerts/alerts.factor +++ b/extra/ui/gadgets/alerts/alerts.factor @@ -11,5 +11,5 @@ IN: ui.gadgets.alerts fldm [ ->% 1 ] btn [ "okay" ] | btn -> [ fldm swap ] - [ [ drop lbl close-window f ] , ] bi + [ [ drop lbl close-window ] <$ , ] bi ] ] { 161 86 } >>pref-dim "" open-window ; \ No newline at end of file