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 combinators.short-circuit
   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 -- constraint ) resolve-copy true-constraint boa ;
  32
  33 : follow-implications ( constraint -- )
  34     constraints get assoc-stack [ assume ] when* ;
  35
  36 M: true-constraint assume*
  37     [ \ f class-not <class-info> swap value>> refine-value-info ]
  38     [ follow-implications ]
  39     bi ;
  40
  41 M: true-constraint satisfied?
  42     value>> value-info class>>
  43     { [ true-class? ] [ null-class? not ] } 1&& ;
  44
  45 TUPLE: false-constraint value ;
  46
  47 : =f ( value -- constriant ) resolve-copy false-constraint boa ;
  48
  49 M: false-constraint assume*
  50     [ \ f <class-info> swap value>> refine-value-info ]
  51     [ follow-implications ]
  52     bi ;
  53
  54 M: false-constraint satisfied?
  55     value>> value-info class>>
  56     { [ false-class? ] [ null-class? not ] } 1&& ;
  57
  58 ! Class constraints
  59 TUPLE: class-constraint value class ;
  60
  61 : is-instance-of ( value class -- constraint )
  62     [ resolve-copy ] dip class-constraint boa ;
  63
  64 M: class-constraint assume*
  65     [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
  66
  67 ! Interval constraints
  68 TUPLE: interval-constraint value interval ;
  69
  70 : is-in-interval ( value interval -- constraint )
  71     [ resolve-copy ] dip interval-constraint boa ;
  72
  73 M: interval-constraint assume*
  74     [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
  75
  76 ! Literal constraints
  77 TUPLE: literal-constraint value literal ;
  78
  79 : is-equal-to ( value literal -- constraint )
  80     [ resolve-copy ] dip literal-constraint boa ;
  81
  82 M: literal-constraint assume*
  83     [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
  84
  85 ! Implication constraints
  86 TUPLE: implication p q ;
  87
  88 C: --> implication
  89
  90 : assume-implication ( q p -- )
  91     [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
  92     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
  93
  94 M: implication assume*
  95     [ q>> ] [ p>> ] bi assume-implication ;
  96
  97 ! Equivalence constraints
  98 TUPLE: equivalence p q ;
  99
 100 C: <--> equivalence
 101
 102 M: equivalence assume*
 103     [ p>> ] [ q>> ] bi
 104     [ assume-implication ]
 105     [ swap assume-implication ] 2bi ;
 106
 107 ! Conjunction constraints -- sequences act as conjunctions
 108 M: sequence assume* [ assume ] each ;
 109
 110 : /\ ( p q -- constraint ) 2array ;
 111
 112 ! Utilities
 113 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
 114
 115 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;