basis/models/models.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors continuations kernel math math.order sequences ;
   4 IN: models
   5
   6 TUPLE: model < identity-tuple
   7 value connections dependencies ref locked? ;
   8
   9 : new-model ( value class -- model )
  10     new
  11         swap >>value
  12         V{ } clone >>connections
  13         V{ } clone >>dependencies
  14         0 >>ref ; inline
  15
  16 : <model> ( value -- model )
  17     model new-model ;
  18
  19 : add-dependency ( dep model -- )
  20     dependencies>> push ;
  21
  22 : remove-dependency ( dep model -- )
  23     dependencies>> remove! drop ;
  24
  25 DEFER: add-connection
  26
  27 GENERIC: model-activated ( model -- )
  28
  29 M: model model-activated drop ;
  30
  31 : ref-model ( model -- n )
  32     [ 1 + dup ] change-ref drop ;
  33
  34 : unref-model ( model -- n )
  35     [ 1 - dup ] change-ref drop ;
  36
  37 : activate-model ( model -- )
  38     dup ref-model 1 = [
  39         dup dependencies>>
  40         [ dup activate-model dupd add-connection ] each
  41         model-activated
  42     ] [
  43         drop
  44     ] if ;
  45
  46 DEFER: remove-connection
  47
  48 : deactivate-model ( model -- )
  49     dup unref-model zero? [
  50         dup dependencies>>
  51         [ dup deactivate-model remove-connection ] with each
  52     ] [
  53         drop
  54     ] if ;
  55
  56 : compute-model ( model -- value )
  57     [ activate-model ] [ deactivate-model ] [ value>> ] tri ;
  58
  59 GENERIC: model-changed ( model observer -- )
  60 M: object model-changed 2drop ;
  61
  62 : add-connection ( observer model -- )
  63     dup connections>>
  64     [ empty? [ activate-model ] [ drop ] if ]
  65     [ push ] bi ;
  66
  67 : remove-connection ( observer model -- )
  68     [ connections>> remove! ] keep swap
  69     empty? [ deactivate-model ] [ drop ] if ;
  70
  71 : with-locked-model ( model quot -- )
  72     [ '[ _ t >>locked? @ ] ]
  73     [ drop '[ f _ locked?<< ] ]
  74     2bi finally ; inline
  75
  76 GENERIC: update-model ( model -- )
  77
  78 M: model update-model drop ;
  79
  80 : notify-connections ( model -- )
  81     dup connections>> [ model-changed ] with each ;
  82
  83 : set-model ( value model -- )
  84     dup locked?>> [
  85         2drop
  86     ] [
  87         [
  88             swap >>value
  89             [ update-model ] [ notify-connections ] bi
  90         ] with-locked-model
  91     ] if ;
  92
  93 : ?set-model ( value model -- )
  94     2dup value>> = [ 2drop ] [ set-model ] if ;
  95
  96 : call-change-model ( model quot -- newvalue model )
  97     over [ [ value>> ] dip call ] dip ; inline
  98
  99 : change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
 100     call-change-model set-model ; inline
 101
 102 : (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
 103     call-change-model value<< ; inline
 104
 105 GENERIC: range-value ( model -- value )
 106 GENERIC: range-page-value ( model -- value )
 107 GENERIC: range-min-value ( model -- value )
 108 GENERIC: range-max-value ( model -- value )
 109 GENERIC: range-max-value* ( model -- value )
 110 GENERIC: set-range-value ( value model -- )
 111 GENERIC: set-range-page-value ( value model -- )
 112 GENERIC: set-range-min-value ( value model -- )
 113 GENERIC: set-range-max-value ( value model -- )
 114
 115 : clamp-value ( value range -- newvalue )
 116     [ range-min-value ] [ range-max-value* ] bi clamp ;
 117
 118 : change-model* ( ..a model quot: ( ..a obj -- ..b ) -- ..b )
 119     '[ _ keep ] change-model ; inline
 120
 121 : push-model ( value model -- )
 122     [ push ] change-model* ;
 123
 124 : pop-model ( model -- value )
 125     [ pop ] change-model* ;