core/ui/models.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: models
   4 USING: generic kernel math sequences timers ;
   5
   6 TUPLE: model value connections dependencies ref ;
   7
   8 C: model ( value -- model )
   9     [ set-model-value ] keep
  10     V{ } clone over set-model-connections
  11     V{ } clone over set-model-dependencies
  12     0 over set-model-ref ;
  13
  14 M: model equal? eq? ;
  15
  16 : add-dependency ( dep model -- )
  17     model-dependencies push ;
  18
  19 : remove-dependency ( dep model -- )
  20     model-dependencies delete ;
  21
  22 DEFER: add-connection
  23
  24 GENERIC: model-activated ( model -- )
  25
  26 M: model model-activated drop ;
  27
  28 : ref-model ( model -- n )
  29     dup model-ref 1+ dup rot set-model-ref ;
  30
  31 : unref-model ( model -- n )
  32     dup model-ref 1- dup rot set-model-ref ;
  33
  34 : activate-model ( model -- )
  35     dup ref-model 1 = [
  36         dup model-dependencies
  37         [ dup activate-model dupd add-connection ] each
  38         model-activated
  39     ] [
  40         drop
  41     ] if ;
  42
  43 DEFER: remove-connection
  44
  45 : deactivate-model ( model -- )
  46     dup unref-model zero? [
  47         dup model-dependencies
  48         [ dup deactivate-model remove-connection ] each-with
  49     ] [
  50         drop
  51     ] if ;
  52
  53 GENERIC: model-changed ( observer -- )
  54
  55 : add-connection ( observer model -- )
  56     dup model-connections empty? [ dup activate-model ] when
  57     model-connections push ;
  58
  59 : remove-connection ( observer model -- )
  60     [ model-connections delete ] keep
  61     dup model-connections empty? [ dup deactivate-model ] when
  62     drop ;
  63
  64 GENERIC: set-model ( value model -- )
  65
  66 M: model set-model
  67     [ set-model-value ] keep
  68     model-connections [ model-changed ] each ;
  69
  70 : ((change-model)) ( model quot -- newvalue model )
  71     over >r >r model-value r> call r> ; inline
  72
  73 : change-model ( model quot -- )
  74     ((change-model)) set-model ; inline
  75
  76 : (change-model) ( model quot -- )
  77     ((change-model)) set-model-value ; inline
  78
  79 : delegate>model ( tuple -- )
  80     f <model> swap set-delegate ;
  81
  82 TUPLE: filter model quot ;
  83
  84 C: filter ( model quot -- filter )
  85     dup delegate>model
  86     [ set-filter-quot ] keep
  87     [ set-filter-model ] 2keep
  88     [ add-dependency ] keep ;
  89
  90 M: filter model-changed
  91     dup filter-model model-value over filter-quot call
  92     swap set-model ;
  93
  94 M: filter model-activated model-changed ;
  95
  96 TUPLE: compose ;
  97
  98 C: compose ( models -- compose )
  99     dup delegate>model
 100     swap clone over set-model-dependencies ;
 101
 102 M: compose model-changed
 103     dup model-dependencies [ model-value ] map
 104     swap delegate set-model ;
 105
 106 M: compose model-activated model-changed ;
 107
 108 M: compose set-model
 109     model-dependencies [ set-model ] 2each ;
 110
 111 TUPLE: history back forward ;
 112
 113 C: history ( value -- history )
 114     [ >r <model> r> set-delegate ] keep
 115     V{ } clone over set-history-back
 116     V{ } clone over set-history-forward ;
 117
 118 : (add-history)
 119     swap model-value dup [ swap push ] [ 2drop ] if ;
 120
 121 : go-back/forward ( history to from -- )
 122     dup empty?
 123     [ 3drop ]
 124     [ >r dupd (add-history) r> pop swap set-model ] if ;
 125
 126 : go-back ( history -- )
 127     dup history-forward over history-back go-back/forward ;
 128
 129 : go-forward ( history -- )
 130     dup history-back over history-forward go-back/forward ;
 131
 132 : add-history ( history -- )
 133     dup history-forward delete-all
 134     dup history-back (add-history) ;
 135
 136 TUPLE: delay model timeout ;
 137
 138 : update-delay-model ( delay -- )
 139     dup delay-model model-value swap set-model ;
 140
 141 C: delay ( model timeout -- filter )
 142     dup delegate>model
 143     [ set-delay-timeout ] keep
 144     [ set-delay-model ] 2keep
 145     [ add-dependency ] keep
 146     dup update-delay-model ;
 147
 148 M: delay model-changed 0 over delay-timeout add-timer ;
 149
 150 M: delay model-activated update-delay-model ;
 151
 152 M: delay tick dup remove-timer update-delay-model ;