basis/models/models.factor

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