├── .gitignore ├── Makefile ├── README.md ├── extracted ├── interleaving_interpreter.hs ├── interleaving_interpreter_wrapped.hs ├── sld_interpreter.hs └── sld_interpreter_wrapped.hs └── src ├── FairConjunction └── AngelicSemantics.v ├── InterleavingSearch ├── Completeness.v ├── DenotationalSem.v ├── OperationalSem.v └── Soundness.v ├── Preliminaries ├── Streams.v └── Unification.v ├── SLDSearch ├── DenotationalSemSLD.v ├── LanguageSLD.v ├── OperationalSemSLD.v └── SoundnessSLD.v └── Syntax └── Language.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.glob 2 | .*.aux 3 | *.vo 4 | *~ 5 | _CoqProject 6 | Makefile.coq 7 | Makefile.coq.conf 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | COQMODULE := semantics 2 | COQTHEORIES := src/Preliminaries/*.v src/Syntax/*.v src/InterleavingSearch/*.v src/SLDSearch/*.v src/FairConjunction/*.v 3 | 4 | .PHONY: all theories clean tounicode 5 | 6 | all: build 7 | 8 | build: Makefile.coq 9 | $(MAKE) -f Makefile.coq all 10 | 11 | quick: Makefile.coq 12 | $(MAKE) -f Makefile.coq quick 13 | 14 | Makefile.coq: Makefile $(COQTHEORIES) 15 | (echo "-R src $(COQMODULE)"; \ 16 | echo $(COQTHEORIES)) > _CoqProject 17 | coq_makefile -f _CoqProject -o Makefile.coq 18 | 19 | %.vo: Makefile.coq 20 | $(MAKE) -f Makefile.coq "$@" 21 | 22 | %.vio: Makefile.coq 23 | $(MAKE) -f Makefile.coq "$@" 24 | 25 | clean: 26 | (test -f Makefile.coq && $(MAKE) -f Makefile.coq clean) || true 27 | rm -f _CoqProject Makefile.coq 28 | find src/ -type f -name "*.vo" -delete 29 | find src/ -type f -name "*.vos" -delete 30 | find src/ -type f -name "*.vok" -delete 31 | find src/ -type f -name "*.glob" -delete 32 | 33 | tounicode: 34 | sed -i 's/<>/⟫/g' $(COQTHEORIES) 36 | sed -i 's/;;/⨾/g' $(COQTHEORIES) 37 | sed -i 's/<|/⦗/g' $(COQTHEORIES) 38 | sed -i 's/|>/⦘/g' $(COQTHEORIES) 39 | 40 | archive: clean 41 | tar czf ../certified-semantics-src.tgz . 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A certified semantics for relational programming workout. 2 | 3 | `make` command will build and verify everything, and extract code from the Coq specification 4 | 5 | The folder 'src' contains the specification of the semantics and all the proofs in Coq: 6 | 7 | - The subfolder 'src/Preliminaries' contains the specification of premilinary notions used in the semantics: 8 | - Unification.v -- notions from unification theory (terms, substitutions, computation of the most general unifier) 9 | - Streams.v -- (possibly infinite) streams and their properties 10 | - The subfolder 'src/Syntax' contains the specification of syntax of conventional miniKanren: 11 | - Language.v -- base language ('Prog' axiom here is an arbitrary correct program) 12 | - The subfolder 'src/InterleavingSearch' contains the specification of syntax and semantics of miniKanren language with canonical interleaving search: 13 | - DenotationalSem.v -- denotational semantics 14 | - OperationalSem.v -- operational semantics for interleaving search 15 | - Soundness.v -- soundness of interleaving search 16 | - Completeness.v -- completeness of interleaving search 17 | - The subfolder 'src/SLDSearch' contains the specification of syntax and semantics of miniKanren language with SLD resolution with cuts (it repeats the specification of interleaving search with minor modifications): 18 | - LanguageSLD.v -- base language extended with ''cut'' constructs ('Prog' axiom here is an arbitrary correct program) 19 | - DenotationalSemSLD.v -- denotational semantics 20 | - OperationalSemSLD.v -- operational semantics for SLD resolution with cuts 21 | - SoundnessSLD.v -- soundness of SLD resolution with cuts 22 | - The subfolder 'src/FairConjunction' contains the specification of semantics for fair conjunction: 23 | - AngelicSemantics.c -- angelic semantics 24 | 25 | The folder 'extracted' contains reference interpreters extracted from the Coq specification: 26 | 27 | - interleaving_interpreter.hs -- the code extracted from interleaving search semantics (from src/InterleavingSearch/OperationalSem.v) 28 | - interleaving_interpreter_wrapped.hs -- the code from interleaving_interpreter.hs appended with primitives for more convenient use and some tests 29 | - sld_interpreter.hs -- the code extracted from SLD resolution with cuts semantics (from src/SLDSearch/OperationalSem.v) 30 | - sld_interpreter_wrapped.hs -- the code from sld_interpreter.hs appended with primitives for more convenient use (including the Prolog to MiniKanren translation) and some tests 31 | -------------------------------------------------------------------------------- /extracted/interleaving_interpreter.hs: -------------------------------------------------------------------------------- 1 | module Interleaving_interpreter where 2 | 3 | import qualified Prelude 4 | 5 | __ :: any 6 | __ = Prelude.error "Logical or arity value used" 7 | 8 | eq_rect :: a1 -> a2 -> a1 -> a2 9 | eq_rect _ f _ = 10 | f 11 | 12 | eq_rec :: a1 -> a2 -> a1 -> a2 13 | eq_rec = 14 | eq_rect 15 | 16 | eq_rec_r :: a1 -> a2 -> a1 -> a2 17 | eq_rec_r = 18 | eq_rec 19 | 20 | data Bool = 21 | True 22 | | False 23 | 24 | orb :: Bool -> Bool -> Bool 25 | orb b1 b2 = 26 | case b1 of { 27 | True -> True; 28 | False -> b2} 29 | 30 | data Nat = 31 | O 32 | | S Nat 33 | 34 | nat_rect :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 35 | nat_rect f f0 n = 36 | case n of { 37 | O -> f; 38 | S n0 -> f0 n0 (nat_rect f f0 n0)} 39 | 40 | nat_rec :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 41 | nat_rec = 42 | nat_rect 43 | 44 | data Option a = 45 | Some a 46 | | None 47 | 48 | data Prod a b = 49 | Pair a b 50 | 51 | fst :: (Prod a1 a2) -> a1 52 | fst p = 53 | case p of { 54 | Pair x _ -> x} 55 | 56 | snd :: (Prod a1 a2) -> a2 57 | snd p = 58 | case p of { 59 | Pair _ y -> y} 60 | 61 | data List a = 62 | Nil 63 | | Cons a (List a) 64 | 65 | app :: (List a1) -> (List a1) -> List a1 66 | app l m = 67 | case l of { 68 | Nil -> m; 69 | Cons a l1 -> Cons a (app l1 m)} 70 | 71 | type Sig a = a 72 | -- singleton inductive, whose constructor was exist 73 | 74 | data SigT a p = 75 | ExistT a p 76 | 77 | proj1_sig :: a1 -> a1 78 | proj1_sig e = 79 | e 80 | 81 | data Sumbool = 82 | Left 83 | | Right 84 | 85 | acc_rect :: (a1 -> () -> (a1 -> () -> a2) -> a2) -> a1 -> a2 86 | acc_rect f x = 87 | f x __ (\y _ -> acc_rect f y) 88 | 89 | well_founded_induction_type :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 90 | well_founded_induction_type x a = 91 | acc_rect (\x0 _ x1 -> x x0 x1) a 92 | 93 | well_founded_induction :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 94 | well_founded_induction = 95 | well_founded_induction_type 96 | 97 | eqb :: Nat -> Nat -> Bool 98 | eqb n m = 99 | case n of { 100 | O -> case m of { 101 | O -> True; 102 | S _ -> False}; 103 | S n' -> case m of { 104 | O -> False; 105 | S m' -> eqb n' m'}} 106 | 107 | eq_dec :: Nat -> Nat -> Sumbool 108 | eq_dec n = 109 | nat_rec (\m -> case m of { 110 | O -> Left; 111 | S _ -> Right}) (\_ iHn m -> 112 | case m of { 113 | O -> Right; 114 | S m0 -> iHn m0}) n 115 | 116 | map :: (a1 -> a2) -> (List a1) -> List a2 117 | map f l = 118 | case l of { 119 | Nil -> Nil; 120 | Cons a t -> Cons (f a) (map f t)} 121 | 122 | type Name = Nat 123 | 124 | data Term = 125 | Var Name 126 | | Cst Name 127 | | Con Name Term Term 128 | 129 | occurs :: Name -> Term -> Bool 130 | occurs n t = 131 | case t of { 132 | Var x -> eqb n x; 133 | Cst _ -> False; 134 | Con _ l r -> orb (occurs n l) (occurs n r)} 135 | 136 | type Subst = List (Prod Name Term) 137 | 138 | empty_subst :: Subst 139 | empty_subst = 140 | Nil 141 | 142 | singleton_subst :: Name -> Term -> List (Prod Name Term) 143 | singleton_subst n t = 144 | Cons (Pair n t) Nil 145 | 146 | image :: Subst -> Name -> Option Term 147 | image s n = 148 | case s of { 149 | Nil -> None; 150 | Cons p tl -> 151 | case p of { 152 | Pair m t -> case eq_dec m n of { 153 | Left -> Some t; 154 | Right -> image tl n}}} 155 | 156 | apply_subst :: Subst -> Term -> Term 157 | apply_subst s t = 158 | case t of { 159 | Var n -> case image s n of { 160 | Some t' -> t'; 161 | None -> t}; 162 | Cst _ -> t; 163 | Con n l r -> Con n (apply_subst s l) (apply_subst s r)} 164 | 165 | compose :: Subst -> Subst -> Subst 166 | compose s1 s2 = 167 | app (map (\p -> Pair (fst p) (apply_subst s2 (snd p))) s1) s2 168 | 169 | data Unification_step_outcome = 170 | NonUnifiable 171 | | Same 172 | | VarSubst Name Term 173 | 174 | create :: Name -> Term -> Unification_step_outcome 175 | create n t = 176 | case occurs n t of { 177 | True -> NonUnifiable; 178 | False -> VarSubst n t} 179 | 180 | unification_step :: Term -> Term -> Unification_step_outcome 181 | unification_step t1 t2 = 182 | case t1 of { 183 | Var n1 -> 184 | case t2 of { 185 | Var n2 -> case eq_dec n1 n2 of { 186 | Left -> Same; 187 | Right -> create n1 t2}; 188 | _ -> create n1 t2}; 189 | Cst n1 -> 190 | case t2 of { 191 | Var n2 -> create n2 t1; 192 | Cst n2 -> case eq_dec n1 n2 of { 193 | Left -> Same; 194 | Right -> NonUnifiable}; 195 | Con _ _ _ -> NonUnifiable}; 196 | Con n1 l1 r1 -> 197 | case t2 of { 198 | Var n2 -> create n2 t1; 199 | Cst _ -> NonUnifiable; 200 | Con n2 l2 r2 -> 201 | case eq_dec n1 n2 of { 202 | Left -> 203 | case unification_step l1 l2 of { 204 | Same -> unification_step r1 r2; 205 | x -> x}; 206 | Right -> NonUnifiable}}} 207 | 208 | mgu_result_exists :: Term -> Term -> SigT (Option Subst) () 209 | mgu_result_exists t1 t2 = 210 | let { 211 | h = well_founded_induction (\x h -> 212 | eq_rec_r __ (\h0 -> 213 | case x of { 214 | Pair t3 t4 -> 215 | let {u = unification_step t3 t4} in 216 | case u of { 217 | NonUnifiable -> ExistT None __; 218 | Same -> ExistT (Some empty_subst) __; 219 | VarSubst n t -> 220 | let { 221 | h1 = h0 (Pair (apply_subst (singleton_subst n t) t3) 222 | (apply_subst (singleton_subst n t) t4))} 223 | in 224 | let {h2 = h1 __} in 225 | case h2 of { 226 | ExistT x0 _ -> 227 | case x0 of { 228 | Some s -> ExistT (Some (compose (singleton_subst n t) s)) 229 | __; 230 | None -> ExistT None __}}}}) __ h) (Pair t1 t2)} 231 | in 232 | eq_rec_r __ (\h0 -> h0) __ h 233 | 234 | data Stream a = 235 | Nil0 236 | | Cons0 a (Stream a) 237 | 238 | data Goal = 239 | Fail 240 | | Unify Term Term 241 | | Disj Goal Goal 242 | | Conj Goal Goal 243 | | Fresh (Name -> Goal) 244 | | Invoke Name Term 245 | 246 | type Rel = Term -> Goal 247 | 248 | type Def = Rel 249 | 250 | type Spec = Name -> Def 251 | 252 | prog :: Spec 253 | prog = 254 | Prelude.error "AXIOM TO BE REALIZED" 255 | 256 | data Nt_state = 257 | Leaf Goal Subst Nat 258 | | Sum Nt_state Nt_state 259 | | Prod0 Nt_state Goal 260 | 261 | nt_state_rect :: (Goal -> Subst -> Nat -> a1) -> (Nt_state -> a1 -> Nt_state 262 | -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) -> Nt_state 263 | -> a1 264 | nt_state_rect f f0 f1 n = 265 | case n of { 266 | Leaf g s n0 -> f g s n0; 267 | Sum n0 n1 -> 268 | f0 n0 (nt_state_rect f f0 f1 n0) n1 (nt_state_rect f f0 f1 n1); 269 | Prod0 n0 g -> f1 n0 (nt_state_rect f f0 f1 n0) g} 270 | 271 | nt_state_rec :: (Goal -> Subst -> Nat -> a1) -> (Nt_state -> a1 -> Nt_state 272 | -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) -> Nt_state -> 273 | a1 274 | nt_state_rec = 275 | nt_state_rect 276 | 277 | data State = 278 | Stop 279 | | NTState Nt_state 280 | 281 | data Label = 282 | Step 283 | | Answer Subst Nat 284 | 285 | eval_step_exists :: Nt_state -> SigT Label (SigT State ()) 286 | eval_step_exists nst = 287 | nt_state_rec (\g s n -> 288 | case g of { 289 | Fail -> ExistT Step (ExistT Stop __); 290 | Unify t t0 -> 291 | let {h = mgu_result_exists (apply_subst s t) (apply_subst s t0)} in 292 | case h of { 293 | ExistT x _ -> 294 | case x of { 295 | Some s0 -> ExistT (Answer (compose s s0) n) (ExistT Stop __); 296 | None -> ExistT Step (ExistT Stop __)}}; 297 | Disj g1 g2 -> ExistT Step (ExistT (NTState (Sum (Leaf g1 s n) (Leaf g2 s 298 | n))) __); 299 | Conj g1 g2 -> ExistT Step (ExistT (NTState (Prod0 (Leaf g1 s n) g2)) __); 300 | Fresh g0 -> ExistT Step (ExistT (NTState (Leaf (g0 n) s (S n))) __); 301 | Invoke n0 t -> ExistT Step (ExistT (NTState (Leaf 302 | (proj1_sig (prog n0) t) s n)) __)}) (\_ iHnst1 nst2 _ -> 303 | case iHnst1 of { 304 | ExistT l1 s -> 305 | case s of { 306 | ExistT st1 _ -> 307 | case st1 of { 308 | Stop -> ExistT l1 (ExistT (NTState nst2) __); 309 | NTState n -> ExistT l1 (ExistT (NTState (Sum nst2 n)) __)}}}) 310 | (\_ iHnst g -> 311 | case iHnst of { 312 | ExistT l s -> 313 | case s of { 314 | ExistT st _ -> 315 | case st of { 316 | Stop -> 317 | case l of { 318 | Step -> ExistT Step (ExistT Stop __); 319 | Answer s0 n -> ExistT Step (ExistT (NTState (Leaf g s0 n)) __)}; 320 | NTState n -> 321 | case l of { 322 | Step -> ExistT Step (ExistT (NTState (Prod0 n g)) __); 323 | Answer s0 n0 -> ExistT Step (ExistT (NTState (Sum (Leaf g s0 n0) 324 | (Prod0 n g))) __)}}}}) nst 325 | 326 | type Trace = Stream Label 327 | 328 | trace_from :: State -> Trace 329 | trace_from st = 330 | case st of { 331 | Stop -> Nil0; 332 | NTState nst -> 333 | case eval_step_exists nst of { 334 | ExistT l s -> case s of { 335 | ExistT nst' _ -> Cons0 l (trace_from nst')}}} 336 | 337 | op_sem_exists :: State -> SigT Trace () 338 | op_sem_exists st = 339 | ExistT (trace_from st) __ 340 | 341 | -------------------------------------------------------------------------------- /extracted/interleaving_interpreter_wrapped.hs: -------------------------------------------------------------------------------- 1 | module Interleaving_interpreter where 2 | 3 | import qualified Prelude as P 4 | import qualified Data.Maybe 5 | import qualified Data.Tuple 6 | import qualified Data.List 7 | 8 | __ :: any 9 | __ = P.error "Logical or arity value used" 10 | 11 | eq_rect :: a1 -> a2 -> a1 -> a2 12 | eq_rect _ f _ = 13 | f 14 | 15 | eq_rec :: a1 -> a2 -> a1 -> a2 16 | eq_rec = 17 | eq_rect 18 | 19 | eq_rec_r :: a1 -> a2 -> a1 -> a2 20 | eq_rec_r = 21 | eq_rec 22 | 23 | data Bool = 24 | True 25 | | False 26 | 27 | orb :: Bool -> Bool -> Bool 28 | orb b1 b2 = 29 | case b1 of { 30 | True -> True; 31 | False -> b2} 32 | 33 | data Nat = 34 | O 35 | | S Nat 36 | 37 | nat_rect :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 38 | nat_rect f f0 n = 39 | case n of { 40 | O -> f; 41 | S n0 -> f0 n0 (nat_rect f f0 n0)} 42 | 43 | nat_rec :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 44 | nat_rec = 45 | nat_rect 46 | 47 | data Option a = 48 | Some a 49 | | None 50 | 51 | data Prod a b = 52 | Pair a b 53 | 54 | fst :: (Prod a1 a2) -> a1 55 | fst p = 56 | case p of { 57 | Pair x _ -> x} 58 | 59 | snd :: (Prod a1 a2) -> a2 60 | snd p = 61 | case p of { 62 | Pair _ y -> y} 63 | 64 | data List a = 65 | Nil 66 | | Cons a (List a) 67 | 68 | app :: (List a1) -> (List a1) -> List a1 69 | app l m = 70 | case l of { 71 | Nil -> m; 72 | Cons a l1 -> Cons a (app l1 m)} 73 | 74 | type Sig a = a 75 | -- singleton inductive, whose constructor was exist 76 | 77 | data SigT a p = 78 | ExistT a p 79 | 80 | proj1_sig :: a1 -> a1 81 | proj1_sig e = 82 | e 83 | 84 | data Sumbool = 85 | Left 86 | | Right 87 | 88 | acc_rect :: (a1 -> () -> (a1 -> () -> a2) -> a2) -> a1 -> a2 89 | acc_rect f x = 90 | f x __ (\y _ -> acc_rect f y) 91 | 92 | well_founded_induction_type :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 93 | well_founded_induction_type x a = 94 | acc_rect (\x0 _ x1 -> x x0 x1) a 95 | 96 | well_founded_induction :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 97 | well_founded_induction = 98 | well_founded_induction_type 99 | 100 | eqb :: Nat -> Nat -> Bool 101 | eqb n m = 102 | case n of { 103 | O -> case m of { 104 | O -> True; 105 | S _ -> False}; 106 | S n' -> case m of { 107 | O -> False; 108 | S m' -> eqb n' m'}} 109 | 110 | eq_dec :: Nat -> Nat -> Sumbool 111 | eq_dec n = 112 | nat_rec (\m -> case m of { 113 | O -> Left; 114 | S _ -> Right}) (\_ iHn m -> 115 | case m of { 116 | O -> Right; 117 | S m0 -> iHn m0}) n 118 | 119 | map :: (a1 -> a2) -> (List a1) -> List a2 120 | map f l = 121 | case l of { 122 | Nil -> Nil; 123 | Cons a t -> Cons (f a) (map f t)} 124 | 125 | type Name = Nat 126 | 127 | data Term = 128 | Var Name 129 | | Cst Name 130 | | Con Name Term Term 131 | 132 | occurs :: Name -> Term -> Bool 133 | occurs n t = 134 | case t of { 135 | Var x -> eqb n x; 136 | Cst _ -> False; 137 | Con _ l r -> orb (occurs n l) (occurs n r)} 138 | 139 | type Subst = List (Prod Name Term) 140 | 141 | empty_subst :: Subst 142 | empty_subst = 143 | Nil 144 | 145 | singleton_subst :: Name -> Term -> List (Prod Name Term) 146 | singleton_subst n t = 147 | Cons (Pair n t) Nil 148 | 149 | image :: Subst -> Name -> Option Term 150 | image s n = 151 | case s of { 152 | Nil -> None; 153 | Cons p tl -> 154 | case p of { 155 | Pair m t -> case eq_dec m n of { 156 | Left -> Some t; 157 | Right -> image tl n}}} 158 | 159 | apply_subst :: Subst -> Term -> Term 160 | apply_subst s t = 161 | case t of { 162 | Var n -> case image s n of { 163 | Some t' -> t'; 164 | None -> t}; 165 | Cst _ -> t; 166 | Con n l r -> Con n (apply_subst s l) (apply_subst s r)} 167 | 168 | compose :: Subst -> Subst -> Subst 169 | compose s1 s2 = 170 | app (map (\p -> Pair (fst p) (apply_subst s2 (snd p))) s1) s2 171 | 172 | data Unification_step_outcome = 173 | NonUnifiable 174 | | Same 175 | | VarSubst Name Term 176 | 177 | create :: Name -> Term -> Unification_step_outcome 178 | create n t = 179 | case occurs n t of { 180 | True -> NonUnifiable; 181 | False -> VarSubst n t} 182 | 183 | unification_step :: Term -> Term -> Unification_step_outcome 184 | unification_step t1 t2 = 185 | case t1 of { 186 | Var n1 -> 187 | case t2 of { 188 | Var n2 -> case eq_dec n1 n2 of { 189 | Left -> Same; 190 | Right -> create n1 t2}; 191 | _ -> create n1 t2}; 192 | Cst n1 -> 193 | case t2 of { 194 | Var n2 -> create n2 t1; 195 | Cst n2 -> case eq_dec n1 n2 of { 196 | Left -> Same; 197 | Right -> NonUnifiable}; 198 | Con _ _ _ -> NonUnifiable}; 199 | Con n1 l1 r1 -> 200 | case t2 of { 201 | Var n2 -> create n2 t1; 202 | Cst _ -> NonUnifiable; 203 | Con n2 l2 r2 -> 204 | case eq_dec n1 n2 of { 205 | Left -> 206 | case unification_step l1 l2 of { 207 | Same -> unification_step r1 r2; 208 | x -> x}; 209 | Right -> NonUnifiable}}} 210 | 211 | mgu_result_exists :: Term -> Term -> SigT (Option Subst) () 212 | mgu_result_exists t1 t2 = 213 | let { 214 | h = well_founded_induction (\x h -> 215 | eq_rec_r __ (\h0 -> 216 | case x of { 217 | Pair t3 t4 -> 218 | let {u = unification_step t3 t4} in 219 | case u of { 220 | NonUnifiable -> ExistT None __; 221 | Same -> ExistT (Some empty_subst) __; 222 | VarSubst n t -> 223 | let { 224 | h1 = h0 (Pair (apply_subst (singleton_subst n t) t3) 225 | (apply_subst (singleton_subst n t) t4))} 226 | in 227 | let {h2 = h1 __} in 228 | case h2 of { 229 | ExistT x0 _ -> 230 | case x0 of { 231 | Some s -> ExistT (Some (compose (singleton_subst n t) s)) 232 | __; 233 | None -> ExistT None __}}}}) __ h) (Pair t1 t2)} 234 | in 235 | eq_rec_r __ (\h0 -> h0) __ h 236 | 237 | data Stream a = 238 | Nil0 239 | | Cons0 a (Stream a) 240 | 241 | data Goal = 242 | Fail 243 | | Unify Term Term 244 | | Disj Goal Goal 245 | | Conj Goal Goal 246 | | Fresh (Name -> Goal) 247 | | Invoke Name Term 248 | 249 | type Rel = Term -> Goal 250 | 251 | type Def = Rel 252 | 253 | type Spec = Name -> Def 254 | 255 | data Nt_state = 256 | Leaf Goal Subst Nat 257 | | Sum Nt_state Nt_state 258 | | Prod0 Nt_state Goal 259 | 260 | nt_state_rect :: (Goal -> Subst -> Nat -> a1) -> (Nt_state -> a1 -> Nt_state 261 | -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) -> Nt_state 262 | -> a1 263 | nt_state_rect f f0 f1 n = 264 | case n of { 265 | Leaf g s n0 -> f g s n0; 266 | Sum n0 n1 -> 267 | f0 n0 (nt_state_rect f f0 f1 n0) n1 (nt_state_rect f f0 f1 n1); 268 | Prod0 n0 g -> f1 n0 (nt_state_rect f f0 f1 n0) g} 269 | 270 | nt_state_rec :: (Goal -> Subst -> Nat -> a1) -> (Nt_state -> a1 -> Nt_state 271 | -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) -> Nt_state -> 272 | a1 273 | nt_state_rec = 274 | nt_state_rect 275 | 276 | data State = 277 | Stop 278 | | NTState Nt_state 279 | 280 | data Label = 281 | Step 282 | | Answer Subst Nat 283 | 284 | eval_step_exists :: Nt_state -> SigT Label (SigT State ()) 285 | eval_step_exists nst = 286 | nt_state_rec (\g s n -> 287 | case g of { 288 | Fail -> ExistT Step (ExistT Stop __); 289 | Unify t t0 -> 290 | let {h = mgu_result_exists (apply_subst s t) (apply_subst s t0)} in 291 | case h of { 292 | ExistT x _ -> 293 | case x of { 294 | Some s0 -> ExistT (Answer (compose s s0) n) (ExistT Stop __); 295 | None -> ExistT Step (ExistT Stop __)}}; 296 | Disj g1 g2 -> ExistT Step (ExistT (NTState (Sum (Leaf g1 s n) (Leaf g2 s 297 | n))) __); 298 | Conj g1 g2 -> ExistT Step (ExistT (NTState (Prod0 (Leaf g1 s n) g2)) __); 299 | Fresh g0 -> ExistT Step (ExistT (NTState (Leaf (g0 n) s (S n))) __); 300 | Invoke n0 t -> ExistT Step (ExistT (NTState (Leaf 301 | (proj1_sig (prog n0) t) s n)) __)}) (\_ iHnst1 nst2 _ -> 302 | case iHnst1 of { 303 | ExistT l1 s -> 304 | case s of { 305 | ExistT st1 _ -> 306 | case st1 of { 307 | Stop -> ExistT l1 (ExistT (NTState nst2) __); 308 | NTState n -> ExistT l1 (ExistT (NTState (Sum nst2 n)) __)}}}) 309 | (\_ iHnst g -> 310 | case iHnst of { 311 | ExistT l s -> 312 | case s of { 313 | ExistT st _ -> 314 | case st of { 315 | Stop -> 316 | case l of { 317 | Step -> ExistT Step (ExistT Stop __); 318 | Answer s0 n -> ExistT Step (ExistT (NTState (Leaf g s0 n)) __)}; 319 | NTState n -> 320 | case l of { 321 | Step -> ExistT Step (ExistT (NTState (Prod0 n g)) __); 322 | Answer s0 n0 -> ExistT Step (ExistT (NTState (Sum (Leaf g s0 n0) 323 | (Prod0 n g))) __)}}}}) nst 324 | 325 | type Trace = Stream Label 326 | 327 | trace_from :: State -> Trace 328 | trace_from st = 329 | case st of { 330 | Stop -> Nil0; 331 | NTState nst -> 332 | case eval_step_exists nst of { 333 | ExistT l s -> case s of { 334 | ExistT nst' _ -> Cons0 l (trace_from nst')}}} 335 | 336 | op_sem_exists :: State -> SigT Trace () 337 | op_sem_exists st = 338 | ExistT (trace_from st) __ 339 | 340 | 341 | 342 | 343 | 344 | {- Nats and ints -} 345 | 346 | int_to_nat :: P.Int -> Nat 347 | int_to_nat n | n P.== 0 = O 348 | | P.otherwise = S (int_to_nat (n P.- 1)) 349 | 350 | nat_to_int :: Nat -> P.Int 351 | nat_to_int O = 0 352 | nat_to_int (S n) = (nat_to_int n) P.+ 1 353 | 354 | instance P.Show Nat where 355 | show n = P.show (nat_to_int n) 356 | 357 | instance P.Eq Nat where 358 | a == b = (nat_to_int a) P.== (nat_to_int b) 359 | 360 | 361 | {- Usual terms and terms -} 362 | 363 | data UsualTerm = UVar Name | UCon P.String [UsualTerm] 364 | 365 | v i = UVar (int_to_nat i) 366 | c = UCon 367 | cst s = UCon s [] 368 | 369 | constr_names :: [(P.Int, P.String)] 370 | constr_names = 371 | [ 372 | (0, "_app"), 373 | (1, "_nil"), 374 | (2, "_cons"), 375 | 376 | (3, "z"), 377 | (4, "s"), 378 | (5, "nil"), 379 | (6, "cons") 380 | ] 381 | 382 | constr_name_id :: P.String -> Name 383 | constr_name_id s = int_to_nat (Data.Maybe.fromMaybe (P.error "no such constr name") 384 | (P.lookup s (P.map Data.Tuple.swap constr_names))) 385 | 386 | constr_id_name :: Name -> P.String 387 | constr_id_name n = Data.Maybe.fromMaybe (P.error "no such constr name") 388 | (P.lookup (nat_to_int n) constr_names) 389 | 390 | usual_term_to_term :: UsualTerm -> Term 391 | usual_term_to_term (UVar n) = Var n 392 | usual_term_to_term (UCon s uts) = Con (constr_name_id "_app") 393 | (Cst (constr_name_id s)) 394 | (usual_list_to_term uts) 395 | 396 | usual_list_to_term :: [UsualTerm] -> Term 397 | usual_list_to_term uts = P.foldr (Con (constr_name_id "_cons")) 398 | (Cst (constr_name_id "_nil")) 399 | (P.map usual_term_to_term uts) 400 | 401 | 402 | 403 | instance P.Show Term where 404 | show (Var n) = "v" P.++ (P.show n) -- result of variable translation 405 | show (Con _ (Cst n) (Cst _)) = constr_id_name n -- result of constant translation 406 | show (Con _ (Cst n) (Con _ at ats)) = constr_id_name n P.++ -- result of constructor translation 407 | "(" P.++ 408 | (P.show at) P.++ 409 | (show_arg_terms ats) P.++ 410 | ")" 411 | 412 | show_arg_terms (Cst _) = "" 413 | show_arg_terms (Con _ t ts) = ", " P.++ (P.show t) P.++ (show_arg_terms ts) 414 | 415 | 416 | {- Program constructors -} 417 | 418 | fail = Fail 419 | 420 | infix 4 === 421 | ut1 === ut2 = Unify (usual_term_to_term ut1) (usual_term_to_term ut2) 422 | 423 | infixr 2 ||| 424 | (|||) = Disj 425 | 426 | infixr 3 &&& 427 | (&&&) = Conj 428 | 429 | fresh fb = Fresh (\x -> fb (UVar x)) 430 | 431 | invoke r args = Invoke (pred_name_id r) (usual_list_to_term args) 432 | 433 | rel0 :: Goal -> Def 434 | rel0 g = \arg -> (Unify arg (usual_list_to_term [])) &&& g 435 | 436 | rel1 :: (UsualTerm -> Goal) -> Def 437 | rel1 gf = \arg -> fresh (\x -> (Unify arg (usual_list_to_term [x])) &&& gf x) 438 | 439 | rel2 :: (UsualTerm -> UsualTerm -> Goal) -> Def 440 | rel2 gf = \arg -> fresh (\x -> 441 | (fresh (\y -> (Unify arg (usual_list_to_term [x, y])) &&& gf x y))) 442 | 443 | rel3 :: (UsualTerm -> UsualTerm -> UsualTerm -> Goal) -> Def 444 | rel3 gf = \arg -> fresh (\x -> 445 | (fresh (\y -> 446 | (fresh (\z -> (Unify arg (usual_list_to_term [x, y, z])) &&& gf x y z))))) 447 | 448 | {- Program (all predicate definitions) and test goals -} 449 | 450 | pred_name_id :: P.String -> Name 451 | pred_name_id s = int_to_nat (Data.Maybe.fromMaybe (P.error "no such pred name") 452 | (P.lookup s (P.map Data.Tuple.swap pred_names))) 453 | 454 | pred_id_name :: Name -> P.String 455 | pred_id_name n = Data.Maybe.fromMaybe (P.error "no such pred name") 456 | (P.lookup (nat_to_int n) pred_names) 457 | 458 | pred_names :: [(P.Int, P.String)] 459 | pred_names = 460 | [ 461 | (0, "zeroeso"), 462 | (1, "appendo"), 463 | (2, "reverso") 464 | ] 465 | 466 | pseudo_p :: P.String -> Def 467 | pseudo_p "zeroeso" = rel1 (\x -> invoke "zeroeso" [x] ||| x === cst "z") 468 | pseudo_p "appendo" = rel3 (\a b ab -> (a === cst "nil" &&& b === ab) ||| 469 | fresh (\h -> 470 | (fresh (\t -> 471 | (fresh (\tb -> a === c "cons" [h, t] &&& 472 | ab === c "cons" [h, tb] &&& 473 | invoke "appendo" [t, b, tb])))))) 474 | pseudo_p "reverso" = rel2 (\a ar -> (a === cst "nil" &&& ar === cst "nil") ||| 475 | fresh (\h -> 476 | (fresh (\t -> 477 | (fresh (\tr -> a === c "cons" [h, t] &&& 478 | invoke "reverso" [t, tr] &&& 479 | invoke "appendo" [tr, c "cons" [h, cst "nil"], ar])))))) 480 | pseudo_p _ = \arg -> fail 481 | 482 | prog :: Spec 483 | prog = \r_id -> pseudo_p (pred_id_name r_id) 484 | 485 | 486 | itut :: P.Int -> UsualTerm 487 | itut n | n P.== 0 = cst "z" 488 | | P.otherwise = c "s" [itut (n P.- 1)] 489 | 490 | 491 | ultut :: [UsualTerm] -> UsualTerm 492 | ultut uts = P.foldr (\x y -> c "cons" [x, y]) (cst "nil") uts 493 | 494 | goal0 = invoke "zeroeso" [v 0] -- should give infinite stream 495 | goal1 = invoke "appendo" [ultut [itut 0, itut 1], ultut [itut 2, itut 3], v 0] 496 | goal2 = invoke "appendo" [v 0, v 1, ultut [itut 0, itut 1, itut 2]] 497 | goal3 = invoke "reverso" [ultut [itut 0, itut 1, itut 2], v 0] 498 | goal4 = invoke "reverso" [v 0, v 0] 499 | 500 | 501 | 502 | {- Interpretation -} 503 | 504 | instance (P.Show a, P.Show b) => P.Show (Prod a b) where 505 | show (Pair x v) = P.show x P.++ " -> " P.++ P.show v 506 | 507 | instance P.Show a => P.Show (List a) where 508 | show Nil = [] 509 | show (Cons h t) = "[" P.++ 510 | (P.show h) P.++ 511 | (show_tail t) P.++ 512 | "]" 513 | 514 | show_tail Nil = "" 515 | show_tail (Cons h t) = ", " P.++ (P.show h) P.++ (show_tail t) 516 | 517 | streamToList :: Stream a -> [a] 518 | streamToList Nil0 = [] 519 | streamToList (Cons0 x xs) = x : streamToList xs 520 | 521 | initState :: P.Int -> Goal -> State 522 | initState n g = NTState (Leaf g Nil (int_to_nat n)) 523 | 524 | interpret :: P.Int -> Goal -> [Subst] 525 | interpret n g = let (ExistT t _) = op_sem_exists (initState n g) 526 | in P.map (\ (Answer s _) -> s) (P.filter answersOnly (streamToList t)) 527 | where 528 | answersOnly Step = P.False 529 | answersOnly (Answer _ _) = P.True 530 | -------------------------------------------------------------------------------- /extracted/sld_interpreter.hs: -------------------------------------------------------------------------------- 1 | module Sld_interpreter where 2 | 3 | import qualified Prelude 4 | 5 | __ :: any 6 | __ = Prelude.error "Logical or arity value used" 7 | 8 | eq_rect :: a1 -> a2 -> a1 -> a2 9 | eq_rect _ f _ = 10 | f 11 | 12 | eq_rec :: a1 -> a2 -> a1 -> a2 13 | eq_rec = 14 | eq_rect 15 | 16 | eq_rec_r :: a1 -> a2 -> a1 -> a2 17 | eq_rec_r = 18 | eq_rec 19 | 20 | data Bool = 21 | True 22 | | False 23 | 24 | orb :: Bool -> Bool -> Bool 25 | orb b1 b2 = 26 | case b1 of { 27 | True -> True; 28 | False -> b2} 29 | 30 | data Nat = 31 | O 32 | | S Nat 33 | 34 | nat_rect :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 35 | nat_rect f f0 n = 36 | case n of { 37 | O -> f; 38 | S n0 -> f0 n0 (nat_rect f f0 n0)} 39 | 40 | nat_rec :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 41 | nat_rec = 42 | nat_rect 43 | 44 | data Option a = 45 | Some a 46 | | None 47 | 48 | data Prod a b = 49 | Pair a b 50 | 51 | fst :: (Prod a1 a2) -> a1 52 | fst p = 53 | case p of { 54 | Pair x _ -> x} 55 | 56 | snd :: (Prod a1 a2) -> a2 57 | snd p = 58 | case p of { 59 | Pair _ y -> y} 60 | 61 | data List a = 62 | Nil 63 | | Cons a (List a) 64 | 65 | app :: (List a1) -> (List a1) -> List a1 66 | app l m = 67 | case l of { 68 | Nil -> m; 69 | Cons a l1 -> Cons a (app l1 m)} 70 | 71 | type Sig a = a 72 | -- singleton inductive, whose constructor was exist 73 | 74 | data SigT a p = 75 | ExistT a p 76 | 77 | proj1_sig :: a1 -> a1 78 | proj1_sig e = 79 | e 80 | 81 | data Sumbool = 82 | Left 83 | | Right 84 | 85 | acc_rect :: (a1 -> () -> (a1 -> () -> a2) -> a2) -> a1 -> a2 86 | acc_rect f x = 87 | f x __ (\y _ -> acc_rect f y) 88 | 89 | well_founded_induction_type :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 90 | well_founded_induction_type x a = 91 | acc_rect (\x0 _ x1 -> x x0 x1) a 92 | 93 | well_founded_induction :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 94 | well_founded_induction = 95 | well_founded_induction_type 96 | 97 | eqb :: Nat -> Nat -> Bool 98 | eqb n m = 99 | case n of { 100 | O -> case m of { 101 | O -> True; 102 | S _ -> False}; 103 | S n' -> case m of { 104 | O -> False; 105 | S m' -> eqb n' m'}} 106 | 107 | eq_dec :: Nat -> Nat -> Sumbool 108 | eq_dec n = 109 | nat_rec (\m -> case m of { 110 | O -> Left; 111 | S _ -> Right}) (\_ iHn m -> 112 | case m of { 113 | O -> Right; 114 | S m0 -> iHn m0}) n 115 | 116 | map :: (a1 -> a2) -> (List a1) -> List a2 117 | map f l = 118 | case l of { 119 | Nil -> Nil; 120 | Cons a t -> Cons (f a) (map f t)} 121 | 122 | type Name = Nat 123 | 124 | data Term = 125 | Var Name 126 | | Cst Name 127 | | Con Name Term Term 128 | 129 | occurs :: Name -> Term -> Bool 130 | occurs n t = 131 | case t of { 132 | Var x -> eqb n x; 133 | Cst _ -> False; 134 | Con _ l r -> orb (occurs n l) (occurs n r)} 135 | 136 | type Subst = List (Prod Name Term) 137 | 138 | empty_subst :: Subst 139 | empty_subst = 140 | Nil 141 | 142 | singleton_subst :: Name -> Term -> List (Prod Name Term) 143 | singleton_subst n t = 144 | Cons (Pair n t) Nil 145 | 146 | image :: Subst -> Name -> Option Term 147 | image s n = 148 | case s of { 149 | Nil -> None; 150 | Cons p tl -> 151 | case p of { 152 | Pair m t -> case eq_dec m n of { 153 | Left -> Some t; 154 | Right -> image tl n}}} 155 | 156 | apply_subst :: Subst -> Term -> Term 157 | apply_subst s t = 158 | case t of { 159 | Var n -> case image s n of { 160 | Some t' -> t'; 161 | None -> t}; 162 | Cst _ -> t; 163 | Con n l r -> Con n (apply_subst s l) (apply_subst s r)} 164 | 165 | compose :: Subst -> Subst -> Subst 166 | compose s1 s2 = 167 | app (map (\p -> Pair (fst p) (apply_subst s2 (snd p))) s1) s2 168 | 169 | data Unification_step_outcome = 170 | NonUnifiable 171 | | Same 172 | | VarSubst Name Term 173 | 174 | create :: Name -> Term -> Unification_step_outcome 175 | create n t = 176 | case occurs n t of { 177 | True -> NonUnifiable; 178 | False -> VarSubst n t} 179 | 180 | unification_step :: Term -> Term -> Unification_step_outcome 181 | unification_step t1 t2 = 182 | case t1 of { 183 | Var n1 -> 184 | case t2 of { 185 | Var n2 -> case eq_dec n1 n2 of { 186 | Left -> Same; 187 | Right -> create n1 t2}; 188 | _ -> create n1 t2}; 189 | Cst n1 -> 190 | case t2 of { 191 | Var n2 -> create n2 t1; 192 | Cst n2 -> case eq_dec n1 n2 of { 193 | Left -> Same; 194 | Right -> NonUnifiable}; 195 | Con _ _ _ -> NonUnifiable}; 196 | Con n1 l1 r1 -> 197 | case t2 of { 198 | Var n2 -> create n2 t1; 199 | Cst _ -> NonUnifiable; 200 | Con n2 l2 r2 -> 201 | case eq_dec n1 n2 of { 202 | Left -> 203 | case unification_step l1 l2 of { 204 | Same -> unification_step r1 r2; 205 | x -> x}; 206 | Right -> NonUnifiable}}} 207 | 208 | mgu_result_exists :: Term -> Term -> SigT (Option Subst) () 209 | mgu_result_exists t1 t2 = 210 | let { 211 | h = well_founded_induction (\x h -> 212 | eq_rec_r __ (\h0 -> 213 | case x of { 214 | Pair t3 t4 -> 215 | let {u = unification_step t3 t4} in 216 | case u of { 217 | NonUnifiable -> ExistT None __; 218 | Same -> ExistT (Some empty_subst) __; 219 | VarSubst n t -> 220 | let { 221 | h1 = h0 (Pair (apply_subst (singleton_subst n t) t3) 222 | (apply_subst (singleton_subst n t) t4))} 223 | in 224 | let {h2 = h1 __} in 225 | case h2 of { 226 | ExistT x0 _ -> 227 | case x0 of { 228 | Some s -> ExistT (Some (compose (singleton_subst n t) s)) 229 | __; 230 | None -> ExistT None __}}}}) __ h) (Pair t1 t2)} 231 | in 232 | eq_rec_r __ (\h0 -> h0) __ h 233 | 234 | data Stream a = 235 | Nil0 236 | | Cons0 a (Stream a) 237 | 238 | data Goal = 239 | Fail 240 | | Cut 241 | | Unify Term Term 242 | | Disj Goal Goal 243 | | Conj Goal Goal 244 | | Fresh (Name -> Goal) 245 | | Invoke Name Term 246 | 247 | type Rel = Term -> Goal 248 | 249 | type Def = Rel 250 | 251 | type Spec = Name -> Def 252 | 253 | prog :: Spec 254 | prog = 255 | Prelude.error "AXIOM TO BE REALIZED" 256 | 257 | data Cutting_mark = 258 | StopCutting 259 | | KeepCutting 260 | 261 | data Nt_state = 262 | Leaf Goal Subst Nat 263 | | Sum Cutting_mark Nt_state Nt_state 264 | | Prod0 Nt_state Goal 265 | 266 | nt_state_rect :: (Goal -> Subst -> Nat -> a1) -> (Cutting_mark -> Nt_state -> 267 | a1 -> Nt_state -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> 268 | a1) -> Nt_state -> a1 269 | nt_state_rect f f0 f1 n = 270 | case n of { 271 | Leaf g s n0 -> f g s n0; 272 | Sum c n0 n1 -> 273 | f0 c n0 (nt_state_rect f f0 f1 n0) n1 (nt_state_rect f f0 f1 n1); 274 | Prod0 n0 g -> f1 n0 (nt_state_rect f f0 f1 n0) g} 275 | 276 | nt_state_rec :: (Goal -> Subst -> Nat -> a1) -> (Cutting_mark -> Nt_state -> 277 | a1 -> Nt_state -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) 278 | -> Nt_state -> a1 279 | nt_state_rec = 280 | nt_state_rect 281 | 282 | data State = 283 | Stop 284 | | NTState Nt_state 285 | 286 | data Label = 287 | Step 288 | | Answer Subst Nat 289 | 290 | data Cut_signal = 291 | NoCutting 292 | | YesCutting 293 | 294 | eval_step_exists :: Nt_state -> SigT Label (SigT Cut_signal (SigT State ())) 295 | eval_step_exists nst = 296 | nt_state_rec (\g s n -> 297 | case g of { 298 | Fail -> ExistT Step (ExistT NoCutting (ExistT Stop __)); 299 | Cut -> ExistT (Answer s n) (ExistT YesCutting (ExistT Stop __)); 300 | Unify t t0 -> 301 | let {h = mgu_result_exists (apply_subst s t) (apply_subst s t0)} in 302 | case h of { 303 | ExistT x _ -> 304 | case x of { 305 | Some s0 -> ExistT (Answer (compose s s0) n) (ExistT NoCutting 306 | (ExistT Stop __)); 307 | None -> ExistT Step (ExistT NoCutting (ExistT Stop __))}}; 308 | Disj g1 g2 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Sum 309 | StopCutting (Leaf g1 s n) (Leaf g2 s n))) __)); 310 | Conj g1 g2 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Prod0 311 | (Leaf g1 s n) g2)) __)); 312 | Fresh g0 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Leaf 313 | (g0 n) s (S n))) __)); 314 | Invoke n0 t -> ExistT Step (ExistT NoCutting (ExistT (NTState (Leaf 315 | (proj1_sig (prog n0) t) s n)) __))}) (\c _ iHnst1 nst2 _ -> 316 | case iHnst1 of { 317 | ExistT l1 s -> 318 | case s of { 319 | ExistT cs s0 -> 320 | case s0 of { 321 | ExistT st1 _ -> 322 | case st1 of { 323 | Stop -> 324 | case cs of { 325 | NoCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState nst2) 326 | __)); 327 | YesCutting -> 328 | case c of { 329 | StopCutting -> ExistT l1 (ExistT NoCutting (ExistT Stop __)); 330 | KeepCutting -> ExistT l1 (ExistT YesCutting (ExistT Stop __))}}; 331 | NTState n -> 332 | case cs of { 333 | NoCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState (Sum c 334 | n nst2)) __)); 335 | YesCutting -> 336 | case c of { 337 | StopCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState n) 338 | __)); 339 | KeepCutting -> ExistT l1 (ExistT YesCutting (ExistT (NTState 340 | n) __))}}}}}}) (\_ iHnst g -> 341 | case iHnst of { 342 | ExistT l s -> 343 | case s of { 344 | ExistT cs s0 -> 345 | case s0 of { 346 | ExistT st _ -> 347 | case st of { 348 | Stop -> 349 | case l of { 350 | Step -> ExistT Step (ExistT cs (ExistT Stop __)); 351 | Answer s1 n -> ExistT Step (ExistT cs (ExistT (NTState (Leaf g 352 | s1 n)) __))}; 353 | NTState n -> 354 | case l of { 355 | Step -> ExistT Step (ExistT cs (ExistT (NTState (Prod0 n g)) 356 | __)); 357 | Answer s1 n0 -> ExistT Step (ExistT cs (ExistT (NTState (Sum 358 | KeepCutting (Leaf g s1 n0) (Prod0 n g))) __))}}}}}) nst 359 | 360 | type Trace = Stream Label 361 | 362 | trace_from :: State -> Trace 363 | trace_from st = 364 | case st of { 365 | Stop -> Nil0; 366 | NTState nst -> 367 | case eval_step_exists nst of { 368 | ExistT l s -> 369 | case s of { 370 | ExistT _ s0 -> 371 | case s0 of { 372 | ExistT nst' _ -> Cons0 l (trace_from nst')}}}} 373 | 374 | op_sem_exists :: State -> SigT Trace () 375 | op_sem_exists st = 376 | ExistT (trace_from st) __ 377 | 378 | -------------------------------------------------------------------------------- /extracted/sld_interpreter_wrapped.hs: -------------------------------------------------------------------------------- 1 | module Sld_interpreter where 2 | 3 | import qualified Prelude as P 4 | import qualified Data.Maybe 5 | import qualified Data.Tuple 6 | import qualified Data.List 7 | 8 | __ :: any 9 | __ = P.error "Logical or arity value used" 10 | 11 | eq_rect :: a1 -> a2 -> a1 -> a2 12 | eq_rect _ f _ = 13 | f 14 | 15 | eq_rec :: a1 -> a2 -> a1 -> a2 16 | eq_rec = 17 | eq_rect 18 | 19 | eq_rec_r :: a1 -> a2 -> a1 -> a2 20 | eq_rec_r = 21 | eq_rec 22 | 23 | data Bool = 24 | True 25 | | False 26 | 27 | orb :: Bool -> Bool -> Bool 28 | orb b1 b2 = 29 | case b1 of { 30 | True -> True; 31 | False -> b2} 32 | 33 | data Nat = 34 | O 35 | | S Nat 36 | 37 | nat_rect :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 38 | nat_rect f f0 n = 39 | case n of { 40 | O -> f; 41 | S n0 -> f0 n0 (nat_rect f f0 n0)} 42 | 43 | nat_rec :: a1 -> (Nat -> a1 -> a1) -> Nat -> a1 44 | nat_rec = 45 | nat_rect 46 | 47 | data Option a = 48 | Some a 49 | | None 50 | 51 | data Prod a b = 52 | Pair a b 53 | 54 | fst :: (Prod a1 a2) -> a1 55 | fst p = 56 | case p of { 57 | Pair x _ -> x} 58 | 59 | snd :: (Prod a1 a2) -> a2 60 | snd p = 61 | case p of { 62 | Pair _ y -> y} 63 | 64 | data List a = 65 | Nil 66 | | Cons a (List a) 67 | 68 | app :: (List a1) -> (List a1) -> List a1 69 | app l m = 70 | case l of { 71 | Nil -> m; 72 | Cons a l1 -> Cons a (app l1 m)} 73 | 74 | type Sig a = a 75 | -- singleton inductive, whose constructor was exist 76 | 77 | data SigT a p = 78 | ExistT a p 79 | 80 | proj1_sig :: a1 -> a1 81 | proj1_sig e = 82 | e 83 | 84 | data Sumbool = 85 | Left 86 | | Right 87 | 88 | acc_rect :: (a1 -> () -> (a1 -> () -> a2) -> a2) -> a1 -> a2 89 | acc_rect f x = 90 | f x __ (\y _ -> acc_rect f y) 91 | 92 | well_founded_induction_type :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 93 | well_founded_induction_type x a = 94 | acc_rect (\x0 _ x1 -> x x0 x1) a 95 | 96 | well_founded_induction :: (a1 -> (a1 -> () -> a2) -> a2) -> a1 -> a2 97 | well_founded_induction = 98 | well_founded_induction_type 99 | 100 | eqb :: Nat -> Nat -> Bool 101 | eqb n m = 102 | case n of { 103 | O -> case m of { 104 | O -> True; 105 | S _ -> False}; 106 | S n' -> case m of { 107 | O -> False; 108 | S m' -> eqb n' m'}} 109 | 110 | eq_dec :: Nat -> Nat -> Sumbool 111 | eq_dec n = 112 | nat_rec (\m -> case m of { 113 | O -> Left; 114 | S _ -> Right}) (\_ iHn m -> 115 | case m of { 116 | O -> Right; 117 | S m0 -> iHn m0}) n 118 | 119 | map :: (a1 -> a2) -> (List a1) -> List a2 120 | map f l = 121 | case l of { 122 | Nil -> Nil; 123 | Cons a t -> Cons (f a) (map f t)} 124 | 125 | type Name = Nat 126 | 127 | data Term = 128 | Var Name 129 | | Cst Name 130 | | Con Name Term Term 131 | 132 | occurs :: Name -> Term -> Bool 133 | occurs n t = 134 | case t of { 135 | Var x -> eqb n x; 136 | Cst _ -> False; 137 | Con _ l r -> orb (occurs n l) (occurs n r)} 138 | 139 | type Subst = List (Prod Name Term) 140 | 141 | empty_subst :: Subst 142 | empty_subst = 143 | Nil 144 | 145 | singleton_subst :: Name -> Term -> List (Prod Name Term) 146 | singleton_subst n t = 147 | Cons (Pair n t) Nil 148 | 149 | image :: Subst -> Name -> Option Term 150 | image s n = 151 | case s of { 152 | Nil -> None; 153 | Cons p tl -> 154 | case p of { 155 | Pair m t -> case eq_dec m n of { 156 | Left -> Some t; 157 | Right -> image tl n}}} 158 | 159 | apply_subst :: Subst -> Term -> Term 160 | apply_subst s t = 161 | case t of { 162 | Var n -> case image s n of { 163 | Some t' -> t'; 164 | None -> t}; 165 | Cst _ -> t; 166 | Con n l r -> Con n (apply_subst s l) (apply_subst s r)} 167 | 168 | compose :: Subst -> Subst -> Subst 169 | compose s1 s2 = 170 | app (map (\p -> Pair (fst p) (apply_subst s2 (snd p))) s1) s2 171 | 172 | data Unification_step_outcome = 173 | NonUnifiable 174 | | Same 175 | | VarSubst Name Term 176 | 177 | create :: Name -> Term -> Unification_step_outcome 178 | create n t = 179 | case occurs n t of { 180 | True -> NonUnifiable; 181 | False -> VarSubst n t} 182 | 183 | unification_step :: Term -> Term -> Unification_step_outcome 184 | unification_step t1 t2 = 185 | case t1 of { 186 | Var n1 -> 187 | case t2 of { 188 | Var n2 -> case eq_dec n1 n2 of { 189 | Left -> Same; 190 | Right -> create n1 t2}; 191 | _ -> create n1 t2}; 192 | Cst n1 -> 193 | case t2 of { 194 | Var n2 -> create n2 t1; 195 | Cst n2 -> case eq_dec n1 n2 of { 196 | Left -> Same; 197 | Right -> NonUnifiable}; 198 | Con _ _ _ -> NonUnifiable}; 199 | Con n1 l1 r1 -> 200 | case t2 of { 201 | Var n2 -> create n2 t1; 202 | Cst _ -> NonUnifiable; 203 | Con n2 l2 r2 -> 204 | case eq_dec n1 n2 of { 205 | Left -> 206 | case unification_step l1 l2 of { 207 | Same -> unification_step r1 r2; 208 | x -> x}; 209 | Right -> NonUnifiable}}} 210 | 211 | mgu_result_exists :: Term -> Term -> SigT (Option Subst) () 212 | mgu_result_exists t1 t2 = 213 | let { 214 | h = well_founded_induction (\x h -> 215 | eq_rec_r __ (\h0 -> 216 | case x of { 217 | Pair t3 t4 -> 218 | let {u = unification_step t3 t4} in 219 | case u of { 220 | NonUnifiable -> ExistT None __; 221 | Same -> ExistT (Some empty_subst) __; 222 | VarSubst n t -> 223 | let { 224 | h1 = h0 (Pair (apply_subst (singleton_subst n t) t3) 225 | (apply_subst (singleton_subst n t) t4))} 226 | in 227 | let {h2 = h1 __} in 228 | case h2 of { 229 | ExistT x0 _ -> 230 | case x0 of { 231 | Some s -> ExistT (Some (compose (singleton_subst n t) s)) 232 | __; 233 | None -> ExistT None __}}}}) __ h) (Pair t1 t2)} 234 | in 235 | eq_rec_r __ (\h0 -> h0) __ h 236 | 237 | data Stream a = 238 | Nil0 239 | | Cons0 a (Stream a) 240 | 241 | data Goal = 242 | Fail 243 | | Cut 244 | | Unify Term Term 245 | | Disj Goal Goal 246 | | Conj Goal Goal 247 | | Fresh (Name -> Goal) 248 | | Invoke Name Term 249 | 250 | type Rel = Term -> Goal 251 | 252 | type Def = Rel 253 | 254 | type Spec = Name -> Def 255 | 256 | data Cutting_mark = 257 | StopCutting 258 | | KeepCutting 259 | 260 | data Nt_state = 261 | Leaf Goal Subst Nat 262 | | Sum Cutting_mark Nt_state Nt_state 263 | | Prod0 Nt_state Goal 264 | 265 | nt_state_rect :: (Goal -> Subst -> Nat -> a1) -> (Cutting_mark -> Nt_state -> 266 | a1 -> Nt_state -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> 267 | a1) -> Nt_state -> a1 268 | nt_state_rect f f0 f1 n = 269 | case n of { 270 | Leaf g s n0 -> f g s n0; 271 | Sum c n0 n1 -> 272 | f0 c n0 (nt_state_rect f f0 f1 n0) n1 (nt_state_rect f f0 f1 n1); 273 | Prod0 n0 g -> f1 n0 (nt_state_rect f f0 f1 n0) g} 274 | 275 | nt_state_rec :: (Goal -> Subst -> Nat -> a1) -> (Cutting_mark -> Nt_state -> 276 | a1 -> Nt_state -> a1 -> a1) -> (Nt_state -> a1 -> Goal -> a1) 277 | -> Nt_state -> a1 278 | nt_state_rec = 279 | nt_state_rect 280 | 281 | data State = 282 | Stop 283 | | NTState Nt_state 284 | 285 | data Label = 286 | Step 287 | | Answer Subst Nat 288 | 289 | data Cut_signal = 290 | NoCutting 291 | | YesCutting 292 | 293 | eval_step_exists :: Nt_state -> SigT Label (SigT Cut_signal (SigT State ())) 294 | eval_step_exists nst = 295 | nt_state_rec (\g s n -> 296 | case g of { 297 | Fail -> ExistT Step (ExistT NoCutting (ExistT Stop __)); 298 | Cut -> ExistT (Answer s n) (ExistT YesCutting (ExistT Stop __)); 299 | Unify t t0 -> 300 | let {h = mgu_result_exists (apply_subst s t) (apply_subst s t0)} in 301 | case h of { 302 | ExistT x _ -> 303 | case x of { 304 | Some s0 -> ExistT (Answer (compose s s0) n) (ExistT NoCutting 305 | (ExistT Stop __)); 306 | None -> ExistT Step (ExistT NoCutting (ExistT Stop __))}}; 307 | Disj g1 g2 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Sum 308 | StopCutting (Leaf g1 s n) (Leaf g2 s n))) __)); 309 | Conj g1 g2 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Prod0 310 | (Leaf g1 s n) g2)) __)); 311 | Fresh g0 -> ExistT Step (ExistT NoCutting (ExistT (NTState (Leaf 312 | (g0 n) s (S n))) __)); 313 | Invoke n0 t -> ExistT Step (ExistT NoCutting (ExistT (NTState (Leaf 314 | (proj1_sig (prog n0) t) s n)) __))}) (\c _ iHnst1 nst2 _ -> 315 | case iHnst1 of { 316 | ExistT l1 s -> 317 | case s of { 318 | ExistT cs s0 -> 319 | case s0 of { 320 | ExistT st1 _ -> 321 | case st1 of { 322 | Stop -> 323 | case cs of { 324 | NoCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState nst2) 325 | __)); 326 | YesCutting -> 327 | case c of { 328 | StopCutting -> ExistT l1 (ExistT NoCutting (ExistT Stop __)); 329 | KeepCutting -> ExistT l1 (ExistT YesCutting (ExistT Stop __))}}; 330 | NTState n -> 331 | case cs of { 332 | NoCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState (Sum c 333 | n nst2)) __)); 334 | YesCutting -> 335 | case c of { 336 | StopCutting -> ExistT l1 (ExistT NoCutting (ExistT (NTState n) 337 | __)); 338 | KeepCutting -> ExistT l1 (ExistT YesCutting (ExistT (NTState 339 | n) __))}}}}}}) (\_ iHnst g -> 340 | case iHnst of { 341 | ExistT l s -> 342 | case s of { 343 | ExistT cs s0 -> 344 | case s0 of { 345 | ExistT st _ -> 346 | case st of { 347 | Stop -> 348 | case l of { 349 | Step -> ExistT Step (ExistT cs (ExistT Stop __)); 350 | Answer s1 n -> ExistT Step (ExistT cs (ExistT (NTState (Leaf g 351 | s1 n)) __))}; 352 | NTState n -> 353 | case l of { 354 | Step -> ExistT Step (ExistT cs (ExistT (NTState (Prod0 n g)) 355 | __)); 356 | Answer s1 n0 -> ExistT Step (ExistT cs (ExistT (NTState (Sum 357 | KeepCutting (Leaf g s1 n0) (Prod0 n g))) __))}}}}}) nst 358 | 359 | type Trace = Stream Label 360 | 361 | trace_from :: State -> Trace 362 | trace_from st = 363 | case st of { 364 | Stop -> Nil0; 365 | NTState nst -> 366 | case eval_step_exists nst of { 367 | ExistT l s -> 368 | case s of { 369 | ExistT _ s0 -> 370 | case s0 of { 371 | ExistT nst' _ -> Cons0 l (trace_from nst')}}}} 372 | 373 | op_sem_exists :: State -> SigT Trace () 374 | op_sem_exists st = 375 | ExistT (trace_from st) __ 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | {- Nats and ints -} 385 | 386 | int_to_nat :: P.Int -> Nat 387 | int_to_nat n | n P.== 0 = O 388 | | P.otherwise = S (int_to_nat (n P.- 1)) 389 | 390 | nat_to_int :: Nat -> P.Int 391 | nat_to_int O = 0 392 | nat_to_int (S n) = (nat_to_int n) P.+ 1 393 | 394 | instance P.Show Nat where 395 | show n = P.show (nat_to_int n) 396 | 397 | instance P.Eq Nat where 398 | a == b = (nat_to_int a) P.== (nat_to_int b) 399 | 400 | 401 | {- Usual terms and terms -} 402 | 403 | data UsualTerm = UVar Name | UCon P.String [UsualTerm] 404 | 405 | v i = UVar (int_to_nat i) 406 | c = UCon 407 | cst s = UCon s [] 408 | 409 | constr_names :: [(P.Int, P.String)] 410 | constr_names = 411 | [ 412 | (0, "_app"), 413 | (1, "_nil"), 414 | (2, "_cons"), 415 | 416 | (3, "z"), 417 | (4, "s"), 418 | (5, "nil"), 419 | (6, "cons") 420 | ] 421 | 422 | constr_name_id :: P.String -> Name 423 | constr_name_id s = int_to_nat (Data.Maybe.fromMaybe (P.error "no such constr name") 424 | (P.lookup s (P.map Data.Tuple.swap constr_names))) 425 | 426 | constr_id_name :: Name -> P.String 427 | constr_id_name n = Data.Maybe.fromMaybe (P.error "no such constr name") 428 | (P.lookup (nat_to_int n) constr_names) 429 | 430 | usual_term_to_term :: UsualTerm -> Term 431 | usual_term_to_term (UVar n) = Var n 432 | usual_term_to_term (UCon s uts) = Con (constr_name_id "_app") 433 | (Cst (constr_name_id s)) 434 | (usual_list_to_term uts) 435 | 436 | usual_list_to_term :: [UsualTerm] -> Term 437 | usual_list_to_term uts = P.foldr (Con (constr_name_id "_cons")) 438 | (Cst (constr_name_id "_nil")) 439 | (P.map usual_term_to_term uts) 440 | 441 | 442 | 443 | instance P.Show Term where 444 | show (Var n) = "v" P.++ (P.show n) -- result of variable translation 445 | show (Con _ (Cst n) (Cst _)) = constr_id_name n -- result of constant translation 446 | show (Con _ (Cst n) (Con _ at ats)) = constr_id_name n P.++ -- result of constructor translation 447 | "(" P.++ 448 | (P.show at) P.++ 449 | (show_arg_terms ats) P.++ 450 | ")" 451 | 452 | show_arg_terms (Cst _) = "" 453 | show_arg_terms (Con _ t ts) = ", " P.++ (P.show t) P.++ (show_arg_terms ts) 454 | 455 | 456 | {- Prolog to miniKanren translation -} 457 | 458 | data Atom = Atom P.String [UsualTerm] 459 | 460 | data Conjunct = CAtom Atom | CCut 461 | 462 | data DefClause = DefClause Atom [Conjunct] 463 | 464 | type PrologProg = [DefClause] 465 | 466 | 467 | atom = Atom 468 | catom s ts = CAtom (Atom s ts) 469 | ccut = CCut 470 | (<=) = DefClause 471 | 472 | pred_name_id :: P.String -> Name 473 | pred_name_id s = int_to_nat (Data.Maybe.fromMaybe (P.error "no such pred name") 474 | (P.lookup s (P.map Data.Tuple.swap pred_names))) 475 | 476 | pred_id_name :: Name -> P.String 477 | pred_id_name n = Data.Maybe.fromMaybe (P.error "no such pred name") 478 | (P.lookup (nat_to_int n) pred_names) 479 | 480 | 481 | rename_fvs_in_usual_term :: [(Name, Name)] -> UsualTerm -> UsualTerm 482 | rename_fvs_in_usual_term renamer (UVar n) = UVar (Data.Maybe.fromMaybe (P.error "no such free var") 483 | (P.lookup n renamer)) 484 | rename_fvs_in_usual_term renamer (UCon s uts) = UCon s (P.map (rename_fvs_in_usual_term renamer) uts) 485 | 486 | translate_atom :: Atom -> Goal 487 | translate_atom (Atom p uts) = Invoke (pred_name_id p) (usual_list_to_term uts) 488 | 489 | translate_conjunct_with_subst :: [(Name, Name)] -> Conjunct -> Goal 490 | translate_conjunct_with_subst renamer CCut = Cut 491 | translate_conjunct_with_subst renamer (CAtom (Atom p uts)) = 492 | Invoke (pred_name_id p) (usual_list_to_term (P.map (rename_fvs_in_usual_term renamer) uts)) 493 | 494 | 495 | translate_def_clause_with_subst :: Term -> [UsualTerm] -> [Conjunct] -> [Name] -> [(Name, Name)] -> Goal 496 | translate_def_clause_with_subst arg pred_args cs [] renamer = 497 | P.foldl Conj 498 | (Unify arg (usual_list_to_term (P.map (rename_fvs_in_usual_term renamer) pred_args))) 499 | (P.map (translate_conjunct_with_subst renamer) cs) 500 | translate_def_clause_with_subst arg pred_args cs (x : fvs) renamer = 501 | Fresh (\u -> translate_def_clause_with_subst arg pred_args cs fvs ((x, u) : renamer)) 502 | 503 | fv_of_usual_term :: UsualTerm -> [Name] 504 | fv_of_usual_term (UVar n) = [n] 505 | fv_of_usual_term (UCon _ ts) = fv_of_usual_term_list ts 506 | 507 | fv_of_usual_term_list :: [UsualTerm] -> [Name] 508 | fv_of_usual_term_list ts = P.foldr Data.List.union [] (P.map fv_of_usual_term ts) 509 | 510 | fv_of_conjuct :: Conjunct -> [Name] 511 | fv_of_conjuct (CAtom (Atom _ ts)) = fv_of_usual_term_list ts 512 | fv_of_conjuct CCut = [] 513 | 514 | fv_of_conjuct_list :: [Conjunct] -> [Name] 515 | fv_of_conjuct_list cs = P.foldr Data.List.union [] (P.map fv_of_conjuct cs) 516 | 517 | translate_def_clause :: Term -> DefClause -> Goal 518 | translate_def_clause arg (DefClause (Atom _ ts) cs) = 519 | translate_def_clause_with_subst arg ts cs 520 | (Data.List.union (fv_of_usual_term_list ts) (fv_of_conjuct_list cs)) 521 | [] 522 | 523 | translate_prog :: PrologProg -> Spec 524 | translate_prog pp = \r arg -> P.foldr Disj Fail P.$ 525 | P.map (\dc -> translate_def_clause arg dc) P.$ 526 | P.filter (\dc -> def_clause_predicate_id dc P.== pred_id_name r) pp 527 | where 528 | def_clause_predicate_id (DefClause (Atom p _) _) = p 529 | 530 | 531 | 532 | {- Program (all predicate definitions) and test goals -} 533 | 534 | pred_names :: [(P.Int, P.String)] 535 | pred_names = 536 | [ 537 | (0, "div"), 538 | (1, "nat"), 539 | (2, "q"), 540 | (3, "p"), 541 | (4, "a"), 542 | (5, "b"), 543 | (6, "c"), 544 | (7, "eq"), 545 | (8, "le"), 546 | (9, "max"), 547 | (10, "badMax") 548 | ] 549 | 550 | prog :: Spec 551 | prog = translate_prog P.$ 552 | [ 553 | atom "div" [] <= [catom "div" []], 554 | atom "div" [] <= [], 555 | 556 | atom "nat" [cst "z"] <= [], 557 | atom "nat" [c "s" [v 0]] <= [catom "nat" [v 0]], 558 | 559 | atom "q" [v 0] <= [ccut], 560 | atom "q" [c "s" [cst "z"]] <= [], 561 | 562 | atom "p" [v 0] <= [catom "q" [v 0]], 563 | atom "p" [c "s" [c "s" [cst "z"]]] <= [], 564 | 565 | atom "a" [cst "z"] <= [], 566 | atom "a" [c "s" [cst "z"]] <= [], 567 | 568 | atom "b" [c "s" [c "s" [cst "z"]], cst "z"] <= [], 569 | atom "b" [v 0, v 1] <= [catom "a" [v 0], 570 | ccut, 571 | catom "a" [v 1]], 572 | atom "b" [c "s" [c "s" [c "s" [cst "z"]]], cst "z"] <= [], 573 | 574 | atom "c" [c "s" [c "s" [c "s" [c "s" [cst "z"]]]], cst "z", cst "z", cst "z"] <= [], 575 | atom "c" [v 0, v 1, v 2, v 3] <= [catom "a" [v 0], 576 | catom "b" [v 1, v 2], 577 | catom "a" [v 3]], 578 | atom "c" [c "s" [c "s" [c "s" [c "s" [c "s" [cst "z"]]]]], cst "z", cst "z", cst "z"] <= [], 579 | 580 | atom "eq" [v 0, v 0] <= [], 581 | 582 | atom "le" [cst "z", v 0] <= [], 583 | atom "le" [c "s" [v 0], c "s" [v 1]] <= [catom "le" [v 0, v 1]], 584 | 585 | atom "max" [v 0, v 1, v 2] <= [catom "le" [v 0, v 1], 586 | ccut, 587 | catom "eq" [v 1, v 2]], 588 | atom "max" [v 0, v 1, v 0] <= [], 589 | 590 | atom "badMax" [v 0, v 1, v 1] <= [catom "le" [v 0, v 1], 591 | ccut], 592 | atom "badMax" [v 0, v 1, v 0] <= [] 593 | ] 594 | 595 | 596 | goal0 = atom "div" [] -- should diverge 597 | 598 | goal1 = atom "nat" [v 0] -- should return infinite stream 599 | 600 | goal2 = atom "p" [v 0] 601 | 602 | goal3 = atom "c" [v 0, v 1, v 2, v 3] 603 | 604 | goal4 = atom "max" [c "s" [c "s" [cst "z"]], cst "z", v 0] 605 | 606 | goal5 = atom "max" [c "s" [cst "z"], c "s" [c "s" [cst "z"]], v 0] 607 | 608 | goal6 = atom "max" [c "s" [cst "z"], c "s" [c "s" [cst "z"]], c "s" [cst "z"]] 609 | 610 | goal7 = atom "badMax" [c "s" [cst "z"], c "s" [c "s" [cst "z"]], c "s" [cst "z"]] 611 | 612 | 613 | {- Interpretation -} 614 | 615 | instance (P.Show a, P.Show b) => P.Show (Prod a b) where 616 | show (Pair x v) = P.show x P.++ " -> " P.++ P.show v 617 | 618 | instance P.Show a => P.Show (List a) where 619 | show Nil = [] 620 | show (Cons h t) = "[" P.++ 621 | (P.show h) P.++ 622 | (show_tail t) P.++ 623 | "]" 624 | 625 | show_tail Nil = "" 626 | show_tail (Cons h t) = ", " P.++ (P.show h) P.++ (show_tail t) 627 | 628 | streamToList :: Stream a -> [a] 629 | streamToList Nil0 = [] 630 | streamToList (Cons0 x xs) = x : streamToList xs 631 | 632 | initState :: P.Int -> Atom -> State 633 | initState n a = NTState (Leaf (translate_atom a) Nil (int_to_nat n)) 634 | 635 | interpret :: P.Int -> Atom -> [Subst] 636 | interpret n a = let (ExistT t _) = op_sem_exists (initState n a) 637 | in P.map (\ (Answer s _) -> s) (P.filter answersOnly (streamToList t)) 638 | where 639 | answersOnly Step = P.False 640 | answersOnly (Answer _ _) = P.True 641 | -------------------------------------------------------------------------------- /src/FairConjunction/AngelicSemantics.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Coq.Lists.ListSet. 4 | Require Import Coq.Program.Equality. 5 | Require Import Omega. 6 | Require Import Extraction. 7 | 8 | Require Import Unification. 9 | Require Import Streams. 10 | Require Import Language. 11 | Require Import DenotationalSem. 12 | Require Import OperationalSem. 13 | 14 | (******************************** States ****************************) 15 | 16 | (* Non-terminal state *) 17 | Inductive nt_state : Set := 18 | Leaf : forall (theta : subst) (i : nat) (r : list (name * term)), nt_state 19 | | Sum : forall (left right : nt_state), nt_state. 20 | 21 | (* State *) 22 | Inductive state : Set := 23 | Stop : state 24 | | NTState : forall (st : nt_state), state. 25 | 26 | (* Functions on states *) 27 | Fixpoint union (x y : state) : state := 28 | match x with 29 | | Stop => y 30 | | NTState sx => match y with 31 | | Stop => x 32 | | NTState sy => NTState (Sum sx sy) 33 | end 34 | end. 35 | 36 | (* The context is represented as a list zipper *) 37 | Definition context : Set := (list (name * term) * list (name * term)). 38 | 39 | Fixpoint push_nt (ctx : context) (st : nt_state) : nt_state := 40 | match st with 41 | | Sum l r => Sum (push_nt ctx l) (push_nt ctx r) 42 | | Leaf theta i r => Leaf theta i (concat [fst ctx; r; snd ctx]) 43 | end. 44 | 45 | Definition push (ctx : context) (st : state) : state := 46 | match st with 47 | | Stop => Stop 48 | | NTState st => NTState (push_nt ctx st) 49 | end. 50 | 51 | (* Free variables of nt_state *) 52 | Inductive is_fv_of_nt_state : name -> nt_state -> Prop := 53 | | isfvnstLeaf : forall x theta i r 54 | (X_FV_R : Exists (fun p => In x (fv_term (snd p))) r) 55 | (X_IN_DOM : in_subst_dom theta x) 56 | (X_IN_VRAN : in_subst_vran theta x), is_fv_of_nt_state x (Leaf theta i r) 57 | | isfvnstSumL : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst1), 58 | is_fv_of_nt_state x (Sum nst1 nst2) 59 | | isfvnstSumR : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst2), 60 | is_fv_of_nt_state x (Sum nst1 nst2). 61 | 62 | Hint Constructors is_fv_of_nt_state : core. 63 | 64 | Inductive is_fv_of_state : name -> state -> Prop := 65 | | isfvstC : forall x nst (X_FV_NT_ST : is_fv_of_nt_state x nst), 66 | is_fv_of_state x (NTState nst). 67 | 68 | Hint Constructors is_fv_of_state : core. 69 | 70 | Inductive is_counter_of_nt_state : nat -> nt_state -> Prop := 71 | | iscnstLeaf : forall theta i r, is_counter_of_nt_state i (Leaf theta i r) 72 | | iscnstSumL : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst1), 73 | is_counter_of_nt_state n (Sum nst1 nst2) 74 | | iscnstSumR : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst2), 75 | is_counter_of_nt_state n (Sum nst1 nst2). 76 | 77 | Hint Constructors is_counter_of_nt_state : core. 78 | 79 | Inductive well_formed_nt_state : nt_state -> Prop := 80 | | wfLeaf : forall theta r frn 81 | (DOM_LT_COUNTER : forall x (X_IN_DOM : in_subst_dom theta x), x < frn) 82 | (VRAN_LT_COUNTER : forall x (X_IN_VRAN : in_subst_vran theta x), x < frn) 83 | (FV_LT_COUNTER : forall x (X_FV : Exists (fun p => In x (fv_term (snd p))) r), x < frn), 84 | well_formed_nt_state (Leaf theta frn r) 85 | | wfSum : forall nst1 nst2 (WF_L : well_formed_nt_state nst1) 86 | (WF_R : well_formed_nt_state nst2), 87 | well_formed_nt_state (Sum nst1 nst2). 88 | 89 | Hint Constructors well_formed_nt_state : core. 90 | 91 | (*********************** One-step unfolding *************************) 92 | 93 | Reserved Notation "st |- g ~~> st'" (at level 0). 94 | 95 | Inductive os_eval : state -> goal -> state -> Prop := 96 | osEnd : forall g, Stop |- g ~~> Stop 97 | | osUnifyFail : forall theta i r t1 t2 98 | (MGU : mgu (apply_subst theta t1) (apply_subst theta t2) None), 99 | (NTState (Leaf theta i r)) |- Unify t1 t2 ~~> Stop 100 | | osUnifySucc : forall theta theta' i r t1 t2 101 | (MGU : mgu (apply_subst theta t1) (apply_subst theta t2) (Some theta')), 102 | (NTState (Leaf theta i r)) |- Unify t1 t2 ~~> (NTState (Leaf (compose theta theta') i r)) 103 | | osApp : forall theta i r rel t, 104 | (NTState (Leaf theta i r)) |- Invoke rel t ~~> (NTState (Leaf theta i (concat [r; [(rel, t)]]))) 105 | | osFresh : forall theta r i g st (H : (NTState (Leaf theta (S i) r)) |- g i ~~> st), 106 | (NTState (Leaf theta i r)) |- Fresh g ~~> st 107 | | osDisjGoal : forall theta r i g1 g2 st1 st2 108 | (H1 : (NTState (Leaf theta i r)) |- g1 ~~> st1) 109 | (H1 : (NTState (Leaf theta i r)) |- g2 ~~> st2), 110 | (NTState (Leaf theta i r)) |- Disj g1 g2 ~~> (union st1 st2) 111 | | osDisjState : forall st1 st2 st3 st4 g 112 | (H1 : (NTState st1) |- g ~~> st3) 113 | (H2 : (NTState st2) |- g ~~> st4), 114 | (NTState (Sum st1 st2)) |- g ~~> (union st3 st4) 115 | | osConj : forall theta i r g1 g2 st st' 116 | (H1 : (NTState (Leaf theta i r)) |- g1 ~~> st) 117 | (H2 : st |- g2 ~~> st'), 118 | (NTState (Leaf theta i r)) |- Conj g1 g2 ~~> st' 119 | where "st |- g ~~> st'" := (os_eval st g st'). 120 | 121 | Inductive unfold : subst -> nat -> name -> term -> state -> Prop := 122 | ufIntro : forall theta i rel term st 123 | (H : (NTState (Leaf theta i [])) |- (proj1_sig (Language.Prog rel) term) ~~> st), 124 | unfold theta i rel term st. 125 | 126 | (******************* Angelic semantics itself ***********************) 127 | 128 | Inductive label : Set := 129 | Step : label 130 | | Answer : subst -> label. 131 | 132 | Inductive selected_app : list (name * term) -> ((name * term) * context) -> Prop := 133 | saBase : forall p, selected_app [p] (p, ([], [])) 134 | | saHead : forall p ps, selected_app (p :: ps) (p, ([], ps)) 135 | | saTail : forall h ps p ps1 ps2 (H : selected_app ps (p, (ps1, ps2))), 136 | selected_app (h :: ps) (p, (h :: ps1, ps2)). 137 | 138 | Reserved Notation "st -- l --> st'" (at level 0). 139 | 140 | Inductive ang_eval : state -> label -> state -> Prop := 141 | angAnswer : forall theta i, (NTState (Leaf theta i [])) -- (Answer theta) --> Stop 142 | | angConjUnfold : forall theta i r name term ctx st 143 | (Hs : selected_app r ((name, term), ctx)) 144 | (H : unfold theta i name term st), 145 | (NTState (Leaf theta i r)) -- Step --> (push ctx st) 146 | | angDisj : forall st1 st2 lab (H : (NTState st1) -- lab --> Stop), 147 | (NTState (Sum st1 st2)) -- lab --> (NTState st2) 148 | | angDisjStep : forall st1 st2 lab st' (H : (NTState st1) -- lab --> (NTState st')), 149 | (NTState (Sum st1 st2)) -- lab --> (NTState (Sum st2 st')) 150 | where "st -- l --> st'" := (ang_eval st l st'). 151 | 152 | 153 | -------------------------------------------------------------------------------- /src/InterleavingSearch/Completeness.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Coq.Lists.ListSet. 3 | Require Import Omega. 4 | 5 | Require Import Unification. 6 | Require Import Streams. 7 | Require Import Language. 8 | Require Import DenotationalSem. 9 | Require Import OperationalSem. 10 | 11 | 12 | Lemma search_completeness_generalized 13 | (l : nat) 14 | (g : goal) 15 | (CG : consistent_goal g) 16 | (s : subst) 17 | (n : nat) 18 | (WF : well_formed_nt_state (Leaf g s n)) 19 | (t : trace) 20 | (OP : op_sem (NTState (Leaf g s n)) t) 21 | (f : repr_fun) 22 | (DSG : [| l | g , f |]) 23 | (DSS : [ s , f ]) : 24 | exists (f' : repr_fun), {| t , f' |} /\ 25 | forall (x : name), x < n -> gt_eq (f x) (f' x). 26 | Proof. 27 | revert OP. revert t. revert CG DSG DSS WF. revert g f s n. induction l. 28 | { intros. apply in_denotational_sem_zero_lev in DSG. contradiction. } 29 | { induction g; intros; good_inversion CG. 30 | { good_inversion DSG. } 31 | { exists f. split. 32 | 2: intros; red; auto. 33 | good_inversion OP. good_inversion EV; good_inversion DSG. 34 | { destruct DSS as [fs COMP_s_fs]. red in UNI. 35 | rewrite <- (repr_fun_eq_apply _ _ t COMP_s_fs) in UNI. 36 | rewrite <- (repr_fun_eq_apply _ _ t0 COMP_s_fs) in UNI. 37 | rewrite (repr_fun_apply_compose s fs t) in UNI. 38 | rewrite (repr_fun_apply_compose s fs t0) in UNI. 39 | apply unfier_from_gt_unifier in UNI. 40 | destruct UNI as [sc [SC_UNIFIES _]]. specialize (mgu_non_unifiable _ _ MGU sc). 41 | contradiction. } 42 | { red. exists (compose s d). exists n. split. 43 | { constructor. } 44 | { apply (denotational_sem_uni _ _ _ _ MGU); auto. } } } 45 | { good_inversion OP. inversion EV; subst. 46 | apply well_formedness_preservation in EV; auto. good_inversion EV. good_inversion wfState. 47 | specialize (op_sem_exists (NTState (Leaf g1 s n))). intro p1. destruct p1 as [t1 OP1]. 48 | specialize (op_sem_exists (NTState (Leaf g2 s n))). intro p2. destruct p2 as [t2 OP2]. 49 | specialize (sum_op_sem _ _ _ _ _ OP1 OP2 OP0). intro Hinter. 50 | good_inversion DSG. 51 | { specialize (IHg1 f s n CG_G1 DSG0 DSS WF_L t1 OP1). 52 | destruct IHg1 as [f' [HinDA ff'_eq]]. exists f'. split; auto. 53 | red in HinDA. destruct HinDA as [sr [nr [Hin DSSr]]]. 54 | red. exists sr. exists nr. split; auto. constructor. 55 | apply (interleave_in _ _ _ Hinter (Answer sr nr)). auto. } 56 | { specialize (IHg2 f s n CG_G2 DSG0 DSS WF_R t2 OP2). 57 | destruct IHg2 as [f' [HinDA ff'_eq]]. exists f'. split; auto. 58 | red in HinDA. destruct HinDA as [sr [nr [Hin DSSr]]]. 59 | red. exists sr. exists nr. split; auto. constructor. 60 | apply (interleave_in _ _ _ Hinter (Answer sr nr)). auto. } } 61 | { good_inversion DSG. good_inversion OP. inversion EV; subst. 62 | specialize (op_sem_exists (NTState (Leaf g1 s n))). intro p1. destruct p1 as [t1 OP1]. 63 | assert (wfst'1 : well_formed_nt_state (Leaf g1 s n)). 64 | { constructor; good_inversion WF; auto. } 65 | specialize (IHg1 f s n CG_G1 DSG_L DSS wfst'1 t1 OP1). 66 | destruct IHg1 as [f' [HinDA ff'_eq]]. red in HinDA. 67 | destruct HinDA as [s' [n' [Hinstr' HDAS']]]. 68 | specialize (op_sem_exists (NTState (Leaf g2 s' n'))). intro p2. destruct p2 as [t2 OP2]. 69 | specialize (counter_in_trace _ _ _ _ _ _ OP1 Hinstr'). intro n_le_n'. 70 | assert (wfst'2 : well_formed_nt_state (Leaf g2 s' n')). 71 | { good_inversion WF. 72 | destruct (well_formed_subst_in_trace _ (wfNonTerminal _ wfst'1) _ OP1 _ _ Hinstr'). 73 | intros. constructor; auto. intros. 74 | apply lt_le_trans with n; auto. } 75 | assert (Hg2' : in_denotational_sem_lev_goal (S l) g2 f'). 76 | { apply closedness_condition_lev with f; auto. intros. apply ff'_eq. 77 | good_inversion WF. auto. } 78 | specialize (IHg2 f' s' n' CG_G2 Hg2' HDAS' wfst'2 t2 OP2). 79 | destruct IHg2 as [f'' [HinDA f'f''_eq]]. red in HinDA. 80 | destruct HinDA as [s'' [n'' [Hinstr'' HDAS'']]]. 81 | exists f''. split. 82 | { red. exists s''. exists n''. split; auto. 83 | constructor. eapply prod_op_sem_in; eauto. } 84 | { intros. red. apply eq_trans with (proj1_sig (f' x)). 85 | { apply ff'_eq. auto. } 86 | { apply f'f''_eq. omega. } } } 87 | { good_inversion DSG. good_inversion OP. inversion EV; subst. 88 | apply well_formedness_preservation in EV; auto. good_inversion EV. 89 | rename fn into fa. 90 | remember (fun x => if name_eq_dec x n 91 | then fa a 92 | else f x) as fn. 93 | assert (Hgn : [| S l | g n , fn |]). 94 | { good_inversion WF. apply den_sem_another_fresh_var with n a fa; auto. 95 | { intro C. apply FV_LT_COUNTER in C. omega. } 96 | { destruct (name_eq_dec n n); try contradiction. reflexivity. } 97 | { intros. destruct (name_eq_dec x n); try contradiction. auto. } } 98 | assert (DSSn : [ s , fn ]). 99 | { red. red in DSS. destruct DSS as [fs fssf'_eq]. 100 | remember (fun x => if name_eq_dec x n 101 | then fn n 102 | else fs x) as fs'. 103 | exists fs'. red. intros. red. unfold subst_repr_fun_compose. 104 | rewrite Heqfs'. rewrite Heqfn. destruct (name_eq_dec x n). 105 | { assert (H_n_is_fresh_2 : apply_subst s (Var n) = Var n). 106 | { simpl. destruct (image s n) eqn:eq; auto. 107 | good_inversion WF. assert (n < n). 108 | { apply DOM_LT_COUNTER. red. eauto. } 109 | omega. } 110 | rewrite e. rewrite H_n_is_fresh_2. simpl. 111 | destruct (name_eq_dec n n); try contradiction. auto. } 112 | { rewrite <- fssf'_eq. unfold subst_repr_fun_compose. 113 | unfold apply_subst. destruct (image s x) eqn:eq. 114 | { apply apply_repr_fun_fv. intros. good_inversion WF. 115 | assert (in_subst_vran s x0). { red. eauto. } 116 | destruct (name_eq_dec x0 n); try reflexivity. 117 | apply VRAN_LT_COUNTER in H1. omega. } 118 | { simpl. destruct (name_eq_dec x n); auto. omega. } } } 119 | specialize (H n fn s (S n) (CG_BODY n) Hgn DSSn wfState t0 OP0). 120 | destruct H as [f' [HinDA ff'_eq]]. exists f'. split. 121 | { red. red in HinDA. destruct HinDA as [s' [n' [Hinstr HDAS]]]. 122 | exists s'. exists n'. split; auto. constructor; auto. } 123 | { intros. assert (x < S n). { omega. } 124 | specialize (ff'_eq x H0). red in ff'_eq. red. rewrite <- ff'_eq. 125 | rewrite Heqfn. destruct (name_eq_dec x n); try omega. reflexivity. } } 126 | { good_inversion DSG. good_inversion OP. inversion EV; subst. 127 | apply well_formedness_preservation in EV; auto. good_inversion EV. 128 | assert (cg_body : consistent_goal (proj1_sig (Language.Prog n) t)). 129 | { remember (Language.Prog n) as d. destruct d as [rel [Hcl Hco]]. 130 | red in Hco. destruct (Hco t) as [Hcog Hcof]. auto. } 131 | specialize (IHl (proj1_sig (Language.Prog n) t) f s n0 cg_body DSG0 DSS wfState t1 OP0). 132 | destruct IHl as [f' [HinDA ff'_eq]]. exists f'. split; auto. 133 | red. red in HinDA. destruct HinDA as [s' [n' [Hinstr HDAS]]]. 134 | exists s'. exists n'. split; auto. constructor; auto. } } 135 | Qed. 136 | 137 | Lemma search_completeness 138 | (g : goal) 139 | (CG : consistent_goal g) 140 | (k : nat) 141 | (HC : closed_goal_in_context (first_nats k) g) 142 | (f : repr_fun) 143 | (t : trace) 144 | (OP : op_sem (NTState (Leaf g empty_subst k)) t) 145 | (HDS : [| g , f |]) : 146 | exists (f' : repr_fun), {| t , f' |} /\ 147 | forall (x : name), In x (first_nats k) -> gt_eq (f x) (f' x). 148 | Proof. 149 | apply in_denotational_sem_some_lev in HDS. destruct HDS as [l HDS]. 150 | assert (WF : well_formed_nt_state (Leaf g empty_subst k)). 151 | { apply well_formed_initial_state; auto. } 152 | specialize (search_completeness_generalized l g CG empty_subst k WF t OP f HDS (empty_subst_ds f)). 153 | intro. destruct H as [f' [HinDA ff'eq]]. exists f'. split; auto. 154 | intros. apply ff'eq. apply first_nats_less; auto. 155 | Qed. 156 | -------------------------------------------------------------------------------- /src/InterleavingSearch/DenotationalSem.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Coq.Lists.ListSet. 3 | Import ListNotations. 4 | 5 | Require Import Unification. 6 | Require Import Language. 7 | Require Import Omega. 8 | 9 | Lemma set_empty_union 10 | (s1 s2 : var_set) 11 | (EQ : var_set_union s1 s2 = var_set_empty) : 12 | s1 = var_set_empty /\ s2 = var_set_empty. 13 | Proof. 14 | split. 15 | { destruct s1; auto. 16 | assert (In n var_set_empty). 17 | { rewrite <- EQ. apply set_union_intro. left. constructor. auto. } 18 | inversion H. } 19 | { destruct s2; auto. 20 | assert (In n var_set_empty). 21 | { rewrite <- EQ. apply set_union_intro. right. constructor. auto. } 22 | inversion H. } 23 | Qed. 24 | 25 | 26 | 27 | (* repr funs *) 28 | Definition repr_fun : Set := name -> ground_term. 29 | 30 | Definition gt_eq (gt1 : ground_term) (gt2 : ground_term) : Prop := 31 | proj1_sig gt1 = proj1_sig gt2. 32 | 33 | Definition repr_fun_eq (f1 : repr_fun) (f2 : repr_fun) : Prop := 34 | forall x, gt_eq (f1 x) (f2 x). 35 | 36 | Fixpoint apply_repr_fun (f : repr_fun) (t : term) : ground_term. 37 | refine ( 38 | match t with 39 | | Var x => f x 40 | | Cst n => exist _ (Cst n) eq_refl 41 | | Con n l r => match apply_repr_fun f l, apply_repr_fun f r with 42 | | exist _ lt lg, exist _ rt rg => exist _ (Con n lt rt) _ 43 | end 44 | end 45 | ). 46 | simpl. rewrite lg. rewrite rg. reflexivity. 47 | Defined. 48 | 49 | Lemma repr_fun_eq_apply 50 | (f1 f2 : repr_fun) 51 | (t : term) 52 | (FEQ : repr_fun_eq f1 f2) : 53 | gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t). 54 | Proof. 55 | induction t. 56 | { simpl. auto. } 57 | { reflexivity. } 58 | { red. simpl. 59 | destruct (apply_repr_fun f1 t1). destruct (apply_repr_fun f1 t2). 60 | destruct (apply_repr_fun f2 t1). destruct (apply_repr_fun f2 t2). 61 | simpl. 62 | red in IHt1. simpl in IHt1. 63 | red in IHt2. simpl in IHt2. 64 | subst. auto. } 65 | Qed. 66 | 67 | Lemma apply_repr_fun_fv 68 | (f1 f2 : repr_fun) 69 | (t : term) 70 | (F12_FV_EQ : forall x, (In x (fv_term t)) -> gt_eq (f1 x) (f2 x)) : 71 | gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t). 72 | Proof. 73 | induction t. 74 | { simpl. apply F12_FV_EQ. simpl. auto. } 75 | { unfold gt_eq. auto. } 76 | { unfold gt_eq. simpl. 77 | remember (apply_repr_fun f1 t1) as p11. destruct p11. 78 | remember (apply_repr_fun f1 t2) as p12. destruct p12. 79 | remember (apply_repr_fun f2 t1) as p21. destruct p21. 80 | remember (apply_repr_fun f2 t2) as p22. destruct p22. 81 | simpl. 82 | assert (x = x1). 83 | { apply IHt1. intros. apply F12_FV_EQ. unfold fv_term. 84 | apply (set_union_intro name_eq_dec). left. auto. } 85 | assert (x0 = x2). 86 | { apply IHt2. intros. apply F12_FV_EQ. unfold fv_term. 87 | apply (set_union_intro name_eq_dec). right. auto. } 88 | subst. auto. } 89 | Qed. 90 | 91 | Lemma repr_fun_eq_trans 92 | (f1 f2 f3 : repr_fun) 93 | (EQ12 : repr_fun_eq f1 f2) 94 | (EQ23 : repr_fun_eq f2 f3) : 95 | repr_fun_eq f1 f3. 96 | Proof. 97 | revert EQ12 EQ23. unfold repr_fun_eq. unfold gt_eq. intros. 98 | rewrite EQ12. auto. 99 | Qed. 100 | 101 | Lemma subst_of_gt 102 | (t : term) 103 | (s : subst) 104 | (f : repr_fun) 105 | (FV_IMG : forall x : name, In x (fv_term t) -> image s x = Some (proj1_sig (f x))) : 106 | apply_subst s t = proj1_sig (apply_repr_fun f t). 107 | Proof. 108 | induction t. 109 | { simpl. replace (image s n) with (Some (proj1_sig (f n))). 110 | { auto. } 111 | { symmetry. apply FV_IMG. constructor. auto. } } 112 | { auto. } 113 | { simpl. 114 | destruct (apply_repr_fun f t1). 115 | destruct (apply_repr_fun f t2). 116 | simpl. 117 | replace x with (apply_subst s t1). 118 | { replace x0 with (apply_subst s t2). 119 | { auto. } 120 | { apply IHt2. intros. apply FV_IMG. 121 | apply set_union_intro2. auto. } } 122 | { apply IHt1. intros. apply FV_IMG. 123 | apply set_union_intro1. auto. } } 124 | Qed. 125 | 126 | Definition subst_repr_fun_compose (s : subst) (f : repr_fun) : repr_fun := 127 | fun x => apply_repr_fun f (apply_subst s (Var x)). 128 | 129 | Lemma repr_fun_apply_compose 130 | (s : subst) 131 | (f : repr_fun) 132 | (t : term) : 133 | gt_eq (apply_repr_fun (subst_repr_fun_compose s f) t) (apply_repr_fun f (apply_subst s t)). 134 | Proof. 135 | induction t. 136 | { reflexivity. } 137 | { reflexivity. } 138 | { red. simpl. 139 | destruct (apply_repr_fun (subst_repr_fun_compose s f) t1). 140 | destruct (apply_repr_fun (subst_repr_fun_compose s f) t2). 141 | destruct (apply_repr_fun f (apply_subst s t1)). 142 | destruct (apply_repr_fun f (apply_subst s t2)). 143 | simpl. 144 | red in IHt1. simpl in IHt1. 145 | red in IHt2. simpl in IHt2. 146 | subst. auto. } 147 | Qed. 148 | 149 | Lemma repr_fun_eq_compose 150 | (f1 f2 : repr_fun) 151 | (EQ : repr_fun_eq f1 f2) 152 | (s : subst) : 153 | repr_fun_eq (subst_repr_fun_compose s f1) (subst_repr_fun_compose s f2). 154 | Proof. 155 | unfold repr_fun_eq. unfold repr_fun_eq in EQ. unfold subst_repr_fun_compose. 156 | intro. induction (apply_subst s (Var x)). 157 | { simpl. auto. } 158 | { reflexivity. } 159 | { unfold gt_eq. simpl. 160 | remember (apply_repr_fun f1 t1) as p11. destruct p11. 161 | remember (apply_repr_fun f1 t2) as p12. destruct p12. 162 | remember (apply_repr_fun f2 t1) as p21. destruct p21. 163 | remember (apply_repr_fun f2 t2) as p22. destruct p22. 164 | simpl. 165 | unfold gt_eq in IHt1. simpl in IHt1. rewrite IHt1. 166 | unfold gt_eq in IHt2. simpl in IHt2. rewrite IHt2. 167 | auto. } 168 | Qed. 169 | 170 | Lemma repr_fun_compose_eq 171 | (f : repr_fun) 172 | (s1 s2 : subst) 173 | (EQ : forall t, apply_subst s1 t = apply_subst s2 t) : 174 | repr_fun_eq (subst_repr_fun_compose s1 f) (subst_repr_fun_compose s2 f). 175 | Proof. 176 | unfold repr_fun_eq. unfold subst_repr_fun_compose. unfold gt_eq. 177 | intro. rewrite EQ. auto. 178 | Qed. 179 | 180 | Lemma subst_repr_fun_compose_assoc_subst 181 | (f : repr_fun) 182 | (s s' : subst) : 183 | repr_fun_eq (subst_repr_fun_compose (compose s s') f) 184 | (subst_repr_fun_compose s (subst_repr_fun_compose s' f)). 185 | Proof. 186 | unfold repr_fun_eq. intros. unfold gt_eq. 187 | replace (subst_repr_fun_compose (compose s s') f x) with 188 | (apply_repr_fun (subst_repr_fun_compose (compose s s') f) (Var x)); auto. 189 | rewrite repr_fun_apply_compose. rewrite compose_correctness. 190 | replace (subst_repr_fun_compose s (subst_repr_fun_compose s' f) x) with 191 | (apply_repr_fun (subst_repr_fun_compose s (subst_repr_fun_compose s' f)) (Var x)); auto. 192 | rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose. auto. 193 | Qed. 194 | 195 | 196 | 197 | (* denotational semantics of goals *) 198 | Reserved Notation "[| g , f |]" (at level 0). 199 | 200 | Inductive in_denotational_sem_goal : goal -> repr_fun -> Prop := 201 | | dsgUnify : forall f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)), 202 | [| Unify t1 t2 , f |] 203 | | dsgDisjL : forall f g1 g2 (DSG : in_denotational_sem_goal g1 f), 204 | [| Disj g1 g2 , f |] 205 | | dsgDisjR : forall f g1 g2 (DSG : in_denotational_sem_goal g2 f), 206 | [| Disj g1 g2 , f |] 207 | | dsgConj : forall f g1 g2 (DSG_L : [| g1 , f |]) 208 | (DSG_R : [| g2 , f |]), 209 | [| Conj g1 g2 , f |] 210 | | dsgFresh : forall f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg)) 211 | (DSG : [| fg a , fn |]) 212 | (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)), 213 | [| Fresh fg , f |] 214 | | dsgInvoke : forall r t f (DSG : [| proj1_sig (Language.Prog r) t , f |]), 215 | [| Invoke r t, f |] 216 | where "[| g , f |]" := (in_denotational_sem_goal g f). 217 | 218 | Hint Constructors in_denotational_sem_goal : core. 219 | 220 | Reserved Notation "[| n | g , f |]" (at level 0). 221 | 222 | Inductive in_denotational_sem_lev_goal : nat -> goal -> repr_fun -> Prop := 223 | | dslgUnify : forall l f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)), 224 | [| S l | Unify t1 t2 , f |] 225 | | dslgDisjL : forall l f g1 g2 (DSG : [| l | g1 , f |]), 226 | [| l | Disj g1 g2 , f |] 227 | | dslgDisjR : forall l f g1 g2 (DSG : [| l | g2 , f |]), 228 | [| l | Disj g1 g2 , f |] 229 | | dslgConj : forall l f g1 g2 (DSG_L : [| l | g1 , f |]) 230 | (DSG_R : [| l | g2 , f |]), 231 | [| l | Conj g1 g2 , f |] 232 | | dslgFresh : forall l f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg)) 233 | (DSG : [| l | (fg a) , fn |]) 234 | (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)), 235 | in_denotational_sem_lev_goal l (Fresh fg) f 236 | | dslgInvoke : forall l r t f (DSG : [| l | (proj1_sig (Language.Prog r) t) , f |]), 237 | [| S l | Invoke r t , f |] 238 | where "[| n | g , f |]" := (in_denotational_sem_lev_goal n g f). 239 | 240 | Hint Constructors in_denotational_sem_lev_goal : core. 241 | 242 | Lemma in_denotational_sem_zero_lev 243 | (g : goal) 244 | (f : repr_fun) : 245 | ~ [| 0 | g , f |]. 246 | Proof. 247 | intro. remember 0 as l. induction H; inversion Heql; auto. 248 | Qed. 249 | 250 | Lemma in_denotational_sem_lev_monotone 251 | (l : nat) 252 | (g : goal) 253 | (f : repr_fun) 254 | (DSG : [| l | g , f |]) 255 | (l' : nat) 256 | (LE: l <= l') : 257 | [| l' | g , f |]. 258 | Proof. 259 | revert LE. revert l'. induction DSG; eauto. 260 | { intros; destruct l'; auto; inversion LE. } 261 | { intros. destruct l'. 262 | { inversion LE. } 263 | { apply le_S_n in LE. auto. } } 264 | Qed. 265 | 266 | Lemma in_denotational_sem_some_lev 267 | (g : goal) 268 | (f : repr_fun) 269 | (DSG : [| g , f |]) : 270 | exists l, [| l | g , f |]. 271 | Proof. 272 | induction DSG. 273 | 1: exists 1; auto. 274 | 1-2, 4-5: destruct IHDSG; eauto. 275 | { destruct IHDSG1. destruct IHDSG2. 276 | exists (max x x0). constructor. 277 | { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_l. } 278 | { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_r. } } 279 | Qed. 280 | 281 | Lemma in_denotational_sem_drop_lev 282 | (g : goal) 283 | (f : repr_fun) 284 | (l : nat) 285 | (DSLG : [| l | g , f |]) : 286 | [| g , f |]. 287 | Proof. 288 | induction DSLG; eauto. 289 | Qed. 290 | 291 | 292 | 293 | (* denotational analog *) 294 | 295 | Definition in_denotational_sem_subst (s : subst) (f : repr_fun) : Prop := 296 | exists (f' : repr_fun), repr_fun_eq (subst_repr_fun_compose s f') f. 297 | 298 | Notation "[ s , f ]" := (in_denotational_sem_subst s f) (at level 0). 299 | 300 | Lemma empty_subst_ds 301 | (f : repr_fun) : 302 | [ empty_subst , f ]. 303 | Proof. 304 | red. exists f. red. intros. 305 | unfold subst_repr_fun_compose. rewrite apply_empty. reflexivity. 306 | Qed. 307 | 308 | Lemma unfier_from_gt_unifier 309 | (t1 t2 : term) 310 | (f : repr_fun) 311 | (F_UNIFIES : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)) : 312 | exists s, unifier s t1 t2 /\ [ s , f ]. 313 | Proof. 314 | remember (map (fun x => (x, proj1_sig (f x))) (var_set_union (fv_term t1) (fv_term t2))) as s. 315 | exists s. split. 316 | { red. red in F_UNIFIES. 317 | assert (apply_subst s t1 = proj1_sig (apply_repr_fun f t1)). 318 | { clear F_UNIFIES. 319 | assert (forall x, In x (fv_term t1) -> image s x = Some (proj1_sig (f x))). 320 | { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))). 321 | { apply set_union_intro1. auto. } 322 | remember (var_set_union (fv_term t1) (fv_term t2)). 323 | subst. apply map_image. auto. } 324 | apply subst_of_gt. auto. } 325 | assert (apply_subst s t2 = proj1_sig (apply_repr_fun f t2)). 326 | { clear F_UNIFIES. 327 | assert (forall x, In x (fv_term t2) -> image s x = Some (proj1_sig (f x))). 328 | { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))). 329 | { apply set_union_intro2. auto. } 330 | remember (var_set_union (fv_term t1) (fv_term t2)). 331 | subst. apply map_image. auto. } 332 | apply subst_of_gt. auto. } 333 | congruence. } 334 | { red. exists f. red. intros x. unfold subst_repr_fun_compose. 335 | unfold apply_subst. destruct (image s x) eqn:eq. 336 | { destruct (f x) eqn:eqfx. 337 | assert (x0 = t). 338 | { unfold image in eq. 339 | remember (var_set_union (fv_term t1) (fv_term t2)). clear Heqv. 340 | revert Heqs. revert v. 341 | induction s. 342 | { inversion eq. } 343 | { intros. destruct a as [y t0]. destruct v; good_inversion Heqs. 344 | destruct (Nat.eq_dec n x). 345 | { good_inversion eq. rewrite eqfx. auto. } 346 | { apply IHs with v; auto. } } } 347 | subst. red. simpl. clear eqfx. clear eq. induction t. 348 | { inversion e. } 349 | { auto. } 350 | { simpl in e. apply set_empty_union in e. destruct e. 351 | apply IHt1 in H. apply IHt2 in H0. simpl. 352 | destruct (apply_repr_fun f t3). simpl in H. 353 | destruct (apply_repr_fun f t4). simpl in H0. 354 | simpl. subst. auto. } } 355 | { red. auto. } } 356 | Qed. 357 | 358 | Lemma denotational_sem_uni 359 | (s d : subst) 360 | (t1 t2 : term) 361 | (MGU : mgu (apply_subst s t1) (apply_subst s t2) (Some d)) 362 | (f : repr_fun) : 363 | [ compose s d , f ] <-> [ s , f ] /\ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2). 364 | Proof. 365 | split. 366 | { intros DSS. red in DSS. destruct DSS as [f' ff'_eq]. split. 367 | { red. exists (subst_repr_fun_compose d f'). 368 | eapply repr_fun_eq_trans; eauto. 369 | red. symmetry. apply subst_repr_fun_compose_assoc_subst. } 370 | { red. 371 | specialize (repr_fun_eq_apply _ _ t1 ff'_eq). intro. rewrite <- H. 372 | specialize (repr_fun_eq_apply _ _ t2 ff'_eq). intro. rewrite <- H0. 373 | rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose. 374 | rewrite compose_correctness. rewrite compose_correctness. 375 | apply mgu_unifies in MGU. rewrite MGU. reflexivity. } } 376 | { intros [DSS F_UNIFIES]. destruct DSS as [fs COMP_s_fs]. 377 | assert (FS_UNIFIES : gt_eq (apply_repr_fun fs (apply_subst s t1)) 378 | (apply_repr_fun fs (apply_subst s t2))). 379 | { red. rewrite <- repr_fun_apply_compose. rewrite <- repr_fun_apply_compose. 380 | apply eq_trans with (proj1_sig (apply_repr_fun f t1)). 381 | { apply repr_fun_eq_apply. auto. } 382 | { apply eq_trans with (proj1_sig (apply_repr_fun f t2)); auto. 383 | symmetry. apply repr_fun_eq_apply. auto. } } 384 | apply unfier_from_gt_unifier in FS_UNIFIES. 385 | destruct FS_UNIFIES as [u [UNI DSSu]]. 386 | specialize (mgu_most_general _ _ _ u MGU UNI). intro MG_d. 387 | red in MG_d. destruct MG_d as [ds COMP_u_ds]. destruct DSSu as [fu COMP_u_fu]. 388 | red. exists (subst_repr_fun_compose ds fu). 389 | eapply repr_fun_eq_trans. 2: eauto. 390 | eapply repr_fun_eq_trans. eapply subst_repr_fun_compose_assoc_subst. 391 | eapply repr_fun_eq_trans. 2: eapply repr_fun_eq_compose; eauto. 392 | apply repr_fun_eq_compose. 393 | eapply repr_fun_eq_trans. red; symmetry; eapply subst_repr_fun_compose_assoc_subst. 394 | apply repr_fun_compose_eq. intros. rewrite COMP_u_ds. apply compose_correctness. } 395 | Qed. 396 | 397 | 398 | 399 | (* den sem properties *) 400 | Lemma closedness_condition_lev 401 | (f f' : repr_fun) 402 | (g : goal) 403 | (l : nat) 404 | (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x)) 405 | (DSG : [| l | g , f |]) : 406 | [| l | g , f' |]. 407 | Proof. 408 | revert FF'_EQ. revert f'. induction DSG; intros. 409 | { constructor. assert (gt_eq (apply_repr_fun f t1) (apply_repr_fun f' t1)). 410 | { apply apply_repr_fun_fv. auto. } 411 | assert (gt_eq (apply_repr_fun f t2) (apply_repr_fun f' t2)). 412 | { apply apply_repr_fun_fv. auto. } 413 | revert UNI H H0. unfold gt_eq. intros. congruence. } 414 | { constructor. apply IHDSG. intros. 415 | apply FF'_EQ. auto. } 416 | { apply dslgDisjR. apply IHDSG. intros. 417 | apply FF'_EQ. auto. } 418 | { constructor. 419 | { apply IHDSG1; intros; apply FF'_EQ; auto. } 420 | { apply IHDSG2; intros; apply FF'_EQ; auto. } } 421 | { remember (fun x => if name_eq_dec x a 422 | then fn a 423 | else f' x) as fn'. 424 | apply dslgFresh with fn' a; auto. 425 | { apply IHDSG. intros. rewrite Heqfn'. 426 | destruct (name_eq_dec x a). 427 | { unfold gt_eq. subst. auto. } 428 | { specialize (EASE _ n). red. rewrite EASE. 429 | apply FF'_EQ. eauto. } } 430 | { rewrite Heqfn'. intros. 431 | destruct (name_eq_dec x a); try contradiction. 432 | reflexivity. } } 433 | { constructor. apply IHDSG. intros. 434 | apply FF'_EQ. constructor. 435 | remember (Language.Prog r). destruct d as [rel [Hcl Hco]]. 436 | simpl in H. red in Hcl. red in Hcl. auto. } 437 | Qed. 438 | 439 | Lemma closedness_condition 440 | (f f' : repr_fun) 441 | (g : goal) 442 | (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x)) 443 | (DSG : [| g , f |]) : 444 | [| g , f' |]. 445 | Proof. 446 | apply in_denotational_sem_some_lev in DSG. 447 | destruct DSG as [l DSLG]. 448 | eapply in_denotational_sem_drop_lev. 449 | eapply closedness_condition_lev; eauto. 450 | Qed. 451 | 452 | Lemma den_sem_rename_var 453 | (g1 g2 : goal) 454 | (CG : consistent_goal g1) 455 | (n : nat) 456 | (G1_BOUND : forall x : name, is_fv_of_goal x g1 -> x < n) 457 | (G2_BOUND : forall x : name, is_fv_of_goal x g2 -> x < n) 458 | (a1 a2 : name) 459 | (A12_NEQ : a1 <> a2) 460 | (A2_FRESH : ~ is_fv_of_goal a2 g1) 461 | (REN : renaming a1 a2 g1 g2) 462 | (fa1 fa2 : repr_fun) 463 | (l : nat) 464 | (DSG1 : [| l | g1 , fa1 |]) 465 | (F_SWITCH : gt_eq (fa1 a1) (fa2 a2)) 466 | (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) : 467 | [| l | g2 , fa2 |]. 468 | Proof. 469 | revert CG G1_BOUND G2_BOUND A12_NEQ A2_FRESH REN DSG1 F_SWITCH F12_EQ. 470 | revert g1 g2 n a1 a2 fa1 fa2. 471 | induction l. 472 | { intros. apply in_denotational_sem_zero_lev in DSG1. contradiction. } 473 | { induction g1; intros; good_inversion DSG1; good_inversion REN; good_inversion CG. 474 | { constructor. 475 | etransitivity. 476 | 2: etransitivity. 477 | 2: apply UNI. 478 | 1-2: etransitivity. 479 | 1, 3: symmetry. 480 | 1, 4: apply repr_fun_apply_compose. 481 | all: apply apply_repr_fun_fv; intros; unfold subst_repr_fun_compose; 482 | simpl; destruct (Nat.eq_dec a1 x); subst; symmetry; auto; 483 | apply F12_EQ; auto; intro; subst; auto. } 484 | { apply dslgDisjL; eauto. eapply IHg1_1; eauto. } 485 | { apply dslgDisjR; eauto. eapply IHg1_2; eauto. } 486 | { constructor; eauto. 487 | { eapply IHg1_1; eauto. } 488 | { eapply IHg1_2; eauto. } } 489 | { apply closedness_condition_lev with fa1. 490 | { intros; apply F12_EQ; intro; subst; auto. } 491 | { econstructor. 492 | 2: eauto. 493 | all: eauto. } } 494 | { rename g into fg. rename fn into fn1. rename a into a0. red in CB_FG. 495 | assert (very_fresh_var : exists y, a0 <> y /\ a2 <> y /\ 496 | (~ is_fv_of_goal y (Fresh fg)) /\ 497 | (~ is_fv_of_goal y (Fresh rfg))). 498 | { destruct (name_eq_dec a0 n); destruct (name_eq_dec a0 (S n)); 499 | destruct (name_eq_dec a2 n); destruct (name_eq_dec a2 (S n)); subst; try omega. 500 | 5, 6, 8, 9: exists n. 501 | 1, 3, 9: exists (S n). 502 | 4, 5: exists (S (S n)). 503 | all: repeat split; try omega. 504 | all: intro CH; try apply G1_BOUND in CH; try apply G2_BOUND in CH; omega. } 505 | destruct very_fresh_var as [a3 [a03_neq [a23_neq [a3_fresh a3_rfresh]]]]. 506 | assert (a13_neq : a1 <> a3). 507 | { intro; subst; auto. } 508 | remember (fun x => if name_eq_dec x a3 509 | then fn1 a0 510 | else if name_eq_dec x a0 511 | then fa2 a0 512 | else fn1 x) as fn0 eqn:fn0_def. 513 | assert (AH0 : in_denotational_sem_lev_goal (S l) (fg a3) fn0). 514 | { subst. 515 | apply H with a0 (max n (max (S a0) (S a3))) a0 a3 fn1; eauto. 516 | { intros. destruct (name_eq_dec x a0); subst. 517 | { zify. omega. } 518 | { assert (x < n); eauto. zify. omega. } } 519 | { intros. destruct (name_eq_dec x a3); subst. 520 | { zify. omega. } 521 | { assert (x < n); eauto. zify. omega. } } 522 | { destruct (name_eq_dec a3 a3); subst. 523 | { reflexivity. } 524 | { contradiction. } } 525 | { intros. destruct (name_eq_dec x a3). 526 | { contradiction. } 527 | { destruct (name_eq_dec x a0). 528 | { contradiction. } 529 | { reflexivity. } } } } 530 | remember (fun x => if name_eq_dec x a2 531 | then fn0 a1 532 | else if name_eq_dec x a1 533 | then fa2 a1 534 | else fn0 x) as fn2 eqn:fn2_def. 535 | assert (AH2 : in_denotational_sem_lev_goal (S l) (rfg a3) fn2). 536 | { apply H with a3 (max n (max (S a0) (S a3))) a1 a2 fn0; subst; eauto. 537 | { intros. destruct (name_eq_dec x a3); subst. 538 | { zify. omega. } 539 | { assert (x < n); eauto. zify. omega. } } 540 | { intros. destruct (name_eq_dec x a3); subst. 541 | { zify. omega. } 542 | { assert (x < n); eauto. zify. omega. } } 543 | { simpl. destruct (name_eq_dec a2 a2); subst. 544 | { reflexivity. } 545 | { contradiction. } } 546 | { intros. simpl. destruct (name_eq_dec x a2). 547 | { contradiction. } 548 | { destruct (name_eq_dec x a1). 549 | { contradiction. } 550 | { reflexivity. } } } } 551 | econstructor; eauto. 552 | intros. subst. destruct (name_eq_dec x a2); subst. 553 | { destruct (name_eq_dec a1 a0); subst. 554 | { contradiction. } 555 | { destruct (name_eq_dec a1 a3); subst. 556 | { contradiction. } 557 | { etransitivity. 558 | { apply EASE. auto. } 559 | { auto. } } } } 560 | { destruct (name_eq_dec x a1); subst. 561 | { reflexivity. } 562 | { destruct (name_eq_dec x a3). 563 | { contradiction. } 564 | { destruct (name_eq_dec x a0); subst. 565 | { reflexivity. } 566 | { etransitivity. 567 | { apply EASE. auto. } 568 | { apply F12_EQ; auto. } } } } } } 569 | { rename n into r. rename n0 into n. 570 | remember (Language.Prog r) as d. destruct d as [rel [Hcl Hco]]. 571 | red in Hco. destruct (Hco t) as [Hcog Hcof]. 572 | red in Hcl. unfold closed_goal_in_context in Hcl. 573 | econstructor. 574 | rewrite <- Heqd. simpl. 575 | eapply IHl. 576 | 7: eauto. 577 | all: simpl; eauto. } } 578 | Qed. 579 | 580 | Lemma den_sem_another_fresh_var 581 | (b : name -> goal) 582 | (CG : consistent_goal (Fresh b)) 583 | (n : nat) 584 | (FRESH_BOUND : forall x : name, is_fv_of_goal x (Fresh b) -> x < n) 585 | (a1 a2 : name) 586 | (A1_FRESH : ~ is_fv_of_goal a1 (Fresh b)) 587 | (A2_FRESH : ~ is_fv_of_goal a2 (Fresh b)) 588 | (fa1 fa2 : repr_fun) 589 | (l : nat) 590 | (DSG1 : in_denotational_sem_lev_goal l (b a1) fa1) 591 | (F_SWITCH : gt_eq (fa1 a1) (fa2 a2)) 592 | (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) : 593 | [| l | b a2 , fa2 |]. 594 | Proof. 595 | destruct (name_eq_dec a1 a2); subst. 596 | { apply closedness_condition_lev with fa1; auto. 597 | intros. destruct (name_eq_dec x a2); subst; auto. } 598 | { good_inversion CG. red in CB_FG. 599 | eapply den_sem_rename_var with (g1 := (b a1)) (n := max n (max (S a1) (S a2))); eauto. 600 | { intros. destruct (name_eq_dec x a1); subst. 601 | { zify. omega. } 602 | { assert (x < n); eauto. zify. omega. } } 603 | { intros. destruct (name_eq_dec x a2); subst. 604 | { zify. omega. } 605 | { assert (x < n); eauto. zify. omega. } } } 606 | Qed. 607 | -------------------------------------------------------------------------------- /src/InterleavingSearch/OperationalSem.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Coq.Lists.ListSet. 4 | Require Import Coq.Program.Equality. 5 | Require Import Omega. 6 | Require Import Extraction. 7 | 8 | Require Import Unification. 9 | Require Import Streams. 10 | Require Import Language. 11 | Require Import DenotationalSem. 12 | 13 | 14 | (************************* States *************************) 15 | 16 | Inductive nt_state : Set := 17 | | Leaf : goal -> subst -> nat -> nt_state 18 | | Sum : nt_state -> nt_state -> nt_state 19 | | Prod : nt_state -> goal -> nt_state. 20 | 21 | Inductive state : Set := 22 | | Stop : state 23 | | NTState : nt_state -> state. 24 | 25 | Inductive is_fv_of_nt_state : name -> nt_state -> Prop := 26 | | isfvnstLeaf : forall x g s n (X_FV_G : is_fv_of_goal x g), 27 | is_fv_of_nt_state x (Leaf g s n) 28 | | isfvnstSumL : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst1), 29 | is_fv_of_nt_state x (Sum nst1 nst2) 30 | | isfvnstSumR : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst2), 31 | is_fv_of_nt_state x (Sum nst1 nst2) 32 | | isfvnstProdL : forall x nst g (X_FV : is_fv_of_nt_state x nst), 33 | is_fv_of_nt_state x (Prod nst g) 34 | | isfvnstProdR : forall x nst g (X_FV : is_fv_of_goal x g), 35 | is_fv_of_nt_state x (Prod nst g). 36 | 37 | Hint Constructors is_fv_of_nt_state : core. 38 | 39 | Inductive is_fv_of_state : name -> state -> Prop := 40 | | isfvstC : forall x nst (X_FV_NT_ST : is_fv_of_nt_state x nst), 41 | is_fv_of_state x (NTState nst). 42 | 43 | Hint Constructors is_fv_of_state : core. 44 | 45 | Inductive is_counter_of_nt_state : nat -> nt_state -> Prop := 46 | | iscnstLeaf : forall g s n, is_counter_of_nt_state n (Leaf g s n) 47 | | iscnstSumL : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst1), 48 | is_counter_of_nt_state n (Sum nst1 nst2) 49 | | iscnstSumR : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst2), 50 | is_counter_of_nt_state n (Sum nst1 nst2) 51 | | iscnstProd : forall n nst g (ISC : is_counter_of_nt_state n nst), 52 | is_counter_of_nt_state n (Prod nst g). 53 | 54 | Hint Constructors is_counter_of_nt_state : core. 55 | 56 | Inductive well_formed_nt_state : nt_state -> Prop := 57 | | wfLeaf : forall g s frn 58 | (DOM_LT_COUNTER : forall x (X_IN_DOM : in_subst_dom s x), x < frn) 59 | (VRAN_LT_COUNTER : forall x (X_IN_VRAN : in_subst_vran s x), x < frn) 60 | (FV_LT_COUNTER : forall x (X_FV : is_fv_of_goal x g), x < frn), 61 | well_formed_nt_state (Leaf g s frn) 62 | | wfSum : forall nst1 nst2 (WF_L : well_formed_nt_state nst1) 63 | (WF_R : well_formed_nt_state nst2), 64 | well_formed_nt_state (Sum nst1 nst2) 65 | | wfProd : forall nst g (WF_L : well_formed_nt_state nst) 66 | (FV_LT_COUNTER : forall x frn (FRN_COUNTER : is_counter_of_nt_state frn nst) 67 | (X_FV : is_fv_of_goal x g), 68 | x < frn), 69 | well_formed_nt_state (Prod nst g). 70 | 71 | Hint Constructors well_formed_nt_state : core. 72 | 73 | Fixpoint first_nats (k : nat) : list nat := 74 | match k with 75 | | 0 => [] 76 | | S n => n :: first_nats n 77 | end. 78 | 79 | Lemma first_nats_less (n k : nat) (H : In n (first_nats k)) : n < k. 80 | Proof. 81 | induction k. 82 | { inversion H. } 83 | { inversion H. { omega. } { apply IHk in H0. omega. } } 84 | Qed. 85 | 86 | Lemma well_formed_initial_state 87 | (g : goal) 88 | (k : nat) 89 | (HC : closed_goal_in_context (first_nats k) g) : 90 | well_formed_nt_state (Leaf g empty_subst k). 91 | Proof. 92 | constructor. 93 | { intros. good_inversion X_IN_DOM. good_inversion H. } 94 | { intros. good_inversion X_IN_VRAN. destruct H as [t0 [H0 _]]. good_inversion H0. } 95 | { red in HC. intros. apply first_nats_less; auto. } 96 | Qed. 97 | 98 | 99 | Inductive well_formed_state : state -> Prop := 100 | | wfTerminal : well_formed_state Stop 101 | | wfNonTerminal : forall nst (wfState : well_formed_nt_state nst), 102 | well_formed_state (NTState nst). 103 | 104 | Hint Constructors well_formed_state : core. 105 | 106 | 107 | 108 | (************************** LTS ***************************) 109 | (* Labels *) 110 | Inductive label : Set := 111 | | Step : label 112 | | Answer : subst -> nat -> label. 113 | 114 | (* Transitions *) 115 | Inductive eval_step : nt_state -> label -> state -> Prop := 116 | | esFail : forall s n, eval_step (Leaf Fail s n) Step Stop 117 | | esUnifyFail : forall t1 t2 s n (MGU : mgu (apply_subst s t1) (apply_subst s t2) None), 118 | eval_step (Leaf (Unify t1 t2) s n) Step Stop 119 | | esUnifySuccess : forall t1 t2 s d n (MGU : mgu (apply_subst s t1) (apply_subst s t2) (Some d)), 120 | eval_step (Leaf (Unify t1 t2) s n) (Answer (compose s d) n) Stop 121 | | esDisj : forall g1 g2 s n, eval_step (Leaf (Disj g1 g2) s n) Step (NTState (Sum (Leaf g1 s n) (Leaf g2 s n))) 122 | | esConj : forall g1 g2 s n, eval_step (Leaf (Conj g1 g2) s n) Step (NTState (Prod (Leaf g1 s n) g2)) 123 | | esFresh : forall fg s n, eval_step (Leaf (Fresh fg) s n) Step (NTState (Leaf (fg n) s (S n))) 124 | | esInvoke : forall r arg s n, eval_step (Leaf (Invoke r arg) s n) Step (NTState (Leaf (proj1_sig (Language.Prog r) arg) s n)) 125 | | esSumE : forall nst1 nst2 l (STEP_L : eval_step nst1 l Stop), 126 | eval_step (Sum nst1 nst2) l (NTState nst2) 127 | | esSumNE : forall nst1 nst1' nst2 l (STEP_L : eval_step nst1 l (NTState nst1')), 128 | eval_step (Sum nst1 nst2) l (NTState (Sum nst2 nst1')) 129 | | esProdSE : forall nst g (STEP_L : eval_step nst Step Stop), 130 | eval_step (Prod nst g) Step Stop 131 | | esProdAE : forall nst g s n (STEP_L : eval_step nst (Answer s n) Stop), 132 | eval_step (Prod nst g) Step (NTState (Leaf g s n)) 133 | | esProdSNE : forall nst g nst' (STEP_L : eval_step nst Step (NTState nst')), 134 | eval_step (Prod nst g) Step (NTState (Prod nst' g)) 135 | | esProdANE : forall nst g s n nst' (STEP_L : eval_step nst (Answer s n) (NTState nst')), 136 | eval_step (Prod nst g) Step (NTState (Sum (Leaf g s n) (Prod nst' g))). 137 | 138 | Hint Constructors eval_step : core. 139 | 140 | Lemma counter_in_answer 141 | (nst : nt_state) 142 | (s : subst) 143 | (n : nat) 144 | (st : state) 145 | (EV : eval_step nst (Answer s n) st) : 146 | is_counter_of_nt_state n nst. 147 | Proof. 148 | remember (Answer s n). induction EV; good_inversion Heql; auto. 149 | Qed. 150 | 151 | Lemma counter_in_next_state 152 | (n : nat) 153 | (nst nst_next : nt_state) 154 | (l : label) 155 | (EV : eval_step nst l (NTState nst_next)) 156 | (ISC_NEXT : is_counter_of_nt_state n nst_next) : 157 | exists n', n' <= n /\ is_counter_of_nt_state n' nst. 158 | Proof. 159 | remember (NTState nst_next) as st. 160 | revert Heqst ISC_NEXT. revert nst_next. 161 | induction EV; intros; good_inversion Heqst. 162 | { exists n. split. 163 | { constructor. } 164 | { good_inversion ISC_NEXT; good_inversion ISC; auto. } } 165 | { exists n. split. 166 | { constructor. } 167 | { good_inversion ISC_NEXT; good_inversion ISC; auto. } } 168 | { good_inversion ISC_NEXT. exists n0. split. 169 | { repeat constructor. } 170 | { auto. } } 171 | { exists n. split. 172 | { constructor. } 173 | { good_inversion ISC_NEXT; auto. } } 174 | { exists n. split. 175 | { constructor. } 176 | { auto. } } 177 | { specialize (IHEV nst1' eq_refl). good_inversion ISC_NEXT. 178 | { exists n. split. 179 | { constructor. } 180 | { auto. } } 181 | { apply IHEV in ISC. destruct ISC as [n' [LE ISC]]. 182 | exists n'; auto. } } 183 | { good_inversion ISC_NEXT. exists n0. 184 | eapply counter_in_answer in EV. split; auto. } 185 | { specialize (IHEV nst' eq_refl). good_inversion ISC_NEXT. 186 | apply IHEV in ISC. destruct ISC as [n' [LE ISC]]. 187 | exists n'; auto. } 188 | { specialize (IHEV nst' eq_refl). good_inversion ISC_NEXT. 189 | { good_inversion ISC. exists n0. 190 | eapply counter_in_answer in EV. split; auto. } 191 | { good_inversion ISC. apply IHEV in ISC0. 192 | destruct ISC0 as [n' [LE ISC]]. exists n'; auto. } } 193 | Qed. 194 | 195 | Lemma well_formed_subst_in_answer 196 | (nst : nt_state) 197 | (s : subst) 198 | (n : nat) 199 | (st : state) 200 | (EV : eval_step nst (Answer s n) st) 201 | (WF : well_formed_nt_state nst) : 202 | (forall x, in_subst_dom s x -> x < n) /\ (forall x, in_subst_vran s x -> x < n). 203 | Proof. 204 | remember (Answer s n). induction EV; good_inversion Heql; good_inversion WF; auto. 205 | assert (FV_LT_N_1 : forall x, In x (fv_term (apply_subst s0 t1)) -> x < n). 206 | { clear MGU. clear d. intros. induction t1. 207 | { simpl in H. destruct (image s0 n0) eqn:eq; auto. 208 | apply VRAN_LT_COUNTER. red. eauto. } 209 | { good_inversion H. } 210 | { simpl in H. apply (set_union_elim name_eq_dec) in H. destruct H. 211 | { apply IHt1_1; auto. intros. apply FV_LT_COUNTER. 212 | good_inversion X_FV; auto. apply fvUnifyL. simpl. 213 | apply set_union_intro. left. auto. } 214 | { apply IHt1_2; auto. intros. apply FV_LT_COUNTER. 215 | good_inversion X_FV; auto. apply fvUnifyL. simpl. 216 | apply set_union_intro. right. auto. } } } 217 | assert (FV_LT_N_2 : forall x, In x (fv_term (apply_subst s0 t2)) -> x < n). 218 | { clear MGU. clear d. intros. induction t2. 219 | { simpl in H. destruct (image s0 n0) eqn:eq; auto. 220 | apply VRAN_LT_COUNTER. red. eauto. } 221 | { good_inversion H. } 222 | { simpl in H. apply (set_union_elim name_eq_dec) in H. destruct H. 223 | { apply IHt2_1; auto. intros. apply FV_LT_COUNTER. 224 | good_inversion X_FV; auto. apply fvUnifyR. simpl. 225 | apply set_union_intro. left. auto. } 226 | { apply IHt2_2; auto. intros. apply FV_LT_COUNTER. 227 | good_inversion X_FV; auto. apply fvUnifyR. simpl. 228 | apply set_union_intro. right. auto. } } } 229 | specialize (mgu_dom _ _ _ MGU). intro S'_DOM. 230 | specialize (mgu_vran _ _ _ MGU). intro S'_VRAN. 231 | split. 232 | { intros. apply compose_dom in H. destruct H; auto. 233 | apply S'_DOM in H. destruct H; auto. } 234 | { intros. apply compose_vran in H. destruct H; auto. 235 | apply S'_VRAN in H. destruct H; auto. } 236 | Qed. 237 | 238 | Lemma well_formedness_preservation 239 | (nst : nt_state) 240 | (l : label) 241 | (st : state) 242 | (EV : eval_step nst l st) 243 | (WF : well_formed_nt_state nst) : 244 | well_formed_state st. 245 | Proof. 246 | intros. induction EV; good_inversion WF; auto. 247 | { constructor. auto. } 248 | { constructor. constructor; auto. 249 | intros. good_inversion FRN_COUNTER. subst. auto. } 250 | { constructor. constructor; auto. 251 | 1-2: intros; eapply lt_trans; eauto. 252 | intros. destruct (eq_nat_dec n x). 253 | { omega. } 254 | { apply Nat.lt_lt_succ_r. apply FV_LT_COUNTER. econstructor; eauto. } } 255 | { constructor. constructor; auto. 256 | specialize (proj2_sig (Language.Prog r)). intro CC. 257 | simpl in CC. destruct CC as [CL _]. red in CL. red in CL. auto. } 258 | { specialize (IHEV WF_L). 259 | good_inversion IHEV. auto. } 260 | { constructor. constructor; auto. 261 | 1-2: apply well_formed_subst_in_answer in EV; destruct EV; auto. 262 | intros. apply FV_LT_COUNTER; auto. eapply counter_in_answer; eauto. } 263 | { specialize (IHEV WF_L). good_inversion IHEV. 264 | constructor. constructor; auto. intros. 265 | eapply counter_in_next_state in EV; eauto. 266 | destruct EV as [frn' [LE ISC]]. eapply lt_le_trans. 267 | 2: eauto. 268 | auto. } 269 | { specialize (IHEV WF_L). good_inversion IHEV. 270 | constructor. constructor. 271 | { constructor. 272 | 1-2: apply well_formed_subst_in_answer in EV; destruct EV; auto. 273 | intros. apply FV_LT_COUNTER; auto. 274 | eapply counter_in_answer; eauto. } 275 | { constructor; auto. intros. 276 | eapply counter_in_next_state in EV; eauto. 277 | destruct EV as [frn' [Le ISC]]. eapply lt_le_trans. 278 | 2: eauto. 279 | auto. } } 280 | Qed. 281 | 282 | Lemma eval_step_exists 283 | (nst : nt_state) : 284 | {l : label & {st : state & eval_step nst l st}}. 285 | Proof. 286 | induction nst. 287 | { destruct g. 288 | 1,3-6: repeat eexists; econstructor. 289 | { assert ({r & mgu (apply_subst s t) (apply_subst s t0) r}). 290 | { apply mgu_result_exists. } 291 | destruct H. destruct x. 292 | { repeat eexists; eauto. } 293 | { repeat eexists; eauto. } } } 294 | { destruct IHnst1 as [l1 [st1 IH1]]. destruct st1. 295 | all: repeat eexists; eauto. } 296 | { destruct IHnst as [l [st IH]]. destruct st; destruct l. 297 | all: repeat eexists; eauto. } 298 | Defined. 299 | 300 | Lemma eval_step_unique 301 | (nst : nt_state) 302 | (l1 l2 : label) 303 | (st1 st2 : state) 304 | (STEP_1 : eval_step nst l1 st1) 305 | (STEP_2 : eval_step nst l2 st2) : 306 | l1 = l2 /\ st1 = st2. 307 | Proof. 308 | revert STEP_1 STEP_2. revert l1 l2 st1 st2. induction nst. 309 | { intros. destruct g; good_inversion STEP_1; good_inversion STEP_2; auto. 310 | { assert (C : None = Some d). 311 | { eapply mgu_result_unique; eassumption. } 312 | inversion C. } 313 | { assert (C : None = Some d). 314 | { eapply mgu_result_unique; eassumption. } 315 | inversion C. } 316 | { assert (EQ : Some d = Some d0). 317 | { eapply mgu_result_unique; eassumption. } 318 | good_inversion EQ. auto. } } 319 | { intros. good_inversion STEP_1; good_inversion STEP_2; 320 | specialize (IHnst1 _ _ _ _ STEP_L STEP_L0); inversion IHnst1; 321 | inversion H0; subst; auto. } 322 | { intros. good_inversion STEP_1; good_inversion STEP_2; 323 | specialize (IHnst _ _ _ _ STEP_L STEP_L0); inversion IHnst; subst; 324 | inversion H; inversion H0; auto. } 325 | Qed. 326 | 327 | 328 | 329 | (***************** Operational Semantics ******************) 330 | 331 | Definition trace : Set := @stream label. 332 | 333 | CoInductive op_sem : state -> trace -> Prop := 334 | | osStop : op_sem Stop Nil 335 | | osNTState : forall nst l st t (EV: eval_step nst l st) 336 | (OP: op_sem st t), 337 | op_sem (NTState nst) (Cons l t). 338 | 339 | Hint Constructors op_sem : core. 340 | 341 | CoFixpoint trace_from (st : state) : trace := 342 | match st with 343 | | Stop => Nil 344 | | NTState nst => 345 | match eval_step_exists nst with 346 | | existT _ l (existT _ nst' ev_nst_nst') => 347 | Cons l (trace_from nst') 348 | end 349 | end. 350 | 351 | Lemma trace_from_correct 352 | (st : state) : 353 | op_sem st (trace_from st). 354 | Proof. 355 | revert st. cofix CIH. destruct st. 356 | { rewrite helper_eq. simpl. constructor. } 357 | { rewrite helper_eq. simpl. destruct (eval_step_exists n). 358 | destruct s. econstructor; eauto. } 359 | Qed. 360 | 361 | Lemma op_sem_exists 362 | (st : state) : 363 | {t : trace & op_sem st t}. 364 | Proof. 365 | eexists. eapply trace_from_correct. 366 | Defined. 367 | 368 | Lemma op_sem_unique 369 | (st : state) 370 | (t1 t2 : trace) 371 | (OP_1 : op_sem st t1) 372 | (OP_2 : op_sem st t2) : 373 | equal_streams t1 t2. 374 | Proof. 375 | revert OP_1 OP_2. revert t1 t2 st. 376 | cofix CIH. intros. inversion OP_1; inversion OP_2; 377 | rewrite <- H1 in H; inversion H. 378 | { constructor. } 379 | { subst. 380 | specialize (eval_step_unique _ _ _ _ _ EV EV0). 381 | intros [EQL EQST]. constructor. 382 | { auto. } 383 | { subst. eapply CIH; eauto. } } 384 | Qed. 385 | 386 | Definition in_denotational_analog (t : trace) (f : repr_fun) : Prop := 387 | exists (s : subst) (n : nat), 388 | in_stream (Answer s n) t /\ [ s , f ]. 389 | 390 | Notation "{| t , f |}" := (in_denotational_analog t f). 391 | 392 | Lemma counter_in_trace 393 | (g : goal) 394 | (s sr : subst) 395 | (n nr : nat) 396 | (tr : trace) 397 | (OP : op_sem (NTState (Leaf g s n)) tr) 398 | (HIn : in_stream (Answer sr nr) tr) : 399 | n <= nr. 400 | Proof. 401 | remember (Leaf g s n) as nst. 402 | assert (CNT_GE : forall n', is_counter_of_nt_state n' nst -> n <= n'). 403 | { intros. subst. good_inversion H. auto. } 404 | clear Heqnst. revert CNT_GE OP. revert n nst. 405 | remember (Answer sr nr). induction HIn; intros; subst. 406 | { good_inversion OP. apply counter_in_answer in EV. auto. } 407 | { good_inversion OP. destruct st. 408 | { good_inversion OP0. good_inversion HIn. } 409 | { apply IHHIn with n0; auto. intros. 410 | specialize (counter_in_next_state _ _ _ _ EV H). intros. 411 | destruct H0. destruct H0. apply CNT_GE in H1. 412 | eapply le_trans; eauto. } } 413 | Qed. 414 | 415 | Lemma well_formed_subst_in_trace 416 | (st : state) 417 | (WF : well_formed_state st) 418 | (t : trace) 419 | (OP : op_sem st t) 420 | (s : subst) 421 | (n : nat) 422 | (IS_ANS: in_stream (Answer s n) t) : 423 | (forall x, in_subst_dom s x -> x < n) /\ (forall x, in_subst_vran s x -> x < n). 424 | Proof. 425 | remember (Answer s n). revert WF OP. revert st. 426 | induction IS_ANS; intros. 427 | { good_inversion OP. good_inversion WF. 428 | eapply well_formed_subst_in_answer; eauto. } 429 | { good_inversion OP. good_inversion WF. 430 | apply IHIS_ANS with st0; auto. 431 | eapply well_formedness_preservation; eauto. } 432 | Qed. 433 | 434 | Lemma sum_op_sem 435 | (nst1 nst2 : nt_state) 436 | (t1 t2 t : trace) 437 | (OP_1 : op_sem (NTState nst1) t1) 438 | (OP_2 : op_sem (NTState nst2) t2) 439 | (OP_12 : op_sem (NTState (Sum nst1 nst2)) t) : 440 | interleave t1 t2 t. 441 | Proof. 442 | revert OP_1 OP_2 OP_12. revert t1 t2 t nst1 nst2. 443 | cofix CIH. intros. inversion OP_1. subst. inversion OP_12. subst. 444 | inversion EV0; subst; specialize (eval_step_unique _ _ _ _ _ EV STEP_L); 445 | intros [EQL EQST]; subst; constructor. 446 | { inversion OP. subst. specialize (op_sem_unique _ _ _ OP_2 OP0). 447 | intro EQS. inversion EQS; subst. 448 | { constructor. constructor. } 449 | { constructor. constructor. auto. } } 450 | { eapply CIH; eassumption. } 451 | Qed. 452 | 453 | Lemma sum_op_sem_in 454 | (nst1 nst2 : nt_state) 455 | (t1 t2 t : trace) 456 | (r : label) 457 | (OP_1 : op_sem (NTState nst1) t1) 458 | (OP_2 : op_sem (NTState nst2) t2) 459 | (OP_12 : op_sem (NTState (Sum nst1 nst2)) t) : 460 | in_stream r t <-> in_stream r t1 \/ in_stream r t2. 461 | Proof. 462 | apply interleave_in. eapply sum_op_sem; eauto. 463 | Qed. 464 | 465 | Lemma disj_termination 466 | (g1 g2 : goal) 467 | (s : subst) 468 | (n : nat) 469 | (t1 t2 t : trace) 470 | (r : label) 471 | (OP_1 : op_sem (NTState (Leaf g1 s n)) t1) 472 | (OP_2 : op_sem (NTState (Leaf g2 s n)) t2) 473 | (OP_12 : op_sem (NTState (Leaf (Disj g1 g2) s n)) t) : 474 | finite t <-> finite t1 /\ finite t2. 475 | Proof. 476 | good_inversion OP_12. good_inversion EV. 477 | assert (forall t, finite (Cons Step t) <-> finite t). 478 | { intros; split; intros H. 479 | { inversion H; auto. } 480 | { constructor; auto. } } 481 | eapply RelationClasses.iff_Transitive. eapply (H t0). 482 | apply interleave_finite. eapply sum_op_sem; eauto. 483 | Qed. 484 | 485 | Lemma prod_op_sem_in 486 | (nst : nt_state) 487 | (g : goal) 488 | (s : subst) 489 | (n : nat) 490 | (t1 t2 t : trace) 491 | (r : label) 492 | (OP : op_sem (NTState (Prod nst g)) t) 493 | (OP1 : op_sem (NTState nst) t1) 494 | (OP2 : op_sem (NTState (Leaf g s n)) t2) 495 | (IN_1 : in_stream (Answer s n) t1) 496 | (IN_2 : in_stream r t2) : 497 | in_stream r t. 498 | Proof. 499 | revert OP OP1. revert t nst. remember (Answer s n) as r1. 500 | induction IN_1; intros; subst. 501 | { good_inversion OP1. good_inversion OP. 502 | good_inversion EV0; specialize (eval_step_unique _ _ _ _ _ EV STEP_L); 503 | intro eqs; destruct eqs; subst; good_inversion H. 504 | { constructor. specialize (op_sem_unique _ _ _ OP2 OP1). 505 | intros. eapply in_equal_streams; eauto. } 506 | { constructor. specialize (op_sem_exists (NTState (Leaf g s0 n0))). 507 | intro H. destruct H as [t3 OP3]. 508 | specialize (op_sem_exists (NTState (Prod nst' g))). 509 | intro H. destruct H as [t4 OP4]. 510 | specialize (sum_op_sem _ _ _ _ _ OP3 OP4 OP1). 511 | intro interH. eapply interleave_in in interH. 512 | eapply interH. left. specialize (op_sem_unique _ _ _ OP2 OP3). 513 | intros. eapply in_equal_streams; eauto. } } 514 | { specialize (IHIN_1 eq_refl). 515 | good_inversion OP1. good_inversion OP. 516 | good_inversion EV0; specialize (eval_step_unique _ _ _ _ _ EV STEP_L); 517 | intro eqs; destruct eqs; subst. 518 | 1-2: good_inversion OP0; good_inversion IN_1. 519 | { constructor. eapply IHIN_1; eauto. } 520 | { constructor. specialize (op_sem_exists (NTState (Leaf g s0 n0))). 521 | intro H. destruct H as [t3 OP3]. 522 | specialize (op_sem_exists (NTState (Prod nst' g))). 523 | intro H. destruct H as [t4 OP4]. 524 | specialize (sum_op_sem _ _ _ _ _ OP3 OP4 OP1). 525 | intro interH. eapply interleave_in in interH. 526 | eapply interH. right. eapply IHIN_1; eauto. } } 527 | Qed. 528 | 529 | Extraction Language Haskell. 530 | 531 | Extraction "extracted/interleaving_interpreter.hs" op_sem_exists. 532 | -------------------------------------------------------------------------------- /src/InterleavingSearch/Soundness.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Coq.Lists.ListSet. 3 | Import ListNotations. 4 | Require Import Omega. 5 | 6 | Require Import Unification. 7 | Require Import Streams. 8 | Require Import Language. 9 | Require Import DenotationalSem. 10 | Require Import OperationalSem. 11 | 12 | Inductive in_denotational_sem_nt_state : nt_state -> repr_fun -> Prop := 13 | | dsnstLeaf : forall g s n f (DSG : [| g , f |]) 14 | (DSS : [ s , f ]), 15 | in_denotational_sem_nt_state (Leaf g s n) f 16 | | dsnstSumL : forall nst1 nst2 f (DSST' : in_denotational_sem_nt_state nst1 f), 17 | in_denotational_sem_nt_state (Sum nst1 nst2) f 18 | | dsnstSumR : forall nst1 nst2 f (DSST' : in_denotational_sem_nt_state nst2 f), 19 | in_denotational_sem_nt_state (Sum nst1 nst2) f 20 | | dsnstProd : forall nst g f (DSG : [| g , f |]) 21 | (DSST' : in_denotational_sem_nt_state nst f), 22 | in_denotational_sem_nt_state (Prod nst g) f. 23 | 24 | Hint Constructors in_denotational_sem_nt_state : core. 25 | 26 | Inductive in_denotational_sem_state : state -> repr_fun -> Prop := 27 | | dsstNTState : forall nst f (DSST' : in_denotational_sem_nt_state nst f), 28 | in_denotational_sem_state (NTState nst) f. 29 | 30 | Hint Constructors in_denotational_sem_state : core. 31 | 32 | 33 | Lemma answer_correct 34 | (s : subst) 35 | (n : nat) 36 | (f : repr_fun) 37 | (DSS : [ s , f ]) 38 | (st' : nt_state) 39 | (st : state) 40 | (EV : eval_step st' (Answer s n) st) : 41 | in_denotational_sem_nt_state st' f. 42 | Proof. 43 | remember (Answer s n) as l. 44 | induction EV; good_inversion Heql; auto. 45 | { assert (DSS_copy := DSS). apply (denotational_sem_uni _ _ _ _ MGU _) in DSS. 46 | destruct DSS as [DSS EQ]. constructor; auto. } 47 | Qed. 48 | 49 | Lemma next_state_correct 50 | (f : repr_fun) 51 | (st : state) 52 | (DSS : in_denotational_sem_state st f) 53 | (st' : nt_state) 54 | (WF : well_formed_nt_state st') 55 | (h : label) 56 | (EV : eval_step st' h st) : 57 | in_denotational_sem_nt_state st' f. 58 | Proof. 59 | induction EV; good_inversion DSS. 60 | { good_inversion DSST'; good_inversion DSST'0; 61 | constructor; auto. } 62 | { good_inversion DSST'. good_inversion DSST'0. auto. } 63 | { good_inversion WF. good_inversion DSST'. 64 | constructor; auto. econstructor; eauto. 65 | intros HIn. apply FV_LT_COUNTER in HIn. 66 | { omega. } 67 | { reflexivity. } } 68 | { good_inversion DSST'. auto. } 69 | { auto. } 70 | { good_inversion WF. good_inversion DSST'; auto. } 71 | { good_inversion DSST'. constructor; auto. 72 | eapply answer_correct; eauto. } 73 | { good_inversion WF. good_inversion DSST'. auto. } 74 | { good_inversion WF. good_inversion DSST'. 75 | { good_inversion DSST'0. 76 | constructor; auto. 77 | eapply answer_correct; eauto. } 78 | { good_inversion DSST'0. auto. } } 79 | Qed. 80 | 81 | Lemma search_correctness_generalized 82 | (st : state) 83 | (WF : well_formed_state st) 84 | (f : repr_fun) 85 | (t : trace) 86 | (HOP : op_sem st t) 87 | (HDA : {| t , f |}) : 88 | in_denotational_sem_state st f. 89 | Proof. 90 | revert HOP WF. revert st. 91 | red in HDA. destruct HDA as [s [n [HInStr DSS]]]. 92 | remember (Answer s n) as l. induction HInStr. 93 | { intros. inversion HOP; clear HOP; subst. 94 | constructor. eapply answer_correct; eauto. } 95 | { specialize (IHHInStr Heql). intros. 96 | inversion HOP; clear HOP; subst. 97 | inversion WF; clear WF; subst. 98 | specialize (well_formedness_preservation _ _ _ EV wfState). 99 | intro wf_st0. 100 | specialize (IHHInStr st0 OP wf_st0). 101 | constructor. eapply next_state_correct; eauto. } 102 | Qed. 103 | 104 | Lemma search_correctness 105 | (g : goal) 106 | (k : nat) 107 | (HC : closed_goal_in_context (first_nats k) g) 108 | (f : repr_fun) 109 | (t : trace) 110 | (HOP : op_sem (NTState (Leaf g empty_subst k)) t) 111 | (HDA : {| t , f |}) : 112 | [| g , f |]. 113 | Proof. 114 | remember (NTState (Leaf g empty_subst k)) as st. 115 | assert (in_denotational_sem_state st f). 116 | { eapply search_correctness_generalized; eauto. 117 | subst. constructor. apply well_formed_initial_state; auto. } 118 | subst. inversion H. inversion DSST'. auto. 119 | Qed. 120 | -------------------------------------------------------------------------------- /src/Preliminaries/Streams.v: -------------------------------------------------------------------------------- 1 | Section Stream. 2 | 3 | Context {A : Set}. 4 | 5 | CoInductive stream : Set := 6 | | Nil : stream 7 | | Cons : A -> stream -> stream. 8 | 9 | Definition helper (s : stream) : stream := 10 | match s with 11 | | Nil => Nil 12 | | Cons h t => Cons h t 13 | end. 14 | 15 | Lemma helper_eq 16 | (s : stream) : 17 | s = helper s. 18 | Proof. destruct s; reflexivity. Qed. 19 | 20 | CoInductive equal_streams : stream -> stream -> Prop := 21 | | eqsNil : equal_streams Nil Nil 22 | | eqsCons : forall h1 h2 t1 t2 (EQH : h1 = h2) 23 | (EQT : equal_streams t1 t2), 24 | equal_streams (Cons h1 t1) (Cons h2 t2). 25 | 26 | Lemma equal_streams_symmetry 27 | (s1 s2 : stream) 28 | (EQS : equal_streams s1 s2) : 29 | equal_streams s2 s1. 30 | Proof. 31 | revert EQS. revert s1 s2. 32 | cofix CIH. intros. inversion EQS; subst. 33 | { constructor. } 34 | { constructor. reflexivity. auto. } 35 | Qed. 36 | 37 | Inductive in_stream : A -> stream -> Prop := 38 | | inHead : forall x t, in_stream x (Cons x t) 39 | | inTail : forall x h t (IN : in_stream x t), 40 | in_stream x (Cons h t). 41 | 42 | Hint Constructors in_stream : core. 43 | 44 | Lemma in_equal_streams 45 | (s1 s2 : stream) 46 | (EQS : equal_streams s1 s2) 47 | (x : A) 48 | (X_IN : in_stream x s1) : 49 | in_stream x s2. 50 | Proof. 51 | revert EQS. revert s2. 52 | induction X_IN; intros; inversion_clear EQS; subst. 53 | { constructor. } 54 | { constructor. eapply IHX_IN. assumption. } 55 | Qed. 56 | 57 | Inductive finite : stream -> Prop := 58 | | fNil : finite Nil 59 | | fCons : forall h t (FIN : finite t), 60 | finite (Cons h t). 61 | 62 | Hint Constructors finite : core. 63 | 64 | CoInductive interleave : stream -> stream -> stream -> Prop := 65 | | interNil : forall s s' (EQS : equal_streams s s'), 66 | interleave Nil s s' 67 | | interCons : forall h t s rs (INTER : interleave s t rs), 68 | interleave (Cons h t) s (Cons h rs). 69 | 70 | Lemma interleave_in_1 71 | (s1 s2 s : stream) 72 | (INTER : interleave s1 s2 s) 73 | (x : A) 74 | (X_IN : in_stream x s) : 75 | in_stream x s1 \/ in_stream x s2. 76 | Proof. 77 | revert INTER. revert s1 s2. induction X_IN; intros. 78 | { inversion INTER. 79 | { right. inversion EQS. subst. constructor. } 80 | { left. constructor. } } 81 | { inversion INTER; subst. 82 | { right. inversion EQS; subst. constructor. 83 | apply equal_streams_symmetry in EQT. 84 | eapply in_equal_streams; eauto. } 85 | { specialize (IHX_IN _ _ INTER0). destruct IHX_IN. 86 | { auto. } 87 | { left. constructor. auto. } } } 88 | Qed. 89 | 90 | Lemma interleave_in_2 91 | (s1 s2 s : stream) 92 | (INTER : interleave s1 s2 s) 93 | (x : A) 94 | (X_IN_12 : in_stream x s1 \/ in_stream x s2) : 95 | in_stream x s. 96 | Proof. 97 | destruct X_IN_12. 98 | { revert INTER. revert s2 s. induction H. 99 | { intros. inversion_clear INTER; subst. constructor. } 100 | { intros. inversion_clear INTER; subst. constructor. 101 | inversion_clear INTER0; subst. 102 | { eapply in_equal_streams; eauto. } 103 | { constructor. eauto. } } } 104 | { revert INTER. revert s1 s. induction H. 105 | { intros. inversion INTER; subst. 106 | { eapply in_equal_streams; eauto. } 107 | { constructor. inversion INTER0; subst. auto. } } 108 | { intros. inversion INTER; subst. 109 | { eapply in_equal_streams; eauto. } 110 | { inversion INTER0; subst. constructor. constructor. eapply IHin_stream. eauto. } } } 111 | Qed. 112 | 113 | Lemma interleave_in 114 | (s1 s2 s : stream) 115 | (INTER : interleave s1 s2 s) 116 | (x : A) : 117 | in_stream x s <-> in_stream x s1 \/ in_stream x s2. 118 | Proof. 119 | intros. split. 120 | { apply interleave_in_1. auto. } 121 | { apply interleave_in_2. auto. } 122 | Qed. 123 | 124 | Lemma equal_streams_finite 125 | (s1 s2 : stream) 126 | (EQS : equal_streams s1 s2) 127 | (FIN_1 : finite s1) : 128 | finite s2. 129 | Proof. 130 | revert EQS. revert s2. 131 | induction FIN_1; intros; inversion EQS; subst; auto. 132 | Qed. 133 | 134 | Lemma interleave_finite_1 135 | (s s1 s2 : stream) 136 | (INTER : interleave s1 s2 s) 137 | (FIN : finite s) : 138 | finite s1 /\ finite s2. 139 | Proof. 140 | revert INTER. revert s1 s2. induction FIN. 141 | { intros. inversion INTER; subst. inversion EQS. auto. } 142 | { intros. inversion INTER; subst. 143 | { inversion EQS; subst. split; auto. constructor. 144 | apply equal_streams_symmetry in EQT. eapply equal_streams_finite; eauto. } 145 | { apply IHFIN in INTER0. destruct INTER0. auto. } } 146 | Qed. 147 | 148 | Lemma interleave_finite_2 149 | (s s1 s2 : stream) 150 | (INTER : interleave s1 s2 s) 151 | (FIN_1 : finite s1) 152 | (FIN_2 : finite s2) : 153 | finite s. 154 | Proof. 155 | revert INTER FIN_2. revert s s2. induction FIN_1. 156 | { intros. inversion INTER. eapply equal_streams_finite; eauto. } 157 | { intros. inversion INTER; subst. constructor. inversion INTER0; subst. 158 | { eapply equal_streams_finite; eauto. } 159 | { inversion FIN_2; subst. constructor. eapply IHFIN_1; eauto. } } 160 | Qed. 161 | 162 | Lemma interleave_finite 163 | (s1 s2 s : stream) 164 | (INTER : interleave s1 s2 s) : 165 | finite s <-> finite s1 /\ finite s2. 166 | Proof. 167 | intros. split. 168 | { intro. eapply interleave_finite_1; eauto. } 169 | { intro. destruct H. eapply interleave_finite_2; eauto. } 170 | Qed. 171 | 172 | End Stream. 173 | 174 | Section Test. 175 | 176 | CoFixpoint nats (n : nat) : stream := Cons n (nats (S n)). 177 | 178 | Definition true_false : stream := Cons true (Cons false Nil). 179 | 180 | Lemma true_false_fin : finite true_false. 181 | Proof. 182 | repeat constructor. 183 | Qed. 184 | 185 | Lemma nats_not_fin 186 | (n : nat) : 187 | ~ finite (nats n). 188 | Proof. 189 | intro C. remember (nats n). 190 | revert Heqs. revert n. 191 | induction C. 192 | { intros. rewrite helper_eq in Heqs. simpl in Heqs. inversion Heqs. } 193 | { intros. apply IHC with (S n). rewrite helper_eq in Heqs. simpl in Heqs. 194 | inversion Heqs. reflexivity. } 195 | Qed. 196 | 197 | Lemma nats_contain_all_nats 198 | (n : nat) : 199 | in_stream n (nats 0). 200 | Proof. 201 | induction n. 202 | { rewrite helper_eq. constructor. } 203 | { remember (nats 0). remember 0. clear Heqn0. 204 | revert Heqs. revert n0. induction IHn. 205 | { intros. rewrite helper_eq in Heqs. inversion Heqs. 206 | constructor. rewrite helper_eq. constructor. } 207 | { intros. constructor. rewrite helper_eq in Heqs. 208 | inversion Heqs; subst. eapply IHIHn. reflexivity. } } 209 | Qed. 210 | 211 | End Test. 212 | -------------------------------------------------------------------------------- /src/Preliminaries/Unification.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Arith. 4 | Require Import Omega. 5 | Require Import Coq.Lists.ListSet. 6 | Require Export Coq.Structures.OrderedTypeEx. 7 | 8 | Ltac good_inversion H := inversion H; clear H; subst. 9 | 10 | 11 | (************************* Terms **************************) 12 | Definition name := nat. 13 | 14 | Definition name_eq_dec : (forall x y : name, {x = y} + {x <> y}) := eq_nat_dec. 15 | 16 | Inductive term : Set := 17 | | Var : name -> term 18 | | Cst : name -> term 19 | | Con : name -> term -> term -> term. 20 | 21 | Lemma term_eq_dec : forall t1 t2 : term, {t1 = t2} + {t1 <> t2}. 22 | Proof. 23 | induction t1; destruct t2. 24 | 2, 3, 4, 6, 7, 8: right; intro H; inversion H. 25 | 1, 2: specialize (eq_nat_dec n n0); intro; destruct H; 26 | [ left; auto 27 | | right; intro H; inversion H; auto ]. 28 | specialize (eq_nat_dec n n0); intro; destruct H; 29 | specialize (IHt1_1 t2_1); destruct IHt1_1; 30 | specialize (IHt1_2 t2_2); destruct IHt1_2. 31 | 1: left; subst; reflexivity. 32 | all: right; intro H; inversion H; auto. 33 | Qed. 34 | 35 | Definition var_set := set name. 36 | 37 | Definition var_set_empty : var_set := empty_set name. 38 | Definition var_set_add : name -> var_set -> var_set := set_add name_eq_dec. 39 | Definition var_set_union : var_set -> var_set -> var_set := set_union name_eq_dec. 40 | Definition var_set_remove : name -> var_set -> var_set := set_remove name_eq_dec. 41 | Definition var_set_size : var_set -> nat := @length name. 42 | 43 | Fixpoint fv_term (t : term) : var_set := 44 | match t with 45 | | Var n => var_set_add n var_set_empty 46 | | Cst _ => var_set_empty 47 | | Con _ l r => var_set_union (fv_term l) (fv_term r) 48 | end. 49 | 50 | Definition ground_term : Set := {t : term | fv_term t = var_set_empty}. 51 | 52 | Lemma fv_term_nodup 53 | (t : term) : 54 | NoDup (fv_term t). 55 | Proof. 56 | induction t. 57 | { apply set_add_nodup. constructor. } 58 | { constructor. } 59 | { apply set_union_nodup; assumption. } 60 | Qed. 61 | 62 | Lemma free_var 63 | (t : term) : 64 | exists x, ~ In x (fv_term t). 65 | Proof. 66 | assert (A : forall t, exists n, forall x, In x (fv_term t) -> S x <= n). 67 | { clear. induction t. 68 | { exists (S n). intros. destruct H. 69 | { omega. } 70 | { contradiction. } } 71 | { exists 0. intros. contradiction. } 72 | { destruct IHt1 as [n1 IHt1]. destruct IHt2 as [n2 IHt2]. 73 | exists (max n1 n2). intros. apply (set_union_elim name_eq_dec) in H. 74 | destruct H. 75 | { eapply le_trans. 76 | { eapply IHt1. assumption. } 77 | { apply Nat.le_max_l. } } 78 | { eapply le_trans. 79 | { eapply IHt2. assumption. } 80 | { apply Nat.le_max_r. } } } } 81 | specialize (A t). destruct A. exists x. intro C. 82 | apply H in C. omega. 83 | Qed. 84 | 85 | Fixpoint height (t : term) : nat := 86 | match t with 87 | | Var _ => 1 88 | | Cst _ => 1 89 | | Con _ l r => S (max (height l) (height r)) 90 | end. 91 | 92 | Fixpoint occurs (n : name) (t : term) : bool := 93 | match t with 94 | | Var x => Nat.eqb n x 95 | | Cst _ => false 96 | | Con _ l r => orb (occurs n l) (occurs n r) 97 | end. 98 | 99 | Lemma occurs_In 100 | (t : term) 101 | (n : name) : 102 | occurs n t = true <-> In n (fv_term t). 103 | Proof. 104 | induction t. 105 | { split; intro. 106 | { left. symmetry. apply Nat.eqb_eq. assumption. } 107 | { destruct H. 108 | { apply Nat.eqb_eq. symmetry. assumption. } 109 | { contradiction. } } } 110 | { split; intro C; inversion C. } 111 | { split; intro. 112 | { apply (set_union_intro name_eq_dec). 113 | apply Bool.orb_true_elim in H. destruct H. 114 | { left. apply IHt1. assumption. } 115 | { right. apply IHt2. assumption. } } 116 | { apply Bool.orb_true_intro. 117 | apply (set_union_elim name_eq_dec) in H. destruct H. 118 | { left. apply IHt1. assumption. } 119 | { right. apply IHt2. assumption. } } } 120 | Qed. 121 | 122 | 123 | 124 | (********************* Substitutions **********************) 125 | Definition subst : Set := list (name * term). 126 | 127 | Definition empty_subst : subst := []. 128 | 129 | Definition singleton_subst (n : name) (t : term) := [(n, t)]. 130 | 131 | (* Substitution image *) 132 | Fixpoint image (s : subst) (n : name) : option term := 133 | match s with 134 | | [] => None 135 | | (m, t) :: tl => if eq_nat_dec m n then Some t else image tl n 136 | end. 137 | 138 | Lemma map_image 139 | (f : name -> term) 140 | (v : var_set) 141 | (x : name) 142 | (X_IN : In x v) : 143 | image (map (fun x0 : name => (x0, f x0)) v) x = Some (f x). 144 | Proof. 145 | induction v. 146 | { contradiction. } 147 | { simpl. destruct (Nat.eq_dec a x). 148 | { subst. auto. } 149 | { apply IHv. destruct X_IN; auto. contradiction. } } 150 | Qed. 151 | 152 | Definition in_subst_dom (s : subst) (x : name) : Prop := exists t, image s x = Some t. 153 | 154 | Definition in_subst_vran (s : subst) (y : name) : Prop := exists x t, image s x = Some t /\ In y (fv_term t). 155 | 156 | Fixpoint apply_subst (s : subst) (t : term) : term := 157 | match t with 158 | | Cst _ => t 159 | | Var n => match image s n with None => t | Some t' => t' end 160 | | Con n l r => Con n (apply_subst s l) (apply_subst s r) 161 | end. 162 | 163 | Lemma apply_empty 164 | (t : term) : 165 | apply_subst empty_subst t = t. 166 | Proof. 167 | induction t; try (simpl; congruence); auto. 168 | Qed. 169 | 170 | Lemma apply_subst_FV 171 | (x : name) 172 | (t : term) 173 | (s : subst) 174 | (X_FV : In x (fv_term (apply_subst s t))) : 175 | In x (fv_term t) \/ in_subst_vran s x. 176 | Proof. 177 | induction t. 178 | { simpl in X_FV. destruct (image s n) eqn:eq. 179 | { right. red. eauto. } 180 | { left. auto. } } 181 | { inversion X_FV. } 182 | { simpl in X_FV. apply (set_union_elim name_eq_dec) in X_FV. destruct X_FV. 183 | { apply IHt1 in H. destruct H. 184 | { left. apply (set_union_intro name_eq_dec). left. auto. } 185 | { right. auto. } } 186 | { apply IHt2 in H. destruct H. 187 | { left. apply (set_union_intro name_eq_dec). right. auto. } 188 | { right. auto. } } } 189 | Qed. 190 | 191 | Definition compose (s1 s2 : subst) : subst := 192 | List.map (fun p => (fst p, apply_subst s2 (snd p))) s1 ++ s2. 193 | 194 | Lemma compose_correctness 195 | (s1 s2 : subst) 196 | (t : term) : 197 | apply_subst (compose s1 s2) t = apply_subst s2 (apply_subst s1 t). 198 | Proof. 199 | induction t. 200 | { simpl. destruct (image s1 n) eqn:eq. 201 | { induction s1. 202 | { inversion eq. } 203 | { destruct a. simpl in eq. simpl. destruct (Nat.eq_dec n0 n). 204 | { congruence. } 205 | { auto. } } } 206 | { induction s1. 207 | { reflexivity. } 208 | { destruct a. simpl in eq. simpl. destruct (Nat.eq_dec n0 n). 209 | { inversion eq. } 210 | { auto. } } } } 211 | { reflexivity. } 212 | { simpl. congruence. } 213 | Qed. 214 | 215 | Lemma compose_dom 216 | (x : name) 217 | (s s' : subst) 218 | (IN_DOM : in_subst_dom (compose s s') x) : 219 | in_subst_dom s x \/ in_subst_dom s' x. 220 | Proof. 221 | induction s. 222 | { right. auto. } 223 | { red in IN_DOM. destruct IN_DOM. unfold in_subst_dom. 224 | simpl. destruct a. simpl in H. 225 | destruct (Nat.eq_dec n x). 226 | { left. eauto. } 227 | { apply IHs. red. eauto. } } 228 | Qed. 229 | 230 | Lemma compose_vran 231 | (y : name) 232 | (s s' : subst) 233 | (IN_VRAN : in_subst_vran (compose s s') y) : 234 | in_subst_vran s y \/ in_subst_vran s' y. 235 | Proof. 236 | destruct IN_VRAN as [x [t [IN_IMAGE IN_FV]]]. 237 | assert (GEN : (exists t0, image s x = Some t0 /\ In y (fv_term t0)) \/ in_subst_vran s' y). 238 | { induction s. 239 | { right. red. eauto. } 240 | { destruct a. simpl in IN_IMAGE. simpl. destruct (Nat.eq_dec n x). 241 | { inversion IN_IMAGE. subst. apply apply_subst_FV in IN_FV. 242 | destruct IN_FV; auto. left. exists t0. split; auto. } 243 | { apply IHs in IN_IMAGE. destruct IN_IMAGE; auto. } } } 244 | destruct GEN. 245 | { left. red. eauto. } 246 | { right. auto. } 247 | Qed. 248 | 249 | 250 | 251 | (************************** MGU ***************************) 252 | Definition more_general (m s : subst) : Prop := 253 | exists (s' : subst), forall (t : term), apply_subst s t = apply_subst s' (apply_subst m t). 254 | 255 | Definition unifier (s : subst) (t1 t2 : term) : Prop := apply_subst s t1 = apply_subst s t2. 256 | 257 | Inductive unification_step_outcome : Set := 258 | | NonUnifiable : unification_step_outcome 259 | | Same : unification_step_outcome 260 | | VarSubst : forall (n: name) (t: term), unification_step_outcome. 261 | 262 | Definition create (n: name) (t: term) : unification_step_outcome := 263 | if occurs n t then NonUnifiable else VarSubst n t. 264 | 265 | Lemma inv_create 266 | (n0 n1 : name) 267 | (t0 t1 : term) 268 | (CR : create n0 t0 = VarSubst n1 t1) : 269 | t0 = t1. 270 | Proof. 271 | { intros. unfold create in CR. destruct (occurs n0 t0). 272 | { inversion CR. } 273 | { inversion CR. reflexivity. } } 274 | Qed. 275 | 276 | Fixpoint unification_step (t1 t2 : term) : unification_step_outcome := 277 | match (t1, t2) with 278 | | (Cst n1 , Cst n2 ) => if eq_nat_dec n1 n2 then Same else NonUnifiable 279 | | (Con n1 l1 r1, Con n2 l2 r2) => if eq_nat_dec n1 n2 280 | then 281 | match unification_step l1 l2 with 282 | | NonUnifiable => NonUnifiable 283 | | Same => unification_step r1 r2 284 | | res => res 285 | end 286 | else NonUnifiable 287 | | (Var n1 , Var n2 ) => if eq_nat_dec n1 n2 then Same else create n1 t2 288 | | (Var n1 , _ ) => create n1 t2 289 | | (_ , Var n2 ) => create n2 t1 290 | | (_ , _ ) => NonUnifiable 291 | end. 292 | 293 | Definition unification_step_ok t1 t2 n s := unification_step t1 t2 = VarSubst n s. 294 | 295 | Lemma unification_step_fv 296 | (t1 t2 s : term) 297 | (n m : name) 298 | (STEP_OK : unification_step_ok t1 t2 n s) 299 | (M_FV : In m (fv_term s)) : 300 | In m (fv_term t1) \/ In m (fv_term t2). 301 | Proof. 302 | revert M_FV STEP_OK. revert t2 m n. induction t1. 303 | { intros. unfold unification_step_ok in STEP_OK. 304 | destruct t2; unfold unification_step in STEP_OK. 305 | { destruct (Nat.eq_dec n n1). 306 | { inversion STEP_OK. } 307 | { apply inv_create in STEP_OK; subst. right. assumption. } } 308 | { apply inv_create in STEP_OK; subst. right. assumption. } 309 | { apply inv_create in STEP_OK; subst. right. assumption. } } 310 | { intros. unfold unification_step_ok in STEP_OK. 311 | destruct t2; unfold unification_step in STEP_OK. 312 | { apply inv_create in STEP_OK; subst. left. assumption. } 313 | { destruct (Nat.eq_dec n n1); inversion STEP_OK. } 314 | { inversion STEP_OK. } } 315 | { intros. unfold unification_step_ok in STEP_OK. 316 | destruct t2; unfold unification_step in STEP_OK. 317 | { apply inv_create in STEP_OK; subst. left. assumption. } 318 | { inversion STEP_OK. } 319 | { fold unification_step in STEP_OK. destruct (Nat.eq_dec n n1). 320 | { destruct (unification_step t1_1 t2_1) eqn:eq. 321 | { inversion STEP_OK. } 322 | { unfold unification_step_ok in IHt1_2. apply IHt1_2 with (m := m) in STEP_OK. 323 | { destruct STEP_OK. 324 | { left. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). right. assumption. } 325 | { right. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). right. assumption. } } 326 | { assumption. } } 327 | { inversion STEP_OK; subst. unfold unification_step_ok in IHt1_1. 328 | apply IHt1_1 with (m := m) in eq. 329 | { destruct eq. 330 | { left. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). left. assumption. } 331 | { right. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). left. assumption. } } 332 | { assumption. } } } 333 | { inversion STEP_OK. } } } 334 | Qed. 335 | 336 | Lemma unification_step_subst_wf 337 | (t1 t2 s : term) 338 | (n : name) 339 | (STEP_OK : unification_step_ok t1 t2 n s) : 340 | ~ In n (fv_term s). 341 | Proof. 342 | intros. assert (CR : exists m t, create m t = VarSubst n s). 343 | { revert STEP_OK. revert t2. induction t1; intros. 344 | { destruct t2; unfold unification_step_ok in STEP_OK; unfold unification_step in STEP_OK. 345 | { destruct (Nat.eq_dec n0 n1). 346 | { inversion STEP_OK. } 347 | { eexists. eexists. eapply STEP_OK. } } 348 | { eexists. eexists. eapply STEP_OK. } 349 | { eexists. eexists. eapply STEP_OK. } } 350 | { destruct t2; unfold unification_step_ok in STEP_OK; unfold unification_step in STEP_OK. 351 | { eexists. eexists. eapply STEP_OK. } 352 | { destruct (Nat.eq_dec n0 n1); inversion STEP_OK. } 353 | { inversion STEP_OK. } } 354 | { destruct t2; unfold unification_step_ok in STEP_OK; unfold unification_step in STEP_OK. 355 | { eexists. eexists. eapply STEP_OK. } 356 | { inversion STEP_OK. } 357 | { destruct (Nat.eq_dec n0 n1). 358 | { fold unification_step in STEP_OK. destruct (unification_step t1_1 t2_1) eqn:eq. 359 | { inversion STEP_OK. } 360 | { eapply IHt1_2. unfold unification_step_ok. eapply STEP_OK. } 361 | { inversion STEP_OK; subst. eapply IHt1_1. unfold unification_step_ok. 362 | eapply eq. } } 363 | { inversion STEP_OK. } } } } 364 | destruct CR as [m [t CR]]. unfold create in CR. destruct (occurs m t) eqn:eq. 365 | { inversion CR. } 366 | { good_inversion CR. intros CH. apply occurs_In in CH. rewrite eq in CH. 367 | inversion CH. } 368 | Qed. 369 | 370 | Lemma unification_step_subst_occurs 371 | (t1 t2 s : term) 372 | (n : name) 373 | (STEP_OK : unification_step_ok t1 t2 n s) : 374 | In n (fv_term t1) \/ In n (fv_term t2). 375 | Proof. 376 | assert (INV_CR: forall n0 n1 t0 t1, create n0 t0 = VarSubst n1 t1 -> n0 = n1). 377 | { intros. unfold create in H. destruct (occurs n0 t0). 378 | { inversion H. } 379 | { inversion H. reflexivity. } } 380 | assert (VAR_IN_FV: forall n, In n (fv_term (Var n))). 381 | { unfold fv_term. unfold In. left. reflexivity. } 382 | revert STEP_OK. revert n t2. induction t1. 383 | { intros. unfold unification_step_ok in STEP_OK. 384 | destruct t2; unfold unification_step in STEP_OK. 385 | { destruct (Nat.eq_dec n n1). 386 | { inversion STEP_OK. } 387 | { apply INV_CR in STEP_OK; subst. left. apply VAR_IN_FV. } } 388 | { apply INV_CR in STEP_OK; subst. left. apply VAR_IN_FV. } 389 | { apply INV_CR in STEP_OK; subst. left. apply VAR_IN_FV. } } 390 | { intros. unfold unification_step_ok in STEP_OK. destruct t2; unfold unification_step in STEP_OK. 391 | { apply INV_CR in STEP_OK; subst. right. apply VAR_IN_FV. } 392 | { destruct (Nat.eq_dec n n1); inversion STEP_OK. } 393 | { inversion STEP_OK. } } 394 | { intros. unfold unification_step_ok in STEP_OK. destruct t2; unfold unification_step in STEP_OK. 395 | { apply INV_CR in STEP_OK; subst. right. apply VAR_IN_FV. } 396 | { inversion STEP_OK. } 397 | { fold unification_step in STEP_OK. destruct (unification_step t1_1 t2_1) eqn:eq. 398 | { destruct (Nat.eq_dec n n1); inversion STEP_OK. } 399 | { destruct (Nat.eq_dec n n1). 400 | { unfold unification_step_ok in IHt1_2. apply IHt1_2 in STEP_OK. destruct STEP_OK. 401 | { left. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). right. assumption. } 402 | { right. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). right. assumption. } } 403 | { inversion STEP_OK. } } 404 | { destruct (Nat.eq_dec n n1); inversion STEP_OK; subst. 405 | unfold unification_step_ok in IHt1_1. apply IHt1_1 in eq. destruct eq. 406 | { left. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). left. assumption. } 407 | { right. unfold fv_term. fold fv_term. apply (set_union_intro name_eq_dec). left. assumption. } } } } 408 | Qed. 409 | 410 | Lemma unification_step_subst_elims 411 | (s t : term) 412 | (n : name) 413 | (N_FV : In n (fv_term (apply_subst (singleton_subst n s) t))) : 414 | In n (fv_term s). 415 | Proof. 416 | revert N_FV. unfold singleton_subst. induction t. 417 | { unfold apply_subst. unfold image. destruct (Nat.eq_dec n n0). 418 | { auto. } 419 | { unfold fv_term. intros. exfalso. inversion N_FV. 420 | { apply n1. symmetry. assumption. } 421 | { inversion H. } } } 422 | { intros. inversion N_FV. } 423 | { intros. unfold apply_subst in N_FV. fold apply_subst in N_FV. 424 | unfold fv_term in N_FV. fold fv_term in N_FV. 425 | apply (set_union_elim name_eq_dec) in N_FV. destruct N_FV; auto. } 426 | Qed. 427 | 428 | Lemma lt_size 429 | (vs1 vs2 : var_set) 430 | (NO_DUP_1 : NoDup vs1) 431 | (NO_DUP_2 : NoDup vs2) 432 | (INCL : incl vs1 vs2) 433 | (UNIQ_VAR : exists n, In n vs2 /\ ~ (In n vs1)) : 434 | var_set_size vs1 < var_set_size vs2. 435 | Proof. 436 | intros. destruct UNIQ_VAR as [n [IN NOT_IN]]. 437 | apply in_split in IN. 438 | destruct IN as [l1 [l2 EQ]]. subst. 439 | unfold var_set_size. rewrite app_length. simpl. 440 | assert (LE_LEN : length vs1 <= length (l1 ++ l2)). 441 | { apply NoDup_incl_length. 442 | { assumption. } 443 | { unfold incl. intros. assert (H_COPY := H). 444 | apply INCL in H. apply in_app_or in H. destruct H. 445 | { apply in_or_app. left. auto. } 446 | { inversion H. 447 | { exfalso. subst. auto. } 448 | { apply in_or_app. right. auto. } } } } 449 | rewrite app_length in LE_LEN. omega. 450 | Qed. 451 | 452 | Lemma unification_step_decreases_fv 453 | (t1 t2 s : term) 454 | (n : name) 455 | (STEP_OK : unification_step_ok t1 t2 n s) : 456 | var_set_size (var_set_union (fv_term (apply_subst (singleton_subst n s) t1)) (fv_term (apply_subst (singleton_subst n s) t2))) < 457 | var_set_size (var_set_union (fv_term t1) (fv_term t2)). 458 | Proof. 459 | apply lt_size; try apply union_NoDup. 460 | { apply set_union_nodup; apply fv_term_nodup. } 461 | { apply set_union_nodup; apply fv_term_nodup. } 462 | { intros n0 InH. apply (set_union_elim name_eq_dec) in InH. inversion_clear InH. 463 | { apply apply_subst_FV in H. inversion_clear H. 464 | { apply (set_union_intro name_eq_dec). left. assumption. } 465 | { apply unification_step_fv with (m:=n0) in STEP_OK. 466 | { apply (set_union_intro name_eq_dec). assumption. } 467 | red in H0. destruct H0 as [x [t [xImage inFV]]]. simpl in xImage. 468 | destruct (Nat.eq_dec n x); good_inversion xImage. auto. } } 469 | { apply apply_subst_FV in H. inversion_clear H. 470 | { apply (set_union_intro name_eq_dec). right. assumption. } 471 | { apply unification_step_fv with (m:=n0) in STEP_OK. 472 | { apply (set_union_intro name_eq_dec). assumption. } 473 | red in H0. destruct H0 as [x [t [xImage inFV]]]. simpl in xImage. 474 | destruct (Nat.eq_dec n x); good_inversion xImage. auto. } } } 475 | { exists n. split. 476 | { apply unification_step_subst_occurs in STEP_OK. apply (set_union_intro name_eq_dec). assumption. } 477 | { unfold not. intro H. apply (set_union_elim name_eq_dec) in H. inversion_clear H as [H0 | H0]; 478 | apply unification_step_subst_elims in H0; 479 | apply unification_step_subst_wf in STEP_OK; auto. } } 480 | Qed. 481 | 482 | 483 | 484 | Definition terms := (term * term)%type. 485 | 486 | Definition fvOrder (t : terms) := length (var_set_union (fv_term (fst t)) (fv_term (snd t))). 487 | 488 | Definition fvOrderRel (t p : terms) := fvOrder t < fvOrder p. 489 | 490 | Theorem fvOrder_wf : well_founded fvOrderRel. 491 | Proof. 492 | assert (fvOrder_wf': forall (size: nat) (t: terms), fvOrder t < size -> Acc fvOrderRel t). 493 | { unfold fvOrderRel. induction size. 494 | { intros. inversion H. } 495 | { intros. constructor. intros. apply IHsize. omega. } } 496 | red; intro; eapply fvOrder_wf'; eauto. 497 | Defined. 498 | 499 | Inductive mgu : term -> term -> option subst -> Prop := 500 | | mguNonUnifiable : forall t1 t2 (STEP_NU : unification_step t1 t2 = NonUnifiable), 501 | mgu t1 t2 None 502 | | mguSame : forall t1 t2 (STEP_SAME : unification_step t1 t2 = Same), 503 | mgu t1 t2 (Some empty_subst) 504 | | mguVarSubstNone : forall t1 t2 n s 505 | (STEP_SUBST : unification_step t1 t2 = VarSubst n s) 506 | (THEN_FAIL : mgu (apply_subst (singleton_subst n s) t1) (apply_subst (singleton_subst n s) t2) None), 507 | mgu t1 t2 None 508 | | mguVarSubstSome : forall t1 t2 n s r sr 509 | (STEP_SUBST : unification_step t1 t2 = VarSubst n s) 510 | (THEN_SUCC : mgu (apply_subst (singleton_subst n s) t1) (apply_subst (singleton_subst n s) t2) (Some r)) 511 | (SR_EQ : sr = compose (singleton_subst n s) r), 512 | mgu t1 t2 (Some sr). 513 | 514 | Example test1: mgu (Cst 1) (Cst 2) None. 515 | Proof. repeat econstructor. Qed. 516 | 517 | Example test2: mgu (Cst 1) (Cst 1) (Some []). 518 | Proof. repeat econstructor. Qed. 519 | 520 | Example test3: mgu (Var 1) (Var 2) (Some [(1, Var 2)]). 521 | Proof. repeat econstructor. Qed. 522 | 523 | Example test4: mgu (Var 1) (Var 1) (Some []). 524 | Proof. repeat econstructor. Qed. 525 | 526 | Example test5: mgu (Con 1 (Var 1) (Var 2)) (Con 2 (Var 1) (Var 2)) None. 527 | Proof. repeat econstructor. Qed. 528 | 529 | Example test6: mgu (Con 1 (Var 1) (Var 2)) (Con 1 (Var 1) (Var 2)) (Some []). 530 | Proof. repeat econstructor. Qed. 531 | 532 | Example test7: mgu (Con 1 (Var 1) (Var 1)) (Con 1 (Var 1) (Var 2)) (Some [(1, Var 2)]). 533 | Proof. repeat econstructor. Qed. 534 | 535 | Example test8: mgu (Con 1 (Cst 1) (Var 2)) (Con 1 (Var 1) (Cst 2)) (Some [(1, Cst 1); (2, Cst 2)]). 536 | Proof. 537 | econstructor. 538 | 1, 3: econstructor. 539 | repeat econstructor. 540 | Qed. 541 | 542 | 543 | 544 | Lemma mgu_result_exists 545 | (t1 t2 : term) : 546 | {r & mgu t1 t2 r}. 547 | Proof. 548 | remember (fun p => {r : option subst & mgu (fst p) (snd p) r}) as P. 549 | assert (P (t1, t2)). 550 | { apply well_founded_induction with (R := fvOrderRel). 551 | { apply fvOrder_wf. } 552 | { intros. subst. clear t1 t2. destruct x as [t1 t2]. simpl. 553 | destruct (unification_step t1 t2) eqn:eq. 554 | { exists None. constructor. assumption. } 555 | { exists (Some empty_subst). constructor. assumption. } 556 | { specialize (H (apply_subst (singleton_subst n t) t1, apply_subst (singleton_subst n t) t2)). 557 | assert (fvOr : fvOrderRel (apply_subst (singleton_subst n t) t1, apply_subst (singleton_subst n t) t2) (t1, t2)). 558 | { apply unification_step_decreases_fv. assumption. } 559 | specialize (H fvOr). destruct H. destruct x. 560 | { eexists. eapply mguVarSubstSome. 561 | { eassumption. } 562 | { eassumption. } 563 | { reflexivity. } } 564 | { exists None. eapply mguVarSubstNone. 565 | { eassumption. } 566 | { eassumption. } } } } } 567 | subst. assumption. 568 | Defined. 569 | 570 | Lemma mgu_result_unique 571 | (t1 t2 : term) 572 | (r r' : option subst) 573 | (UNI_1 : mgu t1 t2 r) 574 | (UNI_2 : mgu t1 t2 r') : 575 | r = r'. 576 | Proof. 577 | revert UNI_2. revert r'. induction UNI_1. 578 | { intros. good_inversion UNI_2; try reflexivity; congruence. } 579 | { intros. good_inversion UNI_2; try reflexivity; congruence. } 580 | { intros. good_inversion UNI_2; try reflexivity; try congruence. 581 | rewrite STEP_SUBST0 in STEP_SUBST. good_inversion STEP_SUBST. 582 | apply IHUNI_1 in THEN_SUCC. inversion THEN_SUCC. } 583 | { intros. good_inversion UNI_2; try congruence; 584 | rewrite STEP_SUBST0 in STEP_SUBST; good_inversion STEP_SUBST. 585 | { apply IHUNI_1 in THEN_FAIL; inversion THEN_FAIL. } 586 | { apply IHUNI_1 in THEN_SUCC; inversion THEN_SUCC; auto. } } 587 | Qed. 588 | 589 | Lemma same_step_equal_terms 590 | (t1 t2 : term) 591 | (STEP_SAME : unification_step t1 t2 = Same) : 592 | t1 = t2. 593 | Proof. 594 | assert (CREATE_NOT_SAME : forall n t, create n t <> Same). 595 | { unfold create. intros n t C. destruct (occurs n t); inversion C. } 596 | revert STEP_SAME. revert t2. induction t1; induction t2; intros; good_inversion STEP_SAME. 597 | { destruct (Nat.eq_dec n n0). 598 | { congruence. } 599 | { apply CREATE_NOT_SAME in H0. contradiction. } } 600 | { apply CREATE_NOT_SAME in H0. contradiction. } 601 | { destruct (Nat.eq_dec n n0). 602 | { congruence. } 603 | { inversion H0. } } 604 | { apply CREATE_NOT_SAME in H0. contradiction. } 605 | { destruct (Nat.eq_dec n n0). 606 | { subst. destruct (unification_step t1_1 t2_1) eqn:eq; inversion H0. 607 | apply IHt1_1 in eq. apply IHt1_2 in H0. congruence. } 608 | { inversion H0. } } 609 | Qed. 610 | 611 | Lemma mgu_unifies 612 | (t1 t2 : term) 613 | (s : subst) 614 | (UNI : mgu t1 t2 (Some s)) : 615 | unifier s t1 t2. 616 | Proof. 617 | revert UNI. revert s. 618 | remember (fun p => forall s : subst, 619 | mgu (fst p) (snd p) (Some s) -> unifier s (fst p) (snd p)). 620 | assert (P (t1, t2)). 621 | { apply well_founded_induction with (R := fvOrderRel). 622 | { apply fvOrder_wf. } 623 | { intros. subst. clear t1 t2. destruct x as [t1 t2]. simpl. 624 | intros. inversion H0; subst; clear H0. 625 | { unfold unifier. rewrite apply_empty. rewrite apply_empty. 626 | apply same_step_equal_terms. assumption. } 627 | { assert (fvOr : fvOrderRel (apply_subst (singleton_subst n s0) t1, apply_subst (singleton_subst n s0) t2) (t1, t2)). 628 | { apply unification_step_decreases_fv. assumption. } 629 | eapply H in fvOr. 630 | 2: { eassumption. } 631 | { unfold unifier. rewrite compose_correctness. rewrite compose_correctness. 632 | assumption. } } } } 633 | subst. assumption. 634 | Qed. 635 | 636 | Lemma unification_step_binds 637 | (t1 t2 t : term) 638 | (x : name) 639 | (s : subst) 640 | (STEP : unification_step t1 t2 = VarSubst x t) 641 | (S_UNIFIER : unifier s t1 t2) : 642 | apply_subst s (Var x) = apply_subst s t. 643 | Proof. 644 | revert S_UNIFIER STEP. revert s x t t2. 645 | induction t1; induction t2; intros; simpl in STEP. 646 | { destruct (Nat.eq_dec n n0). 647 | { inversion STEP. } 648 | { unfold create in STEP. destruct (occurs n (Var n0)); inversion STEP. 649 | subst. assumption. } } 650 | { unfold create in STEP. destruct (occurs n (Cst n0)); inversion STEP. subst. assumption. } 651 | { unfold create in STEP. destruct (occurs n (Con n0 t2_1 t2_2)); inversion STEP. subst. assumption. } 652 | { unfold create in STEP. destruct (occurs n0 (Cst n)); inversion STEP. subst. symmetry. assumption. } 653 | { destruct (Nat.eq_dec n n0); inversion STEP. } 654 | { inversion STEP. } 655 | { unfold create in STEP. destruct (occurs n0 (Con n t1_1 t1_2)); inversion STEP. subst. symmetry. assumption. } 656 | { inversion STEP. } 657 | { clear IHt2_1. clear IHt2_2. 658 | destruct (Nat.eq_dec n n0). 659 | { subst. destruct (unification_step t1_1 t2_1) eqn:eq. 660 | { inversion STEP. } 661 | { inversion S_UNIFIER. apply IHt1_2 with t2_2; assumption. } 662 | { inversion STEP. subst. inversion S_UNIFIER. apply IHt1_1 with t2_1; assumption. } } 663 | { inversion STEP. } } 664 | Qed. 665 | 666 | Lemma unification_step_binds_2 667 | (t1 t2 t : term) 668 | (x : name) 669 | (s : subst) 670 | (STEP : unification_step t1 t2 = VarSubst x t) 671 | (S_UNIFIER : unifier s t1 t2) 672 | (t' : term) : 673 | apply_subst s t' = apply_subst s (apply_subst (singleton_subst x t) t'). 674 | Proof. 675 | specialize (unification_step_binds _ _ _ _ _ STEP S_UNIFIER). intro APP_EQ. 676 | induction t'. 677 | { simpl. destruct (Nat.eq_dec x n). 678 | { subst. rewrite <- APP_EQ. reflexivity. } 679 | { reflexivity. } } 680 | { reflexivity. } 681 | { simpl. rewrite IHt'1. rewrite IHt'2. reflexivity. } 682 | Qed. 683 | 684 | Lemma mgu_most_general 685 | (t1 t2 : term) 686 | (m s : subst) 687 | (UNI : mgu t1 t2 (Some m)) 688 | (S_UNIFIER : unifier s t1 t2) : 689 | more_general m s. 690 | Proof. 691 | revert S_UNIFIER. revert s. 692 | remember (Some m) as r eqn:eq. 693 | revert eq. revert m. 694 | induction UNI; intros m eq; good_inversion eq. 695 | { intros. unfold more_general. exists s. intros. 696 | rewrite apply_empty. reflexivity. } 697 | { subst. specialize (IHUNI r eq_refl). 698 | rename s into st. intros. 699 | specialize (unification_step_binds_2 _ _ _ _ _ STEP_SUBST S_UNIFIER). intro APP_EQ. 700 | assert (MG : more_general r s). 701 | { apply IHUNI. unfold unifier. congruence. } 702 | unfold more_general in MG. destruct MG as [d MG]. unfold more_general. 703 | exists d. intro. rewrite compose_correctness. congruence. } 704 | Qed. 705 | 706 | Lemma occurs_subst_height 707 | (s : subst) 708 | (n : name) 709 | (t : term) 710 | (OCC : occurs n t = true) : 711 | height (apply_subst s (Var n)) <= height (apply_subst s t). 712 | Proof. 713 | induction t. 714 | { simpl in OCC. apply Nat.eqb_eq in OCC. subst. reflexivity. } 715 | { inversion OCC. } 716 | { simpl in OCC. apply Bool.orb_true_elim in OCC. destruct OCC. 717 | { apply IHt1 in e. simpl. apply le_S. eapply le_trans. 718 | eassumption. apply Nat.le_max_l. } 719 | { apply IHt2 in e. simpl. apply le_S. eapply le_trans. 720 | eassumption. apply Nat.le_max_r. } } 721 | Qed. 722 | 723 | Lemma occurs_check_ground 724 | (s : subst) 725 | (x : name) 726 | (t : term) 727 | (OCC : occurs x t = true) 728 | (APP_EQ : apply_subst s (Var x) = apply_subst s t) : 729 | Var x = t. 730 | Proof. 731 | destruct t. 732 | { simpl in OCC. apply beq_nat_true_iff in OCC. congruence. } 733 | { inversion OCC. } 734 | { exfalso. simpl in OCC. apply Bool.orb_true_elim in OCC. destruct OCC. 735 | { apply occurs_subst_height with (s := s) in e. rewrite APP_EQ in e. 736 | simpl in e. apply le_lt_n_Sm in e. apply lt_S_n in e. 737 | apply lt_irrefl with (height (apply_subst s t1)). 738 | eapply le_lt_trans. 739 | 2: { eapply e. } 740 | apply Nat.le_max_l. } 741 | { apply occurs_subst_height with (s := s) in e. rewrite APP_EQ in e. 742 | simpl in e. apply le_lt_n_Sm in e. apply lt_S_n in e. 743 | apply lt_irrefl with (height (apply_subst s t2)). 744 | eapply le_lt_trans. 745 | 2: { eapply e. } 746 | apply Nat.le_max_r. } } 747 | Qed. 748 | 749 | Lemma mgu_non_unifiable 750 | (t1 t2 : term) 751 | (UNI : mgu t1 t2 None) 752 | (s : subst) : 753 | ~ (unifier s t1 t2). 754 | Proof. 755 | revert s. remember None as r eqn:eq. 756 | induction UNI; good_inversion eq. 757 | { revert STEP_NU. revert t2. 758 | induction t1; induction t2; intros H s; inversion H. 759 | { destruct (Nat.eq_dec n n0). 760 | { inversion H1. } 761 | { unfold create in H1. destruct (occurs n (Var n0)) eqn:eq; inversion H1. 762 | intro C. specialize (occurs_check_ground _ _ _ eq C). intro. 763 | inversion H0. contradiction. } } 764 | { unfold create in H1. destruct (occurs n (Con n0 t2_1 t2_2)) eqn:eq; inversion H1. 765 | intro C. specialize (occurs_check_ground _ _ _ eq C). intro. 766 | inversion H0. } 767 | { destruct (Nat.eq_dec n n0). 768 | { inversion H1. } 769 | { intro C. inversion C. contradiction. } } 770 | { intro C. inversion C. } 771 | { unfold create in H1. destruct (occurs n0 (Con n t1_1 t1_2)) eqn:eq; inversion H1. 772 | intro C. red in C. symmetry in C. 773 | specialize (occurs_check_ground _ _ _ eq C). 774 | intro. inversion H0. } 775 | { intro C. inversion C. } 776 | { clear IHt2_1 IHt2_2. intro C. inversion C. destruct (Nat.eq_dec n n0). 777 | { subst. destruct (unification_step t1_1 t2_1) eqn:eq. 778 | { eapply IHt1_1; eassumption. } 779 | { eapply IHt1_2; eassumption. } 780 | { inversion H1. } } 781 | { contradiction. } } } 782 | { rename s into st. intros s C. 783 | specialize (IHUNI eq_refl s). 784 | specialize (unification_step_binds_2 _ _ _ _ _ STEP_SUBST C). intros eq. 785 | apply IHUNI. red. rewrite <- eq. rewrite <- eq. assumption. } 786 | Qed. 787 | 788 | Lemma mgu_dom 789 | (t1 t2 : term) 790 | (s : subst) 791 | (MGU : mgu t1 t2 (Some s)) 792 | (x : name) 793 | (inDom : in_subst_dom s x) : 794 | In x (fv_term t1) \/ In x (fv_term t2). 795 | Proof. 796 | remember (Some s) as r eqn:eq. revert eq inDom. revert s. 797 | induction MGU; intros; good_inversion eq. 798 | { destruct inDom. inversion H. } 799 | { apply compose_dom in inDom. destruct inDom. 800 | { red in H. destruct H. simpl in H. 801 | destruct (Nat.eq_dec n x); good_inversion H. 802 | eapply unification_step_subst_occurs; eauto. } 803 | { specialize (IHMGU _ eq_refl H). destruct IHMGU. 804 | { apply apply_subst_FV in H0. destruct H0. 805 | { left. auto. } 806 | { red in H0. destruct H0 as [x0 [t [x0Image inFV]]]. simpl in x0Image. 807 | destruct (Nat.eq_dec n x0); good_inversion x0Image. 808 | eapply unification_step_fv; eauto. } } 809 | { apply apply_subst_FV in H0. destruct H0. 810 | { right. auto. } 811 | { red in H0. destruct H0 as [x0 [t [x0Image inFV]]]. simpl in x0Image. 812 | destruct (Nat.eq_dec n x0); good_inversion x0Image. 813 | eapply unification_step_fv; eauto. } } } } 814 | Qed. 815 | 816 | Lemma mgu_vran 817 | (t1 t2 : term) 818 | (s : subst) 819 | (MGU : mgu t1 t2 (Some s)) 820 | (x : name) 821 | (inVRan : in_subst_vran s x) : 822 | In x (fv_term t1) \/ In x (fv_term t2). 823 | Proof. 824 | remember (Some s) as r eqn:eq. revert eq inVRan. revert s. 825 | induction MGU; intros; good_inversion eq. 826 | { destruct inVRan. destruct H as [t [x0Image inFV]]. inversion x0Image. } 827 | { apply compose_vran in inVRan. destruct inVRan. 828 | { red in H. destruct H as [x0 [t [x0Image inFV]]]. simpl in x0Image. 829 | destruct (Nat.eq_dec n x0); good_inversion x0Image. 830 | eapply unification_step_fv; eauto. } 831 | { specialize (IHMGU _ eq_refl H). destruct IHMGU. 832 | { apply apply_subst_FV in H0. destruct H0. 833 | { left. auto. } 834 | { red in H0. destruct H0 as [x0 [t [x0Image inFV]]]. simpl in x0Image. 835 | destruct (Nat.eq_dec n x0); good_inversion x0Image. 836 | eapply unification_step_fv; eauto. } } 837 | { apply apply_subst_FV in H0. destruct H0. 838 | { right. auto. } 839 | { red in H0. destruct H0 as [x0 [t [x0Image inFV]]]. simpl in x0Image. 840 | destruct (Nat.eq_dec n x0); good_inversion x0Image. 841 | eapply unification_step_fv; eauto. } } } } 842 | Qed. 843 | -------------------------------------------------------------------------------- /src/SLDSearch/DenotationalSemSLD.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Coq.Lists.ListSet. 3 | Import ListNotations. 4 | Require Import Omega. 5 | 6 | Require Import Unification. 7 | Require Import LanguageSLD. 8 | 9 | Lemma set_empty_union 10 | (s1 s2 : var_set) 11 | (EQ : var_set_union s1 s2 = var_set_empty) : 12 | s1 = var_set_empty /\ s2 = var_set_empty. 13 | Proof. 14 | split. 15 | { destruct s1; auto. 16 | assert (In n var_set_empty). 17 | { rewrite <- EQ. apply set_union_intro. left. constructor. auto. } 18 | inversion H. } 19 | { destruct s2; auto. 20 | assert (In n var_set_empty). 21 | { rewrite <- EQ. apply set_union_intro. right. constructor. auto. } 22 | inversion H. } 23 | Qed. 24 | 25 | 26 | 27 | (* repr funs *) 28 | Definition repr_fun : Set := name -> ground_term. 29 | 30 | Definition gt_eq (gt1 : ground_term) (gt2 : ground_term) : Prop := 31 | proj1_sig gt1 = proj1_sig gt2. 32 | 33 | Definition repr_fun_eq (f1 : repr_fun) (f2 : repr_fun) : Prop := 34 | forall x, gt_eq (f1 x) (f2 x). 35 | 36 | Fixpoint apply_repr_fun (f : repr_fun) (t : term) : ground_term. 37 | refine ( 38 | match t with 39 | | Var x => f x 40 | | Cst n => exist _ (Cst n) eq_refl 41 | | Con n l r => match apply_repr_fun f l, apply_repr_fun f r with 42 | | exist _ lt lg, exist _ rt rg => exist _ (Con n lt rt) _ 43 | end 44 | end 45 | ). 46 | simpl. rewrite lg. rewrite rg. reflexivity. 47 | Defined. 48 | 49 | Lemma repr_fun_eq_apply 50 | (f1 f2 : repr_fun) 51 | (t : term) 52 | (FEQ : repr_fun_eq f1 f2) : 53 | gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t). 54 | Proof. 55 | induction t. 56 | { simpl. auto. } 57 | { reflexivity. } 58 | { red. simpl. 59 | destruct (apply_repr_fun f1 t1). destruct (apply_repr_fun f1 t2). 60 | destruct (apply_repr_fun f2 t1). destruct (apply_repr_fun f2 t2). 61 | simpl. 62 | red in IHt1. simpl in IHt1. 63 | red in IHt2. simpl in IHt2. 64 | subst. auto. } 65 | Qed. 66 | 67 | Lemma apply_repr_fun_fv 68 | (f1 f2 : repr_fun) 69 | (t : term) 70 | (F12_FV_EQ : forall x, (In x (fv_term t)) -> gt_eq (f1 x) (f2 x)) : 71 | gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t). 72 | Proof. 73 | induction t. 74 | { simpl. apply F12_FV_EQ. simpl. auto. } 75 | { unfold gt_eq. auto. } 76 | { unfold gt_eq. simpl. 77 | remember (apply_repr_fun f1 t1) as p11. destruct p11. 78 | remember (apply_repr_fun f1 t2) as p12. destruct p12. 79 | remember (apply_repr_fun f2 t1) as p21. destruct p21. 80 | remember (apply_repr_fun f2 t2) as p22. destruct p22. 81 | simpl. 82 | assert (x = x1). 83 | { apply IHt1. intros. apply F12_FV_EQ. unfold fv_term. 84 | apply (set_union_intro name_eq_dec). left. auto. } 85 | assert (x0 = x2). 86 | { apply IHt2. intros. apply F12_FV_EQ. unfold fv_term. 87 | apply (set_union_intro name_eq_dec). right. auto. } 88 | subst. auto. } 89 | Qed. 90 | 91 | Lemma repr_fun_eq_trans 92 | (f1 f2 f3 : repr_fun) 93 | (EQ12 : repr_fun_eq f1 f2) 94 | (EQ23 : repr_fun_eq f2 f3) : 95 | repr_fun_eq f1 f3. 96 | Proof. 97 | revert EQ12 EQ23. unfold repr_fun_eq. unfold gt_eq. intros. 98 | rewrite EQ12. auto. 99 | Qed. 100 | 101 | Lemma subst_of_gt 102 | (t : term) 103 | (s : subst) 104 | (f : repr_fun) 105 | (FV_IMG : forall x : name, In x (fv_term t) -> image s x = Some (proj1_sig (f x))) : 106 | apply_subst s t = proj1_sig (apply_repr_fun f t). 107 | Proof. 108 | induction t. 109 | { simpl. replace (image s n) with (Some (proj1_sig (f n))). 110 | { auto. } 111 | { symmetry. apply FV_IMG. constructor. auto. } } 112 | { auto. } 113 | { simpl. 114 | destruct (apply_repr_fun f t1). 115 | destruct (apply_repr_fun f t2). 116 | simpl. 117 | replace x with (apply_subst s t1). 118 | { replace x0 with (apply_subst s t2). 119 | { auto. } 120 | { apply IHt2. intros. apply FV_IMG. 121 | apply set_union_intro2. auto. } } 122 | { apply IHt1. intros. apply FV_IMG. 123 | apply set_union_intro1. auto. } } 124 | Qed. 125 | 126 | Definition subst_repr_fun_compose (s : subst) (f : repr_fun) : repr_fun := 127 | fun x => apply_repr_fun f (apply_subst s (Var x)). 128 | 129 | Lemma repr_fun_apply_compose 130 | (s : subst) 131 | (f : repr_fun) 132 | (t : term) : 133 | gt_eq (apply_repr_fun (subst_repr_fun_compose s f) t) (apply_repr_fun f (apply_subst s t)). 134 | Proof. 135 | induction t. 136 | { reflexivity. } 137 | { reflexivity. } 138 | { red. simpl. 139 | destruct (apply_repr_fun (subst_repr_fun_compose s f) t1). 140 | destruct (apply_repr_fun (subst_repr_fun_compose s f) t2). 141 | destruct (apply_repr_fun f (apply_subst s t1)). 142 | destruct (apply_repr_fun f (apply_subst s t2)). 143 | simpl. 144 | red in IHt1. simpl in IHt1. 145 | red in IHt2. simpl in IHt2. 146 | subst. auto. } 147 | Qed. 148 | 149 | Lemma repr_fun_eq_compose 150 | (f1 f2 : repr_fun) 151 | (EQ : repr_fun_eq f1 f2) 152 | (s : subst) : 153 | repr_fun_eq (subst_repr_fun_compose s f1) (subst_repr_fun_compose s f2). 154 | Proof. 155 | unfold repr_fun_eq. unfold repr_fun_eq in EQ. unfold subst_repr_fun_compose. 156 | intro. induction (apply_subst s (Var x)). 157 | { simpl. auto. } 158 | { reflexivity. } 159 | { unfold gt_eq. simpl. 160 | remember (apply_repr_fun f1 t1) as p11. destruct p11. 161 | remember (apply_repr_fun f1 t2) as p12. destruct p12. 162 | remember (apply_repr_fun f2 t1) as p21. destruct p21. 163 | remember (apply_repr_fun f2 t2) as p22. destruct p22. 164 | simpl. 165 | unfold gt_eq in IHt1. simpl in IHt1. rewrite IHt1. 166 | unfold gt_eq in IHt2. simpl in IHt2. rewrite IHt2. 167 | auto. } 168 | Qed. 169 | 170 | Lemma repr_fun_compose_eq 171 | (f : repr_fun) 172 | (s1 s2 : subst) 173 | (EQ : forall t, apply_subst s1 t = apply_subst s2 t) : 174 | repr_fun_eq (subst_repr_fun_compose s1 f) (subst_repr_fun_compose s2 f). 175 | Proof. 176 | unfold repr_fun_eq. unfold subst_repr_fun_compose. unfold gt_eq. 177 | intro. rewrite EQ. auto. 178 | Qed. 179 | 180 | Lemma subst_repr_fun_compose_assoc_subst 181 | (f : repr_fun) 182 | (s s' : subst) : 183 | repr_fun_eq (subst_repr_fun_compose (compose s s') f) 184 | (subst_repr_fun_compose s (subst_repr_fun_compose s' f)). 185 | Proof. 186 | unfold repr_fun_eq. intros. unfold gt_eq. 187 | replace (subst_repr_fun_compose (compose s s') f x) with 188 | (apply_repr_fun (subst_repr_fun_compose (compose s s') f) (Var x)); auto. 189 | rewrite repr_fun_apply_compose. rewrite compose_correctness. 190 | replace (subst_repr_fun_compose s (subst_repr_fun_compose s' f) x) with 191 | (apply_repr_fun (subst_repr_fun_compose s (subst_repr_fun_compose s' f)) (Var x)); auto. 192 | rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose. auto. 193 | Qed. 194 | 195 | 196 | 197 | (* denotational semantics of goals *) 198 | Reserved Notation "[| g , f |]" (at level 0). 199 | 200 | Inductive in_denotational_sem_goal : goal -> repr_fun -> Prop := 201 | | dsgCut : forall f, [| Cut , f |] 202 | | dsgUnify : forall f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)), 203 | [| Unify t1 t2 , f |] 204 | | dsgDisjL : forall f g1 g2 (DSG : in_denotational_sem_goal g1 f), 205 | [| Disj g1 g2 , f |] 206 | | dsgDisjR : forall f g1 g2 (DSG : in_denotational_sem_goal g2 f), 207 | [| Disj g1 g2 , f |] 208 | | dsgConj : forall f g1 g2 (DSG_L : [| g1 , f |]) 209 | (DSG_R : [| g2 , f |]), 210 | [| Conj g1 g2 , f |] 211 | | dsgFresh : forall f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg)) 212 | (DSG : [| fg a , fn |]) 213 | (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)), 214 | [| Fresh fg , f |] 215 | | dsgInvoke : forall r t f (DSG : [| proj1_sig (LanguageSLD.Prog r) t , f |]), 216 | [| Invoke r t, f |] 217 | where "[| g , f |]" := (in_denotational_sem_goal g f). 218 | 219 | Hint Constructors in_denotational_sem_goal : core. 220 | 221 | Reserved Notation "[| n | g , f |]" (at level 0). 222 | 223 | Inductive in_denotational_sem_lev_goal : nat -> goal -> repr_fun -> Prop := 224 | | dslgCut : forall l f, [| (S l) | Cut , f |] 225 | | dslgUnify : forall l f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)), 226 | [| S l | Unify t1 t2 , f |] 227 | | dslgDisjL : forall l f g1 g2 (DSG : [| l | g1 , f |]), 228 | [| l | Disj g1 g2 , f |] 229 | | dslgDisjR : forall l f g1 g2 (DSG : [| l | g2 , f |]), 230 | [| l | Disj g1 g2 , f |] 231 | | dslgConj : forall l f g1 g2 (DSG_L : [| l | g1 , f |]) 232 | (DSG_R : [| l | g2 , f |]), 233 | [| l | Conj g1 g2 , f |] 234 | | dslgFresh : forall l f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg)) 235 | (DSG : [| l | (fg a) , fn |]) 236 | (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)), 237 | in_denotational_sem_lev_goal l (Fresh fg) f 238 | | dslgInvoke : forall l r t f (DSG : [| l | (proj1_sig (LanguageSLD.Prog r) t) , f |]), 239 | [| S l | Invoke r t , f |] 240 | where "[| n | g , f |]" := (in_denotational_sem_lev_goal n g f). 241 | 242 | Hint Constructors in_denotational_sem_lev_goal : core. 243 | 244 | Lemma in_denotational_sem_zero_lev 245 | (g : goal) 246 | (f : repr_fun) : 247 | ~ [| 0 | g , f |]. 248 | Proof. 249 | intro. remember 0 as l. induction H; inversion Heql; auto. 250 | Qed. 251 | 252 | Lemma in_denotational_sem_lev_monotone 253 | (l : nat) 254 | (g : goal) 255 | (f : repr_fun) 256 | (DSG : [| l | g , f |]) 257 | (l' : nat) 258 | (LE: l <= l') : 259 | [| l' | g , f |]. 260 | Proof. 261 | revert LE. revert l'. induction DSG; eauto. 262 | 1-2: intros; destruct l'; auto; inversion LE. 263 | { intros. destruct l'. 264 | { inversion LE. } 265 | { apply le_S_n in LE. auto. } } 266 | Qed. 267 | 268 | Lemma in_denotational_sem_some_lev 269 | (g : goal) 270 | (f : repr_fun) 271 | (DSG : [| g , f |]) : 272 | exists l, [| l | g , f |]. 273 | Proof. 274 | induction DSG. 275 | 1-2: exists 1; auto. 276 | 1-2, 4-5: destruct IHDSG; eauto. 277 | { destruct IHDSG1. destruct IHDSG2. 278 | exists (max x x0). constructor. 279 | { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_l. } 280 | { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_r. } } 281 | Qed. 282 | 283 | Lemma in_denotational_sem_drop_lev 284 | (g : goal) 285 | (f : repr_fun) 286 | (l : nat) 287 | (DSLG : [| l | g , f |]) : 288 | [| g , f |]. 289 | Proof. 290 | induction DSLG; eauto. 291 | Qed. 292 | 293 | 294 | 295 | (* denotational analog *) 296 | 297 | Definition in_denotational_sem_subst (s : subst) (f : repr_fun) : Prop := 298 | exists (f' : repr_fun), repr_fun_eq (subst_repr_fun_compose s f') f. 299 | 300 | Notation "[ s , f ]" := (in_denotational_sem_subst s f) (at level 0). 301 | 302 | Lemma empty_subst_ds 303 | (f : repr_fun) : 304 | [ empty_subst , f ]. 305 | Proof. 306 | red. exists f. red. intros. 307 | unfold subst_repr_fun_compose. rewrite apply_empty. reflexivity. 308 | Qed. 309 | 310 | Lemma unfier_from_gt_unifier 311 | (t1 t2 : term) 312 | (f : repr_fun) 313 | (F_UNIFIES : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)) : 314 | exists s, unifier s t1 t2 /\ [ s , f ]. 315 | Proof. 316 | remember (map (fun x => (x, proj1_sig (f x))) (var_set_union (fv_term t1) (fv_term t2))) as s. 317 | exists s. split. 318 | { red. red in F_UNIFIES. 319 | assert (apply_subst s t1 = proj1_sig (apply_repr_fun f t1)). 320 | { clear F_UNIFIES. 321 | assert (forall x, In x (fv_term t1) -> image s x = Some (proj1_sig (f x))). 322 | { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))). 323 | { apply set_union_intro1. auto. } 324 | remember (var_set_union (fv_term t1) (fv_term t2)). 325 | subst. apply map_image. auto. } 326 | apply subst_of_gt. auto. } 327 | assert (apply_subst s t2 = proj1_sig (apply_repr_fun f t2)). 328 | { clear F_UNIFIES. 329 | assert (forall x, In x (fv_term t2) -> image s x = Some (proj1_sig (f x))). 330 | { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))). 331 | { apply set_union_intro2. auto. } 332 | remember (var_set_union (fv_term t1) (fv_term t2)). 333 | subst. apply map_image. auto. } 334 | apply subst_of_gt. auto. } 335 | congruence. } 336 | { red. exists f. red. intros x. unfold subst_repr_fun_compose. 337 | unfold apply_subst. destruct (image s x) eqn:eq. 338 | { destruct (f x) eqn:eqfx. 339 | assert (x0 = t). 340 | { unfold image in eq. 341 | remember (var_set_union (fv_term t1) (fv_term t2)). clear Heqv. 342 | revert Heqs. revert v. 343 | induction s. 344 | { inversion eq. } 345 | { intros. destruct a as [y t0]. destruct v; good_inversion Heqs. 346 | destruct (Nat.eq_dec n x). 347 | { good_inversion eq. rewrite eqfx. auto. } 348 | { apply IHs with v; auto. } } } 349 | subst. red. simpl. clear eqfx. clear eq. induction t. 350 | { inversion e. } 351 | { auto. } 352 | { simpl in e. apply set_empty_union in e. destruct e. 353 | apply IHt1 in H. apply IHt2 in H0. simpl. 354 | destruct (apply_repr_fun f t3). simpl in H. 355 | destruct (apply_repr_fun f t4). simpl in H0. 356 | simpl. subst. auto. } } 357 | { red. auto. } } 358 | Qed. 359 | 360 | Lemma denotational_sem_uni 361 | (s d : subst) 362 | (t1 t2 : term) 363 | (MGU : mgu (apply_subst s t1) (apply_subst s t2) (Some d)) 364 | (f : repr_fun) : 365 | [ compose s d , f ] <-> [ s , f ] /\ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2). 366 | Proof. 367 | split. 368 | { intros DSS. red in DSS. destruct DSS as [f' ff'_eq]. split. 369 | { red. exists (subst_repr_fun_compose d f'). 370 | eapply repr_fun_eq_trans; eauto. 371 | red. symmetry. apply subst_repr_fun_compose_assoc_subst. } 372 | { red. 373 | specialize (repr_fun_eq_apply _ _ t1 ff'_eq). intro. rewrite <- H. 374 | specialize (repr_fun_eq_apply _ _ t2 ff'_eq). intro. rewrite <- H0. 375 | rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose. 376 | rewrite compose_correctness. rewrite compose_correctness. 377 | apply mgu_unifies in MGU. rewrite MGU. reflexivity. } } 378 | { intros [DSS F_UNIFIES]. destruct DSS as [fs COMP_s_fs]. 379 | assert (FS_UNIFIES : gt_eq (apply_repr_fun fs (apply_subst s t1)) 380 | (apply_repr_fun fs (apply_subst s t2))). 381 | { red. rewrite <- repr_fun_apply_compose. rewrite <- repr_fun_apply_compose. 382 | apply eq_trans with (proj1_sig (apply_repr_fun f t1)). 383 | { apply repr_fun_eq_apply. auto. } 384 | { apply eq_trans with (proj1_sig (apply_repr_fun f t2)); auto. 385 | symmetry. apply repr_fun_eq_apply. auto. } } 386 | apply unfier_from_gt_unifier in FS_UNIFIES. 387 | destruct FS_UNIFIES as [u [UNI DSSu]]. 388 | specialize (mgu_most_general _ _ _ u MGU UNI). intro MG_d. 389 | red in MG_d. destruct MG_d as [ds COMP_u_ds]. destruct DSSu as [fu COMP_u_fu]. 390 | red. exists (subst_repr_fun_compose ds fu). 391 | eapply repr_fun_eq_trans. 2: eauto. 392 | eapply repr_fun_eq_trans. eapply subst_repr_fun_compose_assoc_subst. 393 | eapply repr_fun_eq_trans. 2: eapply repr_fun_eq_compose; eauto. 394 | apply repr_fun_eq_compose. 395 | eapply repr_fun_eq_trans. red; symmetry; eapply subst_repr_fun_compose_assoc_subst. 396 | apply repr_fun_compose_eq. intros. rewrite COMP_u_ds. apply compose_correctness. } 397 | Qed. 398 | 399 | 400 | 401 | (* den sem properties *) 402 | Lemma closedness_condition_lev 403 | (f f' : repr_fun) 404 | (g : goal) 405 | (l : nat) 406 | (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x)) 407 | (DSG : [| l | g , f |]) : 408 | [| l | g , f' |]. 409 | Proof. 410 | revert FF'_EQ. revert f'. induction DSG; intros. 411 | { constructor. } 412 | { constructor. assert (gt_eq (apply_repr_fun f t1) (apply_repr_fun f' t1)). 413 | { apply apply_repr_fun_fv. auto. } 414 | assert (gt_eq (apply_repr_fun f t2) (apply_repr_fun f' t2)). 415 | { apply apply_repr_fun_fv. auto. } 416 | revert UNI H H0. unfold gt_eq. intros. congruence. } 417 | { constructor. apply IHDSG. intros. 418 | apply FF'_EQ. auto. } 419 | { apply dslgDisjR. apply IHDSG. intros. 420 | apply FF'_EQ. auto. } 421 | { constructor. 422 | { apply IHDSG1; intros; apply FF'_EQ; auto. } 423 | { apply IHDSG2; intros; apply FF'_EQ; auto. } } 424 | { remember (fun x => if name_eq_dec x a 425 | then fn a 426 | else f' x) as fn'. 427 | apply dslgFresh with fn' a; auto. 428 | { apply IHDSG. intros. rewrite Heqfn'. 429 | destruct (name_eq_dec x a). 430 | { unfold gt_eq. subst. auto. } 431 | { specialize (EASE _ n). red. rewrite EASE. 432 | apply FF'_EQ. eauto. } } 433 | { rewrite Heqfn'. intros. 434 | destruct (name_eq_dec x a); try contradiction. 435 | reflexivity. } } 436 | { constructor. apply IHDSG. intros. 437 | apply FF'_EQ. constructor. 438 | remember (LanguageSLD.Prog r). destruct d as [rel [Hcl Hco]]. 439 | simpl in H. red in Hcl. red in Hcl. auto. } 440 | Qed. 441 | 442 | Lemma closedness_condition 443 | (f f' : repr_fun) 444 | (g : goal) 445 | (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x)) 446 | (DSG : [| g , f |]) : 447 | [| g , f' |]. 448 | Proof. 449 | apply in_denotational_sem_some_lev in DSG. 450 | destruct DSG as [l DSLG]. 451 | eapply in_denotational_sem_drop_lev. 452 | eapply closedness_condition_lev; eauto. 453 | Qed. 454 | 455 | Lemma den_sem_rename_var 456 | (g1 g2 : goal) 457 | (CG : consistent_goal g1) 458 | (n : nat) 459 | (G1_BOUND : forall x : name, is_fv_of_goal x g1 -> x < n) 460 | (G2_BOUND : forall x : name, is_fv_of_goal x g2 -> x < n) 461 | (a1 a2 : name) 462 | (A12_NEQ : a1 <> a2) 463 | (A2_FRESH : ~ is_fv_of_goal a2 g1) 464 | (REN : renaming a1 a2 g1 g2) 465 | (fa1 fa2 : repr_fun) 466 | (l : nat) 467 | (DSG1 : [| l | g1 , fa1 |]) 468 | (F_SWITCH : gt_eq (fa1 a1) (fa2 a2)) 469 | (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) : 470 | [| l | g2 , fa2 |]. 471 | Proof. 472 | revert CG G1_BOUND G2_BOUND A12_NEQ A2_FRESH REN DSG1 F_SWITCH F12_EQ. 473 | revert g1 g2 n a1 a2 fa1 fa2. 474 | induction l. 475 | { intros. apply in_denotational_sem_zero_lev in DSG1. contradiction. } 476 | { induction g1; intros; good_inversion DSG1; good_inversion REN; good_inversion CG. 477 | { constructor. } 478 | { constructor. 479 | etransitivity. 480 | 2: etransitivity. 481 | 2: apply UNI. 482 | 1-2: etransitivity. 483 | 1, 3: symmetry. 484 | 1, 4: apply repr_fun_apply_compose. 485 | all: apply apply_repr_fun_fv; intros; unfold subst_repr_fun_compose; 486 | simpl; destruct (Nat.eq_dec a1 x); subst; symmetry; auto; 487 | apply F12_EQ; auto; intro; subst; auto. } 488 | { apply dslgDisjL; eauto. eapply IHg1_1; eauto. } 489 | { apply dslgDisjR; eauto. eapply IHg1_2; eauto. } 490 | { constructor; eauto. 491 | { eapply IHg1_1; eauto. } 492 | { eapply IHg1_2; eauto. } } 493 | { apply closedness_condition_lev with fa1. 494 | { intros; apply F12_EQ; intro; subst; auto. } 495 | { econstructor. 496 | 2: eauto. 497 | all: eauto. } } 498 | { rename g into fg. rename fn into fn1. rename a into a0. red in CB_FG. 499 | assert (very_fresh_var : exists y, a0 <> y /\ a2 <> y /\ 500 | (~ is_fv_of_goal y (Fresh fg)) /\ 501 | (~ is_fv_of_goal y (Fresh rfg))). 502 | { destruct (name_eq_dec a0 n); destruct (name_eq_dec a0 (S n)); 503 | destruct (name_eq_dec a2 n); destruct (name_eq_dec a2 (S n)); subst; try omega. 504 | 5, 6, 8, 9: exists n. 505 | 1, 3, 9: exists (S n). 506 | 4, 5: exists (S (S n)). 507 | all: repeat split; try omega. 508 | all: intro CH; try apply G1_BOUND in CH; try apply G2_BOUND in CH; omega. } 509 | destruct very_fresh_var as [a3 [a03_neq [a23_neq [a3_fresh a3_rfresh]]]]. 510 | assert (a13_neq : a1 <> a3). 511 | { intro; subst; auto. } 512 | remember (fun x => if name_eq_dec x a3 513 | then fn1 a0 514 | else if name_eq_dec x a0 515 | then fa2 a0 516 | else fn1 x) as fn0 eqn:fn0_def. 517 | assert (AH0 : in_denotational_sem_lev_goal (S l) (fg a3) fn0). 518 | { subst. 519 | apply H with a0 (max n (max (S a0) (S a3))) a0 a3 fn1; eauto. 520 | { intros. destruct (name_eq_dec x a0); subst. 521 | { zify. omega. } 522 | { assert (x < n); eauto. zify. omega. } } 523 | { intros. destruct (name_eq_dec x a3); subst. 524 | { zify. omega. } 525 | { assert (x < n); eauto. zify. omega. } } 526 | { destruct (name_eq_dec a3 a3); subst. 527 | { reflexivity. } 528 | { contradiction. } } 529 | { intros. destruct (name_eq_dec x a3). 530 | { contradiction. } 531 | { destruct (name_eq_dec x a0). 532 | { contradiction. } 533 | { reflexivity. } } } } 534 | remember (fun x => if name_eq_dec x a2 535 | then fn0 a1 536 | else if name_eq_dec x a1 537 | then fa2 a1 538 | else fn0 x) as fn2 eqn:fn2_def. 539 | assert (AH2 : in_denotational_sem_lev_goal (S l) (rfg a3) fn2). 540 | { apply H with a3 (max n (max (S a0) (S a3))) a1 a2 fn0; subst; eauto. 541 | { intros. destruct (name_eq_dec x a3); subst. 542 | { zify. omega. } 543 | { assert (x < n); eauto. zify. omega. } } 544 | { intros. destruct (name_eq_dec x a3); subst. 545 | { zify. omega. } 546 | { assert (x < n); eauto. zify. omega. } } 547 | { simpl. destruct (name_eq_dec a2 a2); subst. 548 | { reflexivity. } 549 | { contradiction. } } 550 | { intros. simpl. destruct (name_eq_dec x a2). 551 | { contradiction. } 552 | { destruct (name_eq_dec x a1). 553 | { contradiction. } 554 | { reflexivity. } } } } 555 | econstructor; eauto. 556 | intros. subst. destruct (name_eq_dec x a2); subst. 557 | { destruct (name_eq_dec a1 a0); subst. 558 | { contradiction. } 559 | { destruct (name_eq_dec a1 a3); subst. 560 | { contradiction. } 561 | { etransitivity. 562 | { apply EASE. auto. } 563 | { auto. } } } } 564 | { destruct (name_eq_dec x a1); subst. 565 | { reflexivity. } 566 | { destruct (name_eq_dec x a3). 567 | { contradiction. } 568 | { destruct (name_eq_dec x a0); subst. 569 | { reflexivity. } 570 | { etransitivity. 571 | { apply EASE. auto. } 572 | { apply F12_EQ; auto. } } } } } } 573 | { rename n into r. rename n0 into n. 574 | remember (LanguageSLD.Prog r) as d. destruct d as [rel [Hcl Hco]]. 575 | red in Hco. destruct (Hco t) as [Hcog Hcof]. 576 | red in Hcl. unfold closed_goal_in_context in Hcl. 577 | econstructor. 578 | rewrite <- Heqd. simpl. 579 | eapply IHl. 580 | 7: eauto. 581 | all: simpl; eauto. } } 582 | Qed. 583 | 584 | Lemma den_sem_another_fresh_var 585 | (b : name -> goal) 586 | (CG : consistent_goal (Fresh b)) 587 | (n : nat) 588 | (FRESH_BOUND : forall x : name, is_fv_of_goal x (Fresh b) -> x < n) 589 | (a1 a2 : name) 590 | (A1_FRESH : ~ is_fv_of_goal a1 (Fresh b)) 591 | (A2_FRESH : ~ is_fv_of_goal a2 (Fresh b)) 592 | (fa1 fa2 : repr_fun) 593 | (l : nat) 594 | (DSG1 : in_denotational_sem_lev_goal l (b a1) fa1) 595 | (F_SWITCH : gt_eq (fa1 a1) (fa2 a2)) 596 | (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) : 597 | [| l | b a2 , fa2 |]. 598 | Proof. 599 | destruct (name_eq_dec a1 a2); subst. 600 | { apply closedness_condition_lev with fa1; auto. 601 | intros. destruct (name_eq_dec x a2); subst; auto. } 602 | { good_inversion CG. red in CB_FG. 603 | eapply den_sem_rename_var with (g1 := (b a1)) (n := max n (max (S a1) (S a2))); eauto. 604 | { intros. destruct (name_eq_dec x a1); subst. 605 | { zify. omega. } 606 | { assert (x < n); eauto. zify. omega. } } 607 | { intros. destruct (name_eq_dec x a2); subst. 608 | { zify. omega. } 609 | { assert (x < n); eauto. zify. omega. } } } 610 | Qed. 611 | -------------------------------------------------------------------------------- /src/SLDSearch/LanguageSLD.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Coq.Lists.ListSet. 4 | Require Import Arith. 5 | Require Import Omega. 6 | 7 | Require Import Unification. 8 | 9 | Inductive goal : Set := 10 | | Fail : goal 11 | | Cut : goal 12 | | Unify : term -> term -> goal 13 | | Disj : goal -> goal -> goal 14 | | Conj : goal -> goal -> goal 15 | | Fresh : (name -> goal) -> goal 16 | | Invoke : name -> term -> goal. 17 | 18 | Definition rel : Set := term -> goal. 19 | 20 | Inductive is_fv_of_goal (n : name) : goal -> Prop := 21 | | fvUnifyL : forall t1 t2 (IN_FV : In n (fv_term t1)), 22 | is_fv_of_goal n (Unify t1 t2) 23 | | fvUnifyR : forall t1 t2 (IN_FV : In n (fv_term t2)), 24 | is_fv_of_goal n (Unify t1 t2) 25 | | fvDisjL : forall g1 g2 (IS_FV : is_fv_of_goal n g1), 26 | is_fv_of_goal n (Disj g1 g2) 27 | | fvDisjR : forall g1 g2 (IS_FV : is_fv_of_goal n g2), 28 | is_fv_of_goal n (Disj g1 g2) 29 | | fvConjL : forall g1 g2 (IS_FV : is_fv_of_goal n g1), 30 | is_fv_of_goal n (Conj g1 g2) 31 | | fvConjR : forall g1 g2 (IS_FV : is_fv_of_goal n g2), 32 | is_fv_of_goal n (Conj g1 g2) 33 | | fvFresh : forall fg n' (NEQ : n' <> n) 34 | (IS_FV : is_fv_of_goal n (fg n')), 35 | is_fv_of_goal n (Fresh fg) 36 | | fvInvoke : forall r arg (IN_FV : In n (fv_term arg)), 37 | is_fv_of_goal n (Invoke r arg). 38 | 39 | Hint Constructors is_fv_of_goal : core. 40 | 41 | 42 | 43 | (* Weak version of a variable renaming *) 44 | Inductive renaming (old_x : name) (new_x : name) : goal -> goal -> Prop := 45 | | rFail : renaming old_x new_x Fail Fail 46 | | rCut : renaming old_x new_x Cut Cut 47 | | rUnify : forall t1 t2, renaming old_x new_x (Unify t1 t2) 48 | (Unify (apply_subst [(old_x, Var new_x)] t1) 49 | (apply_subst [(old_x, Var new_x)] t2)) 50 | | rDisj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1) 51 | (R_G2 : renaming old_x new_x g2 rg2), 52 | renaming old_x new_x (Disj g1 g2) (Disj rg1 rg2) 53 | | rConj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1) 54 | (R_G2 : renaming old_x new_x g2 rg2), 55 | renaming old_x new_x (Conj g1 g2) (Conj rg1 rg2) 56 | | rFreshNFV : forall fg (OLD_X_NOT_FV : ~ is_fv_of_goal old_x (Fresh fg)), 57 | renaming old_x new_x (Fresh fg) (Fresh fg) 58 | | rFreshFV : forall fg rfg (OLD_X_FV : is_fv_of_goal old_x (Fresh fg)) 59 | (R_FG : forall y (Y_NOT_FV : ~ is_fv_of_goal y (Fresh fg)), 60 | renaming old_x new_x (fg y) (rfg y)), 61 | renaming old_x new_x (Fresh fg) (Fresh rfg) 62 | | rInvoke : forall r arg, renaming old_x new_x (Invoke r arg) 63 | (Invoke r (apply_subst [(old_x, Var new_x)] arg)). 64 | 65 | Hint Constructors renaming : core. 66 | 67 | Definition consistent_binding (b : name -> goal) : Prop := 68 | forall x y, (~ is_fv_of_goal x (Fresh b)) -> renaming x y (b x) (b y). 69 | 70 | Inductive consistent_goal : goal -> Prop := 71 | | cgFail : consistent_goal Fail 72 | | cgCut : consistent_goal Cut 73 | | cgUnify : forall t1 t2, consistent_goal (Unify t1 t2) 74 | | cgDisj : forall g1 g2 (CG_G1 : consistent_goal g1) 75 | (CG_G2 : consistent_goal g2), 76 | consistent_goal (Disj g1 g2) 77 | | cgConj : forall g1 g2 (CG_G1 : consistent_goal g1) 78 | (CG_G2 : consistent_goal g2), 79 | consistent_goal (Conj g1 g2) 80 | | cgFresh : forall fg (CB_FG : consistent_binding fg) 81 | (CG_BODY : forall n, consistent_goal (fg n)), 82 | consistent_goal (Fresh fg) 83 | | cgInvoke : forall r arg, consistent_goal (Invoke r arg). 84 | 85 | Hint Constructors consistent_goal : core. 86 | 87 | Definition consistent_function (f : term -> goal) : Prop := 88 | forall a1 a2 t, renaming a1 a2 (f t) (f (apply_subst [(a1, Var a2)] t)). 89 | 90 | Definition consistent_rel (r : rel) : Prop := 91 | forall (arg : term), consistent_goal (r arg) /\ consistent_function r. 92 | 93 | 94 | 95 | Definition closed_goal_in_context (c : list name) (g : goal) : Prop := 96 | forall n, is_fv_of_goal n g -> In n c. 97 | 98 | Definition closed_rel (r : rel) : Prop := 99 | forall (arg : term), closed_goal_in_context (fv_term arg) (r arg). 100 | 101 | 102 | 103 | Definition def : Set := {r : rel | closed_rel r /\ consistent_rel r}. 104 | 105 | Definition spec : Set := name -> def. 106 | 107 | Axiom Prog : spec. 108 | -------------------------------------------------------------------------------- /src/SLDSearch/OperationalSemSLD.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Coq.Lists.ListSet. 4 | Require Import Coq.Program.Equality. 5 | Require Import Omega. 6 | Require Import Extraction. 7 | 8 | Require Import Unification. 9 | Require Import Streams. 10 | Require Import LanguageSLD. 11 | Require Import DenotationalSemSLD. 12 | 13 | 14 | (************************* States *************************) 15 | 16 | Inductive cutting_mark : Set := 17 | | StopCutting : cutting_mark 18 | | KeepCutting : cutting_mark. 19 | 20 | Inductive nt_state : Set := 21 | | Leaf : goal -> subst -> nat -> nt_state 22 | | Sum : cutting_mark -> nt_state -> nt_state -> nt_state 23 | | Prod : nt_state -> goal -> nt_state. 24 | 25 | Inductive state : Set := 26 | | Stop : state 27 | | NTState : nt_state -> state. 28 | 29 | Inductive is_fv_of_nt_state : name -> nt_state -> Prop := 30 | | isfvnstLeaf : forall x g s n (X_FV_G : is_fv_of_goal x g), 31 | is_fv_of_nt_state x (Leaf g s n) 32 | | isfvnstSumL : forall x m nst1 nst2 (X_FV : is_fv_of_nt_state x nst1), 33 | is_fv_of_nt_state x (Sum m nst1 nst2) 34 | | isfvnstSumR : forall x m nst1 nst2 (X_FV : is_fv_of_nt_state x nst2), 35 | is_fv_of_nt_state x (Sum m nst1 nst2) 36 | | isfvnstProdL : forall x nst g (X_FV : is_fv_of_nt_state x nst), 37 | is_fv_of_nt_state x (Prod nst g) 38 | | isfvnstProdR : forall x nst g (X_FV : is_fv_of_goal x g), 39 | is_fv_of_nt_state x (Prod nst g). 40 | 41 | Hint Constructors is_fv_of_nt_state : core. 42 | 43 | Inductive is_fv_of_state : name -> state -> Prop := 44 | | isfvstC : forall x nst (X_FV_NT_ST : is_fv_of_nt_state x nst), 45 | is_fv_of_state x (NTState nst). 46 | 47 | Hint Constructors is_fv_of_state : core. 48 | 49 | Inductive is_counter_of_nt_state : nat -> nt_state -> Prop := 50 | | iscnstLeaf : forall g s n, is_counter_of_nt_state n (Leaf g s n) 51 | | iscnstSumL : forall n m nst1 nst2 (ISC : is_counter_of_nt_state n nst1), 52 | is_counter_of_nt_state n (Sum m nst1 nst2) 53 | | iscnstSumR : forall n m nst1 nst2 (ISC : is_counter_of_nt_state n nst2), 54 | is_counter_of_nt_state n (Sum m nst1 nst2) 55 | | iscnstProd : forall n nst g (ISC : is_counter_of_nt_state n nst), 56 | is_counter_of_nt_state n (Prod nst g). 57 | 58 | Hint Constructors is_counter_of_nt_state : core. 59 | 60 | Inductive well_formed_nt_state : nt_state -> Prop := 61 | | wfLeaf : forall g s frn 62 | (DOM_LT_COUNTER : forall x (X_IN_DOM : in_subst_dom s x), x < frn) 63 | (VRAN_LT_COUNTER : forall x (X_IN_VRAN : in_subst_vran s x), x < frn) 64 | (FV_LT_COUNTER : forall x (X_FV : is_fv_of_goal x g), x < frn), 65 | well_formed_nt_state (Leaf g s frn) 66 | | wfSum : forall m nst1 nst2 (WF_L : well_formed_nt_state nst1) 67 | (WF_R : well_formed_nt_state nst2), 68 | well_formed_nt_state (Sum m nst1 nst2) 69 | | wfProd : forall nst g (WF_L : well_formed_nt_state nst) 70 | (FV_LT_COUNTER : forall x frn (FRN_COUNTER : is_counter_of_nt_state frn nst) 71 | (X_FV : is_fv_of_goal x g), 72 | x < frn), 73 | well_formed_nt_state (Prod nst g). 74 | 75 | Hint Constructors well_formed_nt_state : core. 76 | 77 | Fixpoint first_nats (k : nat) : list nat := 78 | match k with 79 | | 0 => [] 80 | | S n => n :: first_nats n 81 | end. 82 | 83 | Lemma first_nats_less (n k : nat) (H : In n (first_nats k)) : n < k. 84 | Proof. 85 | induction k. 86 | { inversion H. } 87 | { inversion H. { omega. } { apply IHk in H0. omega. } } 88 | Qed. 89 | 90 | Lemma well_formed_initial_state 91 | (g : goal) 92 | (k : nat) 93 | (HC : closed_goal_in_context (first_nats k) g) : 94 | well_formed_nt_state (Leaf g empty_subst k). 95 | Proof. 96 | constructor. 97 | { intros. good_inversion X_IN_DOM. good_inversion H. } 98 | { intros. good_inversion X_IN_VRAN. destruct H as [t0 [H0 _]]. good_inversion H0. } 99 | { red in HC. intros. apply first_nats_less; auto. } 100 | Qed. 101 | 102 | 103 | Inductive well_formed_state : state -> Prop := 104 | | wfTerminal : well_formed_state Stop 105 | | wfNonTerminal : forall nst (wfState : well_formed_nt_state nst), 106 | well_formed_state (NTState nst). 107 | 108 | Hint Constructors well_formed_state : core. 109 | 110 | 111 | 112 | (************************** LTS ***************************) 113 | (* Labels *) 114 | Inductive label : Set := 115 | | Step : label 116 | | Answer : subst -> nat -> label. 117 | 118 | (* Cutting signal *) 119 | Inductive cut_signal : Set := 120 | | NoCutting : cut_signal 121 | | YesCutting : cut_signal. 122 | 123 | (* Transitions *) 124 | Inductive eval_step : nt_state -> label -> cut_signal -> state -> Prop := 125 | | esFail : forall s n, eval_step (Leaf Fail s n) Step NoCutting Stop 126 | | esCut : forall s n, eval_step (Leaf Cut s n) (Answer s n) YesCutting Stop 127 | | esUnifyFail : forall t1 t2 s n (MGU : mgu (apply_subst s t1) (apply_subst s t2) None), 128 | eval_step (Leaf (Unify t1 t2) s n) Step NoCutting Stop 129 | | esUnifySuccess : forall t1 t2 s d n (MGU : mgu (apply_subst s t1) (apply_subst s t2) (Some d)), 130 | eval_step (Leaf (Unify t1 t2) s n) (Answer (compose s d) n) NoCutting Stop 131 | | esDisj : forall g1 g2 s n, eval_step (Leaf (Disj g1 g2) s n) Step NoCutting (NTState (Sum StopCutting (Leaf g1 s n) (Leaf g2 s n))) 132 | | esConj : forall g1 g2 s n, eval_step (Leaf (Conj g1 g2) s n) Step NoCutting (NTState (Prod (Leaf g1 s n) g2)) 133 | | esFresh : forall fg s n, eval_step (Leaf (Fresh fg) s n) Step NoCutting (NTState (Leaf (fg n) s (S n))) 134 | | esInvoke : forall r arg s n, eval_step (Leaf (Invoke r arg) s n) Step NoCutting (NTState (Leaf (proj1_sig (LanguageSLD.Prog r) arg) s n)) 135 | | esSumE : forall m nst1 nst2 l (STEP_L : eval_step nst1 l NoCutting Stop), 136 | eval_step (Sum m nst1 nst2) l NoCutting (NTState nst2) 137 | | esSumECS : forall nst1 nst2 l (STEP_L : eval_step nst1 l YesCutting Stop), 138 | eval_step (Sum StopCutting nst1 nst2) l NoCutting Stop 139 | | esSumECK : forall nst1 nst2 l (STEP_L : eval_step nst1 l YesCutting Stop), 140 | eval_step (Sum KeepCutting nst1 nst2) l YesCutting Stop 141 | | esSumNE : forall m nst1 nst1' nst2 l (STEP_L : eval_step nst1 l NoCutting (NTState nst1')), 142 | eval_step (Sum m nst1 nst2) l NoCutting (NTState (Sum m nst1' nst2)) 143 | | esSumNECS : forall nst1 nst1' nst2 l (STEP_L : eval_step nst1 l YesCutting (NTState nst1')), 144 | eval_step (Sum StopCutting nst1 nst2) l NoCutting (NTState nst1') 145 | | esSumNECK : forall nst1 nst1' nst2 l (STEP_L : eval_step nst1 l YesCutting (NTState nst1')), 146 | eval_step (Sum KeepCutting nst1 nst2) l YesCutting (NTState nst1') 147 | | esProdSE : forall nst g cs (STEP_L : eval_step nst Step cs Stop), 148 | eval_step (Prod nst g) Step cs Stop 149 | | esProdAE : forall nst g s n cs (STEP_L : eval_step nst (Answer s n) cs Stop), 150 | eval_step (Prod nst g) Step cs (NTState (Leaf g s n)) 151 | | esProdSNE : forall nst g cs nst' (STEP_L : eval_step nst Step cs (NTState nst')), 152 | eval_step (Prod nst g) Step cs (NTState (Prod nst' g)) 153 | | esProdANE : forall nst g s n cs nst' (STEP_L : eval_step nst (Answer s n) cs (NTState nst')), 154 | eval_step (Prod nst g) Step cs (NTState (Sum KeepCutting (Leaf g s n) (Prod nst' g))). 155 | 156 | Hint Constructors eval_step : core. 157 | 158 | Lemma counter_in_answer 159 | (nst : nt_state) 160 | (s : subst) 161 | (n : nat) 162 | (cs : cut_signal) 163 | (st : state) 164 | (EV : eval_step nst (Answer s n) cs st) : 165 | is_counter_of_nt_state n nst. 166 | Proof. 167 | remember (Answer s n). induction EV; good_inversion Heql; auto. 168 | Qed. 169 | 170 | Lemma counter_in_next_state 171 | (n : nat) 172 | (nst nst_next : nt_state) 173 | (l : label) 174 | (cs : cut_signal) 175 | (EV : eval_step nst l cs (NTState nst_next)) 176 | (ISC_NEXT : is_counter_of_nt_state n nst_next) : 177 | exists n', n' <= n /\ is_counter_of_nt_state n' nst. 178 | Proof. 179 | remember (NTState nst_next) as st. 180 | revert Heqst ISC_NEXT. revert nst_next. 181 | induction EV; intros; good_inversion Heqst. 182 | { exists n. split. 183 | { constructor. } 184 | { good_inversion ISC_NEXT; good_inversion ISC; auto. } } 185 | { exists n. split. 186 | { constructor. } 187 | { good_inversion ISC_NEXT; good_inversion ISC; auto. } } 188 | { good_inversion ISC_NEXT. exists n0. split. 189 | { repeat constructor. } 190 | { auto. } } 191 | { exists n. split. 192 | { constructor. } 193 | { good_inversion ISC_NEXT; auto. } } 194 | { exists n. split. 195 | { constructor. } 196 | { auto. } } 197 | { specialize (IHEV nst1' eq_refl). good_inversion ISC_NEXT. 198 | { apply IHEV in ISC. destruct ISC as [n' [LE ISC]]. 199 | exists n'; auto. } 200 | { exists n. split. 201 | { constructor. } 202 | { auto. } } } 203 | { destruct (IHEV nst_next eq_refl ISC_NEXT) as [n' [LE ISC]]. 204 | exists n'; auto. } 205 | { destruct (IHEV nst_next eq_refl ISC_NEXT) as [n' [LE ISC]]. 206 | exists n'; auto. } 207 | { good_inversion ISC_NEXT. exists n0. 208 | eapply counter_in_answer in EV. split; auto. } 209 | { specialize (IHEV nst' eq_refl). good_inversion ISC_NEXT. 210 | apply IHEV in ISC. destruct ISC as [n' [LE ISC]]. 211 | exists n'; auto. } 212 | { specialize (IHEV nst' eq_refl). good_inversion ISC_NEXT. 213 | { good_inversion ISC. exists n0. 214 | eapply counter_in_answer in EV. split; auto. } 215 | { good_inversion ISC. apply IHEV in ISC0. 216 | destruct ISC0 as [n' [LE ISC]]. exists n'; auto. } } 217 | 218 | Qed. 219 | 220 | Lemma well_formed_subst_in_answer 221 | (nst : nt_state) 222 | (s : subst) 223 | (n : nat) 224 | (cs : cut_signal) 225 | (st : state) 226 | (EV : eval_step nst (Answer s n) cs st) 227 | (WF : well_formed_nt_state nst) : 228 | (forall x, in_subst_dom s x -> x < n) /\ (forall x, in_subst_vran s x -> x < n). 229 | Proof. 230 | remember (Answer s n). induction EV; good_inversion Heql; good_inversion WF; auto. 231 | assert (FV_LT_N_1 : forall x, In x (fv_term (apply_subst s0 t1)) -> x < n). 232 | { clear MGU. clear d. intros. induction t1. 233 | { simpl in H. destruct (image s0 n0) eqn:eq; auto. 234 | apply VRAN_LT_COUNTER. red. eauto. } 235 | { good_inversion H. } 236 | { simpl in H. apply (set_union_elim name_eq_dec) in H. destruct H. 237 | { apply IHt1_1; auto. intros. apply FV_LT_COUNTER. 238 | good_inversion X_FV; auto. apply fvUnifyL. simpl. 239 | apply set_union_intro. left. auto. } 240 | { apply IHt1_2; auto. intros. apply FV_LT_COUNTER. 241 | good_inversion X_FV; auto. apply fvUnifyL. simpl. 242 | apply set_union_intro. right. auto. } } } 243 | assert (FV_LT_N_2 : forall x, In x (fv_term (apply_subst s0 t2)) -> x < n). 244 | { clear MGU. clear d. intros. induction t2. 245 | { simpl in H. destruct (image s0 n0) eqn:eq; auto. 246 | apply VRAN_LT_COUNTER. red. eauto. } 247 | { good_inversion H. } 248 | { simpl in H. apply (set_union_elim name_eq_dec) in H. destruct H. 249 | { apply IHt2_1; auto. intros. apply FV_LT_COUNTER. 250 | good_inversion X_FV; auto. apply fvUnifyR. simpl. 251 | apply set_union_intro. left. auto. } 252 | { apply IHt2_2; auto. intros. apply FV_LT_COUNTER. 253 | good_inversion X_FV; auto. apply fvUnifyR. simpl. 254 | apply set_union_intro. right. auto. } } } 255 | specialize (mgu_dom _ _ _ MGU). intro S'_DOM. 256 | specialize (mgu_vran _ _ _ MGU). intro S'_VRAN. 257 | split. 258 | { intros. apply compose_dom in H. destruct H; auto. 259 | apply S'_DOM in H. destruct H; auto. } 260 | { intros. apply compose_vran in H. destruct H; auto. 261 | apply S'_VRAN in H. destruct H; auto. } 262 | Qed. 263 | 264 | Lemma well_formedness_preservation 265 | (nst : nt_state) 266 | (l : label) 267 | (cs : cut_signal) 268 | (st : state) 269 | (EV : eval_step nst l cs st) 270 | (WF : well_formed_nt_state nst) : 271 | well_formed_state st. 272 | Proof. 273 | intros. induction EV; good_inversion WF; auto. 274 | { constructor. auto. } 275 | { constructor. constructor; auto. 276 | intros. good_inversion FRN_COUNTER. subst. auto. } 277 | { constructor. constructor; auto. 278 | 1-2: intros; eapply lt_trans; eauto. 279 | intros. destruct (eq_nat_dec n x). 280 | { omega. } 281 | { apply Nat.lt_lt_succ_r. apply FV_LT_COUNTER. econstructor; eauto. } } 282 | { constructor. constructor; auto. 283 | specialize (proj2_sig (LanguageSLD.Prog r)). intro CC. 284 | simpl in CC. destruct CC as [CL _]. red in CL. red in CL. auto. } 285 | { specialize (IHEV WF_L). 286 | good_inversion IHEV. auto. } 287 | { constructor. constructor; auto. 288 | 1-2: apply well_formed_subst_in_answer in EV; destruct EV; auto. 289 | intros. apply FV_LT_COUNTER; auto. eapply counter_in_answer; eauto. } 290 | { specialize (IHEV WF_L). good_inversion IHEV. 291 | constructor. constructor; auto. intros. 292 | eapply counter_in_next_state in EV; eauto. 293 | destruct EV as [frn' [LE ISC]]. eapply lt_le_trans. 294 | 2: eauto. 295 | auto. } 296 | { specialize (IHEV WF_L). good_inversion IHEV. 297 | constructor. constructor. 298 | { constructor. 299 | 1-2: apply well_formed_subst_in_answer in EV; destruct EV; auto. 300 | intros. apply FV_LT_COUNTER; auto. 301 | eapply counter_in_answer; eauto. } 302 | { constructor; auto. intros. 303 | eapply counter_in_next_state in EV; eauto. 304 | destruct EV as [frn' [Le ISC]]. eapply lt_le_trans. 305 | 2: eauto. 306 | auto. } } 307 | Qed. 308 | 309 | Lemma eval_step_exists 310 | (nst : nt_state) : 311 | {l : label & {cs : cut_signal & {st : state & eval_step nst l cs st}}}. 312 | Proof. 313 | induction nst. 314 | { destruct g. 315 | 1-2,4-7: repeat eexists; econstructor. 316 | { assert ({r & mgu (apply_subst s t) (apply_subst s t0) r}). 317 | { apply mgu_result_exists. } 318 | destruct H. destruct x. 319 | { repeat eexists; eauto. } 320 | { repeat eexists; eauto. } } } 321 | { destruct IHnst1 as [l1 [cs [st1 IH1]]]. 322 | destruct st1; destruct cs; destruct c. 323 | all: repeat eexists; eauto. } 324 | { destruct IHnst as [l [cs [st IH]]]. destruct st; destruct l. 325 | all: repeat eexists; eauto. } 326 | Defined. 327 | 328 | Lemma eval_step_unique 329 | (nst : nt_state) 330 | (l1 l2 : label) 331 | (cs1 cs2 : cut_signal) 332 | (st1 st2 : state) 333 | (STEP_1 : eval_step nst l1 cs1 st1) 334 | (STEP_2 : eval_step nst l2 cs2 st2) : 335 | l1 = l2 /\ cs1 = cs2 /\ st1 = st2. 336 | Proof. 337 | revert STEP_1 STEP_2. revert l1 l2 cs1 cs2 st1 st2. induction nst. 338 | { intros. destruct g; good_inversion STEP_1; good_inversion STEP_2; auto. 339 | { assert (C : None = Some d). 340 | { eapply mgu_result_unique; eassumption. } 341 | inversion C. } 342 | { assert (C : None = Some d). 343 | { eapply mgu_result_unique; eassumption. } 344 | inversion C. } 345 | { assert (EQ : Some d = Some d0). 346 | { eapply mgu_result_unique; eassumption. } 347 | good_inversion EQ. auto. } } 348 | { intros. good_inversion STEP_1; good_inversion STEP_2; 349 | destruct (IHnst1 _ _ _ _ _ _ STEP_L STEP_L0) as [EQL [EQCS EQST]]; 350 | inversion EQCS; inversion EQST; subst; auto. } 351 | { intros. good_inversion STEP_1; good_inversion STEP_2; 352 | destruct (IHnst _ _ _ _ _ _ STEP_L STEP_L0)as [EQL [EQCS EQST]]; 353 | inversion EQL; inversion EQCS; inversion EQST; auto. } 354 | Qed. 355 | 356 | 357 | 358 | (***************** Operational Semantics ******************) 359 | 360 | Definition trace : Set := @stream label. 361 | 362 | CoInductive op_sem : state -> trace -> Prop := 363 | | osStop : op_sem Stop Nil 364 | | osNTState : forall nst l cs st t (EV: eval_step nst l cs st) 365 | (OP: op_sem st t), 366 | op_sem (NTState nst) (Cons l t). 367 | 368 | Hint Constructors op_sem : core. 369 | 370 | CoFixpoint trace_from (st : state) : trace := 371 | match st with 372 | | Stop => Nil 373 | | NTState nst => 374 | match eval_step_exists nst with 375 | | existT _ l (existT _ _ (existT _ nst' ev_nst_nst')) => 376 | Cons l (trace_from nst') 377 | end 378 | end. 379 | 380 | Lemma trace_from_correct 381 | (st : state) : 382 | op_sem st (trace_from st). 383 | Proof. 384 | revert st. cofix CIH. destruct st. 385 | { rewrite helper_eq. simpl. constructor. } 386 | { rewrite helper_eq. simpl. 387 | destruct (eval_step_exists n) as [l [cs [st EV]]]. 388 | econstructor; eauto. } 389 | Qed. 390 | 391 | Lemma op_sem_exists 392 | (st : state) : 393 | {t : trace & op_sem st t}. 394 | Proof. 395 | eexists. eapply trace_from_correct. 396 | Defined. 397 | 398 | Lemma op_sem_unique 399 | (st : state) 400 | (t1 t2 : trace) 401 | (OP_1 : op_sem st t1) 402 | (OP_2 : op_sem st t2) : 403 | equal_streams t1 t2. 404 | Proof. 405 | revert OP_1 OP_2. revert t1 t2 st. 406 | cofix CIH. intros. inversion OP_1; inversion OP_2; 407 | rewrite <- H1 in H; inversion H. 408 | { constructor. } 409 | { subst. 410 | destruct (eval_step_unique _ _ _ _ _ _ _ EV EV0) as [EQL [EQCS EQST]]. 411 | constructor. 412 | { auto. } 413 | { subst. eapply CIH; eauto. } } 414 | Qed. 415 | 416 | Definition in_denotational_analog (t : trace) (f : repr_fun) : Prop := 417 | exists (s : subst) (n : nat), 418 | in_stream (Answer s n) t /\ [ s , f ]. 419 | 420 | Notation "{| t , f |}" := (in_denotational_analog t f). 421 | 422 | Extraction Language Haskell. 423 | 424 | Extraction "extracted/sld_interpreter.hs" op_sem_exists. 425 | -------------------------------------------------------------------------------- /src/SLDSearch/SoundnessSLD.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Coq.Lists.ListSet. 3 | Import ListNotations. 4 | Require Import Omega. 5 | 6 | Require Import Unification. 7 | Require Import Streams. 8 | Require Import LanguageSLD. 9 | Require Import DenotationalSemSLD. 10 | Require Import OperationalSemSLD. 11 | 12 | Inductive in_denotational_sem_nt_state : nt_state -> repr_fun -> Prop := 13 | | dsnstLeaf : forall g s n f (DSG : [| g , f |]) 14 | (DSS : [ s , f ]), 15 | in_denotational_sem_nt_state (Leaf g s n) f 16 | | dsnstSumL : forall m nst1 nst2 f (DSST' : in_denotational_sem_nt_state nst1 f), 17 | in_denotational_sem_nt_state (Sum m nst1 nst2) f 18 | | dsnstSumR : forall m nst1 nst2 f (DSST' : in_denotational_sem_nt_state nst2 f), 19 | in_denotational_sem_nt_state (Sum m nst1 nst2) f 20 | | dsnstProd : forall nst g f (DSG : [| g , f |]) 21 | (DSST' : in_denotational_sem_nt_state nst f), 22 | in_denotational_sem_nt_state (Prod nst g) f. 23 | 24 | Hint Constructors in_denotational_sem_nt_state : core. 25 | 26 | Inductive in_denotational_sem_state : state -> repr_fun -> Prop := 27 | | dsstNTState : forall nst f (DSST' : in_denotational_sem_nt_state nst f), 28 | in_denotational_sem_state (NTState nst) f. 29 | 30 | Hint Constructors in_denotational_sem_state : core. 31 | 32 | 33 | Lemma answer_correct 34 | (s : subst) 35 | (n : nat) 36 | (f : repr_fun) 37 | (DSS : [ s , f ]) 38 | (st' : nt_state) 39 | (cs : cut_signal) 40 | (st : state) 41 | (EV : eval_step st' (Answer s n) cs st) : 42 | in_denotational_sem_nt_state st' f. 43 | Proof. 44 | remember (Answer s n) as l. 45 | induction EV; good_inversion Heql; auto. 46 | { assert (DSS_copy := DSS). apply (denotational_sem_uni _ _ _ _ MGU _) in DSS. 47 | destruct DSS as [DSS EQ]. constructor; auto. } 48 | Qed. 49 | 50 | Lemma next_state_correct 51 | (f : repr_fun) 52 | (st : state) 53 | (DSS : in_denotational_sem_state st f) 54 | (st' : nt_state) 55 | (WF : well_formed_nt_state st') 56 | (h : label) 57 | (cs : cut_signal) 58 | (EV : eval_step st' h cs st) : 59 | in_denotational_sem_nt_state st' f. 60 | Proof. 61 | induction EV; good_inversion DSS. 62 | { good_inversion DSST'; good_inversion DSST'0; 63 | constructor; auto. } 64 | { good_inversion DSST'. good_inversion DSST'0. auto. } 65 | { good_inversion WF. good_inversion DSST'. 66 | constructor; auto. econstructor; eauto. 67 | intros HIn. apply FV_LT_COUNTER in HIn. 68 | { omega. } 69 | { reflexivity. } } 70 | { good_inversion DSST'. auto. } 71 | { auto. } 72 | { good_inversion WF. good_inversion DSST'; auto. } 73 | { good_inversion WF. good_inversion DSST'; auto. } 74 | { good_inversion WF. good_inversion DSST'; auto. } 75 | { good_inversion DSST'. constructor; auto. 76 | eapply answer_correct; eauto. } 77 | { good_inversion WF. good_inversion DSST'. auto. } 78 | { good_inversion WF. good_inversion DSST'. 79 | { good_inversion DSST'0. 80 | constructor; auto. 81 | eapply answer_correct; eauto. } 82 | { good_inversion DSST'0. auto. } } 83 | Qed. 84 | 85 | Lemma search_correctness_generalized 86 | (st : state) 87 | (WF : well_formed_state st) 88 | (f : repr_fun) 89 | (t : trace) 90 | (HOP : op_sem st t) 91 | (HDA : {| t , f |}) : 92 | in_denotational_sem_state st f. 93 | Proof. 94 | revert HOP WF. revert st. 95 | red in HDA. destruct HDA as [s [n [HInStr DSS]]]. 96 | remember (Answer s n) as l. induction HInStr. 97 | { intros. inversion HOP; clear HOP; subst. 98 | constructor. eapply answer_correct; eauto. } 99 | { specialize (IHHInStr Heql). intros. 100 | inversion HOP; clear HOP; subst. 101 | inversion WF; clear WF; subst. 102 | specialize (well_formedness_preservation _ _ _ _ EV wfState). 103 | intro wf_st0. 104 | specialize (IHHInStr st0 OP wf_st0). 105 | constructor. eapply next_state_correct; eauto. } 106 | Qed. 107 | 108 | Lemma search_correctness 109 | (g : goal) 110 | (k : nat) 111 | (HC : closed_goal_in_context (first_nats k) g) 112 | (f : repr_fun) 113 | (t : trace) 114 | (HOP : op_sem (NTState (Leaf g empty_subst k)) t) 115 | (HDA : {| t , f |}) : 116 | [| g , f |]. 117 | Proof. 118 | remember (NTState (Leaf g empty_subst k)) as st. 119 | assert (in_denotational_sem_state st f). 120 | { eapply search_correctness_generalized; eauto. 121 | subst. constructor. apply well_formed_initial_state; auto. } 122 | subst. inversion H. inversion DSST'. auto. 123 | Qed. 124 | -------------------------------------------------------------------------------- /src/Syntax/Language.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import ListNotations. 3 | Require Import Coq.Lists.ListSet. 4 | Require Import Arith. 5 | Require Import Omega. 6 | 7 | Require Import Unification. 8 | 9 | Inductive goal : Set := 10 | | Fail : goal 11 | | Unify : term -> term -> goal 12 | | Disj : goal -> goal -> goal 13 | | Conj : goal -> goal -> goal 14 | | Fresh : (name -> goal) -> goal 15 | | Invoke : name -> term -> goal. 16 | 17 | Definition rel : Set := term -> goal. 18 | 19 | Inductive is_fv_of_goal (n : name) : goal -> Prop := 20 | | fvUnifyL : forall t1 t2 (IN_FV : In n (fv_term t1)), 21 | is_fv_of_goal n (Unify t1 t2) 22 | | fvUnifyR : forall t1 t2 (IN_FV : In n (fv_term t2)), 23 | is_fv_of_goal n (Unify t1 t2) 24 | | fvDisjL : forall g1 g2 (IS_FV : is_fv_of_goal n g1), 25 | is_fv_of_goal n (Disj g1 g2) 26 | | fvDisjR : forall g1 g2 (IS_FV : is_fv_of_goal n g2), 27 | is_fv_of_goal n (Disj g1 g2) 28 | | fvConjL : forall g1 g2 (IS_FV : is_fv_of_goal n g1), 29 | is_fv_of_goal n (Conj g1 g2) 30 | | fvConjR : forall g1 g2 (IS_FV : is_fv_of_goal n g2), 31 | is_fv_of_goal n (Conj g1 g2) 32 | | fvFresh : forall fg n' (NEQ : n' <> n) 33 | (IS_FV : is_fv_of_goal n (fg n')), 34 | is_fv_of_goal n (Fresh fg) 35 | | fvInvoke : forall r arg (IN_FV : In n (fv_term arg)), 36 | is_fv_of_goal n (Invoke r arg). 37 | 38 | Hint Constructors is_fv_of_goal : core. 39 | 40 | 41 | 42 | (* Weak version of a variable renaming *) 43 | Inductive renaming (old_x : name) (new_x : name) : goal -> goal -> Prop := 44 | | rFail : renaming old_x new_x Fail Fail 45 | | rUnify : forall t1 t2, renaming old_x new_x (Unify t1 t2) 46 | (Unify (apply_subst [(old_x, Var new_x)] t1) 47 | (apply_subst [(old_x, Var new_x)] t2)) 48 | | rDisj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1) 49 | (R_G2 : renaming old_x new_x g2 rg2), 50 | renaming old_x new_x (Disj g1 g2) (Disj rg1 rg2) 51 | | rConj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1) 52 | (R_G2 : renaming old_x new_x g2 rg2), 53 | renaming old_x new_x (Conj g1 g2) (Conj rg1 rg2) 54 | | rFreshNFV : forall fg (OLD_X_NOT_FV : ~ is_fv_of_goal old_x (Fresh fg)), 55 | renaming old_x new_x (Fresh fg) (Fresh fg) 56 | | rFreshFV : forall fg rfg (OLD_X_FV : is_fv_of_goal old_x (Fresh fg)) 57 | (R_FG : forall y (Y_NOT_FV : ~ is_fv_of_goal y (Fresh fg)), 58 | renaming old_x new_x (fg y) (rfg y)), 59 | renaming old_x new_x (Fresh fg) (Fresh rfg) 60 | | rInvoke : forall r arg, renaming old_x new_x (Invoke r arg) 61 | (Invoke r (apply_subst [(old_x, Var new_x)] arg)). 62 | 63 | Hint Constructors renaming : core. 64 | 65 | Definition consistent_binding (b : name -> goal) : Prop := 66 | forall x y, (~ is_fv_of_goal x (Fresh b)) -> renaming x y (b x) (b y). 67 | 68 | Inductive consistent_goal : goal -> Prop := 69 | | cgFail : consistent_goal Fail 70 | | cgUnify : forall t1 t2, consistent_goal (Unify t1 t2) 71 | | cgDisj : forall g1 g2 (CG_G1 : consistent_goal g1) 72 | (CG_G2 : consistent_goal g2), 73 | consistent_goal (Disj g1 g2) 74 | | cgConj : forall g1 g2 (CG_G1 : consistent_goal g1) 75 | (CG_G2 : consistent_goal g2), 76 | consistent_goal (Conj g1 g2) 77 | | cgFresh : forall fg (CB_FG : consistent_binding fg) 78 | (CG_BODY : forall n, consistent_goal (fg n)), 79 | consistent_goal (Fresh fg) 80 | | cgInvoke : forall r arg, consistent_goal (Invoke r arg). 81 | 82 | Hint Constructors consistent_goal : core. 83 | 84 | Definition consistent_function (f : term -> goal) : Prop := 85 | forall a1 a2 t, renaming a1 a2 (f t) (f (apply_subst [(a1, Var a2)] t)). 86 | 87 | Definition consistent_rel (r : rel) : Prop := 88 | forall (arg : term), consistent_goal (r arg) /\ consistent_function r. 89 | 90 | 91 | 92 | Definition closed_goal_in_context (c : list name) (g : goal) : Prop := 93 | forall n, is_fv_of_goal n g -> In n c. 94 | 95 | Definition closed_rel (r : rel) : Prop := 96 | forall (arg : term), closed_goal_in_context (fv_term arg) (r arg). 97 | 98 | 99 | 100 | Definition def : Set := {r : rel | closed_rel r /\ consistent_rel r}. 101 | 102 | Definition spec : Set := name -> def. 103 | 104 | Axiom Prog : spec. 105 | --------------------------------------------------------------------------------