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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes.algebra
   4 compiler.tree.propagation.copy compiler.tree.propagation.info
   5 kernel namespaces sequences ;
   6 IN: compiler.tree.propagation.constraints
   7
   8 SYMBOL: constraints
   9
  10 GENERIC: assume* ( constraint -- )
  11 GENERIC: satisfied? ( constraint -- ? )
  12
  13 M: f assume* drop ;
  14
  15 M: object satisfied? drop f ;
  16
  17 : assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
  18
  19 TUPLE: true-constraint value ;
  20
  21 : =t ( value -- constraint ) resolve-copy true-constraint boa ;
  22
  23 : follow-implications ( constraint -- )
  24     constraints get assoc-stack [ assume ] when* ;
  25
  26 M: true-constraint assume*
  27     [ \ f class-not <class-info> swap value>> refine-value-info ]
  28     [ follow-implications ]
  29     bi ;
  30
  31 M: true-constraint satisfied?
  32     value>> value-info*
  33     [ class>> true-class? ] [ drop f ] if ;
  34
  35 TUPLE: false-constraint value ;
  36
  37 : =f ( value -- constraint ) resolve-copy false-constraint boa ;
  38
  39 M: false-constraint assume*
  40     [ \ f <class-info> swap value>> refine-value-info ]
  41     [ follow-implications ]
  42     bi ;
  43
  44 M: false-constraint satisfied?
  45     value>> value-info*
  46     [ class>> false-class? ] [ drop f ] if ;
  47
  48 TUPLE: class-constraint value class ;
  49
  50 : is-instance-of ( value class -- constraint )
  51     [ resolve-copy ] dip class-constraint boa ;
  52
  53 M: class-constraint assume*
  54     [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
  55
  56 TUPLE: interval-constraint value interval ;
  57
  58 : is-in-interval ( value interval -- constraint )
  59     [ resolve-copy ] dip interval-constraint boa ;
  60
  61 M: interval-constraint assume*
  62     [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
  63
  64 TUPLE: literal-constraint value literal ;
  65
  66 : is-equal-to ( value literal -- constraint )
  67     [ resolve-copy ] dip literal-constraint boa ;
  68
  69 M: literal-constraint assume*
  70     [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
  71
  72 TUPLE: implication p q ;
  73
  74 C: --> implication
  75
  76 : maybe-add ( elt seq -- seq' )
  77     2dup member? [ nip ] [ swap suffix ] if ;
  78
  79 : assume-implication ( q p -- )
  80     [ constraints get [ assoc-stack maybe-add ] 2keep last set-at ]
  81     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
  82
  83 M: implication assume*
  84     [ q>> ] [ p>> ] bi assume-implication ;
  85
  86 TUPLE: equivalence p q ;
  87
  88 C: <--> equivalence
  89
  90 M: equivalence assume*
  91     [ p>> ] [ q>> ] bi
  92     [ assume-implication ]
  93     [ swap assume-implication ] 2bi ;
  94
  95 ! Conjunction constraints -- sequences act as conjunctions
  96 M: sequence assume* [ assume ] each ;
  97
  98 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
  99
 100 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;