basis/compiler/tree/propagation/constraints/constraints.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs math math.intervals kernel accessors
   4 sequences namespaces classes classes.algebra
   5 combinators words
   6 compiler.tree
   7 compiler.tree.propagation.info
   8 compiler.tree.propagation.copy ;
   9 IN: compiler.tree.propagation.constraints
  10
  11 ! A constraint is a statement about a value.
  12
  13 ! Maps constraints to constraints ("A implies B")
  14 SYMBOL: constraints
  15
  16 GENERIC: assume* ( constraint -- )
  17 GENERIC: satisfied? ( constraint -- ? )
  18
  19 M: f assume* drop ;
  20
  21 ! satisfied? is inaccurate. It's just used to prevent infinite
  22 ! loops so its only implemented for true-constraints and
  23 ! false-constraints.
  24 M: object satisfied? drop f ;
  25
  26 : assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
  27
  28 ! Boolean constraints
  29 TUPLE: true-constraint value ;
  30
  31 : =t ( value -- constriant ) resolve-copy true-constraint boa ;
  32
  33 M: true-constraint assume*
  34     [ \ f class-not <class-info> swap value>> refine-value-info ]
  35     [ constraints get assoc-stack [ assume ] when* ]
  36     bi ;
  37
  38 M: true-constraint satisfied?
  39     value>> value-info class>> true-class? ;
  40
  41 TUPLE: false-constraint value ;
  42
  43 : =f ( value -- constriant ) resolve-copy false-constraint boa ;
  44
  45 M: false-constraint assume*
  46     [ \ f <class-info> swap value>> refine-value-info ]
  47     [ constraints get assoc-stack [ assume ] when* ]
  48     bi ;
  49
  50 M: false-constraint satisfied?
  51     value>> value-info class>> false-class? ;
  52
  53 ! Class constraints
  54 TUPLE: class-constraint value class ;
  55
  56 : is-instance-of ( value class -- constraint )
  57     [ resolve-copy ] dip class-constraint boa ;
  58
  59 M: class-constraint assume*
  60     [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
  61
  62 ! Interval constraints
  63 TUPLE: interval-constraint value interval ;
  64
  65 : is-in-interval ( value interval -- constraint )
  66     [ resolve-copy ] dip interval-constraint boa ;
  67
  68 M: interval-constraint assume*
  69     [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
  70
  71 ! Literal constraints
  72 TUPLE: literal-constraint value literal ;
  73
  74 : is-equal-to ( value literal -- constraint )
  75     [ resolve-copy ] dip literal-constraint boa ;
  76
  77 M: literal-constraint assume*
  78     [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
  79
  80 ! Implication constraints
  81 TUPLE: implication p q ;
  82
  83 C: --> implication
  84
  85 : assume-implication ( p q -- )
  86     [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
  87     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
  88
  89 M: implication assume*
  90     [ q>> ] [ p>> ] bi assume-implication ;
  91
  92 ! Equivalence constraints
  93 TUPLE: equivalence p q ;
  94
  95 C: <--> equivalence
  96
  97 M: equivalence assume*
  98     [ p>> ] [ q>> ] bi
  99     [ assume-implication ]
 100     [ swap assume-implication ] 2bi ;
 101
 102 ! Conjunction constraints -- sequences act as conjunctions
 103 M: sequence assume* [ assume ] each ;
 104
 105 : /\ ( p q -- constraint ) 2array ;
 106
 107 ! Utilities
 108 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
 109
 110 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;