extra/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 alarms calendar math.order ;
   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 M: model hashcode* drop model hashcode* ;
  21
  22 : add-dependency ( dep model -- )
  23     model-dependencies push ;
  24
  25 : remove-dependency ( dep model -- )
  26     model-dependencies delete ;
  27
  28 DEFER: add-connection
  29
  30 GENERIC: model-activated ( model -- )
  31
  32 M: model model-activated drop ;
  33
  34 : ref-model ( model -- n )
  35     dup model-ref 1+ dup rot set-model-ref ;
  36
  37 : unref-model ( model -- n )
  38     dup model-ref 1- dup rot set-model-ref ;
  39
  40 : activate-model ( model -- )
  41     dup ref-model 1 = [
  42         dup model-dependencies
  43         [ dup activate-model dupd add-connection ] each
  44         model-activated
  45     ] [
  46         drop
  47     ] if ;
  48
  49 DEFER: remove-connection
  50
  51 : deactivate-model ( model -- )
  52     dup unref-model zero? [
  53         dup model-dependencies
  54         [ dup deactivate-model remove-connection ] with each
  55     ] [
  56         drop
  57     ] if ;
  58
  59 GENERIC: model-changed ( model observer -- )
  60
  61 : add-connection ( observer model -- )
  62     dup model-connections empty? [ dup activate-model ] when
  63     model-connections push ;
  64
  65 : remove-connection ( observer model -- )
  66     [ model-connections delete ] keep
  67     dup model-connections empty? [ dup deactivate-model ] when
  68     drop ;
  69
  70 : with-locked-model ( model quot -- )
  71     swap
  72     t over set-model-locked?
  73     slip
  74     f swap set-model-locked? ; inline
  75
  76 GENERIC: update-model ( model -- )
  77
  78 M: model update-model drop ;
  79
  80 : notify-connections ( model -- )
  81     dup model-connections [ model-changed ] with each ;
  82
  83 : set-model ( value model -- )
  84     dup model-locked? [
  85         2drop
  86     ] [
  87         dup [
  88             [ set-model-value ] keep
  89             [ update-model ] keep
  90             notify-connections
  91         ] with-locked-model
  92     ] if ;
  93
  94 : ((change-model)) ( model quot -- newvalue model )
  95     over >r >r model-value r> call r> ; inline
  96
  97 : change-model ( model quot -- )
  98     ((change-model)) set-model ; inline
  99
 100 : (change-model) ( model quot -- )
 101     ((change-model)) set-model-value ; inline
 102
 103 GENERIC: range-value ( model -- value )
 104 GENERIC: range-page-value ( model -- value )
 105 GENERIC: range-min-value ( model -- value )
 106 GENERIC: range-max-value ( model -- value )
 107 GENERIC: range-max-value* ( model -- value )
 108 GENERIC: set-range-value ( value model -- )
 109 GENERIC: set-range-page-value ( value model -- )
 110 GENERIC: set-range-min-value ( value model -- )
 111 GENERIC: set-range-max-value ( value model -- )
 112
 113 : clamp-value ( value range -- newvalue )
 114     [ range-min-value max ] keep
 115     range-max-value* min ;