extra/ui/frp/signals/signals.factor

   1 USING: accessors arrays kernel models models.product sequences ;
   2 IN: ui.frp.signals
   3
   4 TUPLE: multi-model < model ;
   5 GENERIC: (model-changed) ( model observer -- )
   6 : <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
   7 M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
   8 M: multi-model model-activated dup dependencies>> dup length 1 =
   9    [ first swap model-changed ] [ 2drop ] if ;
  10
  11 TUPLE: basic-model < multi-model ;
  12 M: basic-model (model-changed) [ value>> ] dip set-model ;
  13 : <merge> ( models -- model ) basic-model <multi-model> ;
  14 : <basic> ( value -- model ) basic-model new-model ;
  15
  16 TUPLE: filter-model < multi-model quot ;
  17 M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
  18    [ set-model ] [ 2drop ] if ;
  19 : <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
  20
  21 TUPLE: fold-model < multi-model oldval quot ;
  22 M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
  23    call( val oldval -- newval ) ] keep set-model ;
  24 : <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
  25    swap [ >>oldval ] [ >>value ] bi ;
  26
  27 TUPLE: updater-model < multi-model values updates ;
  28 M: updater-model (model-changed) tuck updates>> =
  29    [ [ values>> value>> ] keep set-model ]
  30    [ drop ] if ;
  31 : <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
  32    [ >>values ] [ >>updates ] bi* ;
  33
  34 TUPLE: switch-model < multi-model original switcher on ;
  35 M: switch-model (model-changed) 2dup switcher>> =
  36    [ [ value>> ] [ t >>on ] bi* set-model ]
  37    [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
  38 : <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
  39    [ >>original ] [ >>switcher ] bi* ;
  40 M: switch-model model-activated [ original>> ] keep model-changed ;
  41
  42 TUPLE: mapped-model < multi-model model quot ;
  43 : new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
  44    <multi-model> swap >>quot swap >>model ;
  45 : <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
  46 M: mapped-model (model-changed)
  47     [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
  48     set-model ;
  49
  50 TUPLE: side-effect-model < mapped-model ;
  51 M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
  52 : $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
  53
  54 TUPLE: quot-model < mapped-model ;
  55 M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
  56 : <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
  57
  58 TUPLE: action-value < basic-model parent ;
  59 : <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
  60 M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
  61
  62 TUPLE: action < multi-model quot ;
  63 M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
  64    [ swap add-connection ] 2keep model-changed ;
  65 : <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
  66
  67 TUPLE: | < multi-model ;
  68 : <|> ( models -- product ) | <multi-model> ;
  69 M: | model-changed
  70     nip
  71     dup dependencies>> [ value>> ] all?
  72     [ dup [ value>> ] product-value >>value notify-connections
  73     ] [ drop ] if ;
  74 M: | update-model
  75     dup value>> swap [ set-model ] set-product-value ;
  76 M: | model-activated dup model-changed ;
  77
  78 TUPLE: & < | ;
  79 : <&> ( models -- product ) & <multi-model> ;
  80 M: & model-changed [ call-next-method ] keep
  81    [ dependencies>> [ f swap set-model ] each ] with-locked-model ;