extra/ui/frp/frp.factor

   1 USING: accessors arrays colors fonts fry generalizations kernel
   2 lexer macros math math.parser models models.product monads
   3 sequences ui.gadgets ui.gadgets.buttons ui.gadgets.buttons.private
   4 ui.gadgets.editors ui.gadgets.scrollers ui.gadgets.tables
   5 ui.gadgets.tracks ;
   6 QUALIFIED: make
   7 IN: ui.frp
   8
   9 ! !!! Model utilities
  10 TUPLE: multi-model < model ;
  11 GENERIC: (model-changed) ( model observer -- )
  12 : <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
  13 M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
  14 M: multi-model model-activated dup dependencies>> dup length 1 =
  15    [ first swap model-changed ] [ 2drop ] if ;
  16
  17 TUPLE: basic-model < multi-model ;
  18 M: basic-model (model-changed) [ value>> ] dip set-model ;
  19 : <merge> ( models -- model ) basic-model <multi-model> ;
  20 : <basic> ( value -- model ) basic-model new-model ;
  21
  22 TUPLE: filter-model < multi-model quot ;
  23 M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
  24    [ set-model ] [ 2drop ] if ;
  25 : <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
  26
  27 TUPLE: fold-model < multi-model oldval quot ;
  28 M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
  29    call( val oldval -- newval ) ] keep set-model ;
  30 : <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
  31    swap [ >>oldval ] [ >>value ] bi ;
  32
  33 TUPLE: updater-model < multi-model values updates ;
  34 M: updater-model (model-changed) tuck updates>> =
  35    [ [ values>> value>> ] keep set-model ]
  36    [ drop ] if ;
  37 : <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
  38    [ >>values ] [ >>updates ] bi* ;
  39
  40 TUPLE: switch-model < multi-model original switcher on ;
  41 M: switch-model (model-changed) 2dup switcher>> =
  42    [ [ value>> ] [ t >>on ] bi* set-model ]
  43    [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
  44 : <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
  45    [ >>original ] [ >>switcher ] bi* ;
  46 M: switch-model model-activated [ original>> ] keep model-changed ;
  47
  48 TUPLE: mapped-model < multi-model model quot ;
  49 : new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
  50    <multi-model> swap >>quot swap >>model ;
  51 : <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
  52 M: mapped-model (model-changed)
  53     [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
  54     set-model ;
  55
  56 TUPLE: side-effect-model < mapped-model ;
  57 M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
  58 : $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
  59
  60 TUPLE: quot-model < mapped-model ;
  61 M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
  62 : <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
  63
  64 TUPLE: frp-product < multi-model ;
  65 : <frp-product> ( models -- product ) frp-product <multi-model> ;
  66 M: frp-product model-changed
  67     nip
  68     dup dependencies>> [ value>> ] all?
  69     [ dup [ value>> ] product-value >>value notify-connections
  70     ] [ drop ] if ;
  71 M: frp-product update-model
  72     dup value>> swap [ set-model ] set-product-value ;
  73 M: frp-product model-activated dup model-changed ;
  74
  75 TUPLE: action-value < basic-model parent ;
  76 : <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
  77 M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
  78
  79 ! Update at start
  80 TUPLE: action < multi-model quot ;
  81 M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
  82    [ swap add-connection ] 2keep model-changed ;
  83 : <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
  84
  85 ! Gadgets
  86 TUPLE: frp-button < button hook ;
  87 : <frp-button> ( text -- button ) [
  88       [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
  89       t swap set-control-value
  90    ] frp-button new-button border-button-theme f <basic> >>model ;
  91
  92 TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
  93 M: frp-table column-titles column-titles>> ;
  94 M: frp-table column-alignment column-alignment>> ;
  95 M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
  96 M: frp-table row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  97 M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  98
  99 : <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
 100    V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
 101 : <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
 102 : <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
 103 : <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
 104 : indexed ( table -- table ) f >>val-quot ;
 105
 106 : <frp-field> ( -- field ) "" <model> <model-field> ;
 107
 108 ! Layout utilities
 109 TUPLE: layout gadget width ; C: <layout> layout
 110
 111 GENERIC: output-model ( gadget -- model )
 112 M: gadget output-model model>> ;
 113 M: table output-model dup multiple-selection?>>
 114    [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
 115    [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
 116 M: model-field output-model field-model>> ;
 117 M: scroller output-model viewport>> children>> first output-model ;
 118
 119 GENERIC: , ( uiitem -- )
 120 M: gadget , f <layout> make:, ;
 121 M: model , activate-model ;
 122
 123 SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
 124 SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
 125
 126 GENERIC: -> ( uiitem -- model )
 127 M: gadget -> dup , output-model ;
 128 M: model -> dup , ;
 129
 130 : <spacer> ( -- ) <gadget> 1 <layout> make:, ;
 131 : <box> ( gadgets type -- track )
 132    [ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
 133 : <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
 134 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
 135 : <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
 136 : <vbox> ( gadgets -- track ) vertical <box> ; inline
 137 : <vbox*> ( gadgets -- track ) vertical <box*> ; inline
 138
 139 ! Instances
 140 M: model fmap <mapped> ;
 141 M: model >>= [ swap <action> ] curry ;
 142
 143 SINGLETON: gadget-monad
 144 INSTANCE: gadget-monad monad
 145 INSTANCE: gadget monad
 146 M: gadget monad-of drop gadget-monad ;
 147 M: gadget-monad return drop <gadget> swap >>model ;
 148 M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
 149
 150 ! Macros
 151 : lift ( int -- quot ) dup
 152    '[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend ] ; inline
 153
 154 MACRO: liftA-n ( int -- quot ) lift [ <mapped> ] append ;
 155
 156 MACRO: $>-n ( int -- quot ) lift [ $> ] append ;
 157
 158 MACRO: <$-n ( int -- quot ) lift [ <$ ] append ;
 159
 160 : liftA2 ( a b quot -- arrow ) 2 liftA-n ; inline
 161 : liftA3 ( a b c quot -- arrow ) 3 liftA-n ; inline
 162
 163 : $>2 ( a b quot -- arrow ) 2 $>-n ; inline
 164 : $>3 ( a b c quot -- arrow ) 3 $>-n ; inline
 165
 166 : <$2 ( a b quot -- arrow ) 2 <$-n ; inline
 167 : <$3 ( a b c quot -- arrow ) 3 <$-n ; inline