extra/ui/frp/signals/signals.factor

   1 USING: accessors arrays kernel models models.product monads
   2 sequences sequences.extras ;
   3 FROM: syntax => >> ;
   4 IN: ui.frp.signals
   5
   6 TUPLE: multi-model < model important? ;
   7 GENERIC: (model-changed) ( model observer -- )
   8 : <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
   9 M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
  10 M: multi-model model-activated dup dependencies>> [ value>> ] find nip
  11    [ swap model-changed ] [ drop ] if* ;
  12
  13 : #1 ( model -- model' ) t >>important? ;
  14
  15 IN: models
  16 : notify-connections ( model -- )
  17     dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all
  18     [ second tuck [ remove ] dip prefix ] each
  19     [ model-changed ] with each ;
  20 IN: ui.frp.signals
  21
  22 TUPLE: basic-model < multi-model ;
  23 M: basic-model (model-changed) [ value>> ] dip set-model ;
  24 : <merge> ( models -- signal ) basic-model <multi-model> ;
  25 : <2merge> ( model1 model2 -- signal ) 2array <merge> ;
  26 : <basic> ( value -- signal ) basic-model new-model ;
  27
  28 TUPLE: filter-model < multi-model quot ;
  29 M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
  30    [ set-model ] [ 2drop ] if ;
  31 : <filter> ( model quot -- filter-signal ) [ 1array filter-model <multi-model> ] dip >>quot ;
  32
  33 TUPLE: fold-model < multi-model quot base values ;
  34 M: fold-model (model-changed) 2dup base>> =
  35     [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
  36     [ [ [ value>> ] [ values>> ] bi* push ]
  37       [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
  38     ] if ;
  39 M: fold-model model-activated drop ;
  40 : new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
  41 : <fold> ( model oldval quot -- signal ) rot 1array new-fold-model swap >>quot
  42    swap >>value ;
  43 : <fold*> ( model oldmodel quot -- signal ) over [ [ 2array new-fold-model ] dip >>quot ]
  44     dip [ >>base ] [ value>> >>value ] bi ;
  45
  46 TUPLE: updater-model < multi-model values updates ;
  47 M: updater-model (model-changed) [ tuck updates>> =
  48    [ [ values>> value>> ] keep set-model ]
  49    [ drop ] if ] keep f swap (>>value) ;
  50 : <updates> ( values updates -- signal ) [ 2array updater-model <multi-model> ] 2keep
  51    [ >>values ] [ >>updates ] bi* ;
  52
  53 SYMBOL: switch
  54 TUPLE: switch-model < multi-model original switcher on ;
  55 M: switch-model (model-changed) 2dup switcher>> =
  56    [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ]
  57    [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
  58 : <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep
  59    [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
  60 M: switch-model model-activated [ original>> ] keep model-changed ;
  61 : >behavior ( event -- behavior ) t >>value ;
  62
  63 TUPLE: mapped-model < multi-model model quot ;
  64 : new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
  65    <multi-model> swap >>quot swap >>model ;
  66 : <mapped> ( model quot -- signal ) mapped-model new-mapped-model ;
  67 M: mapped-model (model-changed)
  68     [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
  69     set-model ;
  70
  71 TUPLE: side-effect-model < mapped-model ;
  72 M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
  73
  74 : $> ( model quot -- signal ) side-effect-model new-mapped-model ;
  75
  76 TUPLE: quot-model < mapped-model ;
  77 M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
  78 M: model <$ quot-model new-mapped-model ;
  79
  80 TUPLE: action-value < basic-model parent ;
  81 : <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
  82 M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
  83
  84 TUPLE: action < multi-model quot ;
  85 M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
  86    [ swap add-connection ] 2keep model-changed ;
  87 : <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
  88
  89 TUPLE: collection < multi-model ;
  90 : <collection> ( models -- product ) collection <multi-model> ;
  91 M: collection (model-changed)
  92     nip
  93     dup dependencies>> [ value>> ] all?
  94     [ dup [ value>> ] product-value swap set-model ]
  95     [ drop ] if ;
  96 M: collection model-activated dup (model-changed) ;
  97
  98 ! for side effects
  99 TUPLE: (frp-when) < multi-model quot cond ;
 100 : frp-when ( model quot cond -- model ) rot 1array (frp-when) <multi-model> swap >>cond swap >>quot ;
 101 M: (frp-when) (model-changed) [ quot>> ] 2keep
 102     [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
 103
 104 ! only used in construction
 105 : with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
 106
 107 USE: ui.frp.signals.templates
 108 M: model fmap <mapped> ;
 109 << { "$>" "<$" "fmap" } [ fmaps ] each >>