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
7 compiler.tree.propagation.info
8 compiler.tree.propagation.copy ;
9 IN: compiler.tree.propagation.constraints
11 ! A constraint is a statement about a value.
13 ! Maps constraints to constraints ("A implies B")
16 GENERIC: assume* ( constraint -- )
17 GENERIC: satisfied? ( constraint -- ? )
21 ! satisfied? is inaccurate. It's just used to prevent infinite
22 ! loops so its only implemented for true-constraints and
24 M: object satisfied? drop f ;
26 : assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
29 TUPLE: true-constraint value ;
31 : =t ( value -- constriant ) resolve-copy true-constraint boa ;
33 M: true-constraint assume*
34 [ \ f class-not <class-info> swap value>> refine-value-info ]
35 [ constraints get assoc-stack [ assume ] when* ]
38 M: true-constraint satisfied?
39 value>> value-info class>> true-class? ;
41 TUPLE: false-constraint value ;
43 : =f ( value -- constriant ) resolve-copy false-constraint boa ;
45 M: false-constraint assume*
46 [ \ f <class-info> swap value>> refine-value-info ]
47 [ constraints get assoc-stack [ assume ] when* ]
50 M: false-constraint satisfied?
51 value>> value-info class>> false-class? ;
54 TUPLE: class-constraint value class ;
56 : is-instance-of ( value class -- constraint )
57 [ resolve-copy ] dip class-constraint boa ;
59 M: class-constraint assume*
60 [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
62 ! Interval constraints
63 TUPLE: interval-constraint value interval ;
65 : is-in-interval ( value interval -- constraint )
66 [ resolve-copy ] dip interval-constraint boa ;
68 M: interval-constraint assume*
69 [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
72 TUPLE: literal-constraint value literal ;
74 : is-equal-to ( value literal -- constraint )
75 [ resolve-copy ] dip literal-constraint boa ;
77 M: literal-constraint assume*
78 [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
80 ! Implication constraints
81 TUPLE: implication p q ;
85 : assume-implication ( p q -- )
86 [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
87 [ satisfied? [ assume ] [ drop ] if ] 2bi ;
89 M: implication assume*
90 [ q>> ] [ p>> ] bi assume-implication ;
92 ! Equivalence constraints
93 TUPLE: equivalence p q ;
97 M: equivalence assume*
99 [ assume-implication ]
100 [ swap assume-implication ] 2bi ;
102 ! Conjunction constraints -- sequences act as conjunctions
103 M: sequence assume* [ assume ] each ;
105 : /\ ( p q -- constraint ) 2array ;
108 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
110 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;