--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Unification/Substs.thy	Sun Apr 29 11:29:56 2012 +0100
@@ -0,0 +1,363 @@
+
+
+theory Substs = Main + Terms + PreEqu + Equ:
+
+(* substitutions *)
+
+types substs = "(string \<times> trm)list"
+
+consts 
+  look_up :: "string \<Rightarrow> substs \<Rightarrow> trm"
+primrec 
+  "look_up X []     = Susp [] X"
+  "look_up X (x#xs) = (if (X = fst x) then (snd x) else look_up X xs)"
+
+consts 
+  subst :: "substs \<Rightarrow> trm \<Rightarrow> trm"
+primrec
+  subst_unit: "subst s (Unit)          = Unit"
+  subst_susp: "subst s (Susp pi X)     = swap pi (look_up X s)"
+  subst_atom: "subst s (Atom a)        = Atom a" 
+  subst_abst: "subst s (Abst a t)      = Abst a (subst s t)"
+  subst_paar: "subst s (Paar t1 t2)    = Paar (subst s t1) (subst s t2)"
+  subst_func: "subst s (Func F t)      = Func F (subst s t)"
+
+declare subst_susp [simp del]
+
+(* composition of substitutions (adapted from Martin Coen) *)
+
+consts
+  alist_rec :: "substs \<Rightarrow> substs \<Rightarrow> (string\<Rightarrow>trm\<Rightarrow>substs\<Rightarrow>substs\<Rightarrow>substs) \<Rightarrow> substs"
+
+primrec
+  "alist_rec [] c d = c"
+  "alist_rec (p#al) c d = d (fst p) (snd p) al (alist_rec al c d)"
+
+consts 
+  "\<bullet>"   ::  "substs \<Rightarrow> substs \<Rightarrow> substs" (infixl 81)
+defs
+  comp_def: "s1 \<bullet> s2 \<equiv> alist_rec s2 s1 (\<lambda> x y xs g. (x,subst s1 y)#g)"
+
+(* domain of substitutions *)
+
+consts  
+  domn :: "(trm \<Rightarrow> trm) \<Rightarrow> string set"
+defs 
+  domn_def: "domn s \<equiv> {X. (s (Susp [] X)) \<noteq> (Susp [] X)}" 
+
+(* substitutions extending freshness environments *)
+
+consts 
+  ext_subst :: "fresh_envs \<Rightarrow> (trm \<Rightarrow> trm) \<Rightarrow> fresh_envs \<Rightarrow> bool" (" _ \<Turnstile> _ _ " [80,80,80] 80)
+defs 
+  ext_subst_def: "nabla1 \<Turnstile> s (nabla2) \<equiv> (\<forall>(a,X)\<in>nabla2. nabla1\<turnstile>a\<sharp> s (Susp [] X))"
+
+(* alpah-equality for substitutions *)
+
+consts 
+  subst_equ :: "fresh_envs \<Rightarrow> (trm\<Rightarrow>trm) \<Rightarrow> (trm\<Rightarrow>trm) \<Rightarrow> bool" (" _ \<Turnstile> _ \<approx> _" [80,80,80] 80)
+
+defs 
+  subst_equ_def: 
+  "nabla\<Turnstile> s1 \<approx> s2 \<equiv>  \<forall>X\<in>(domn s1\<union>domn s2). (nabla \<turnstile> s1 (Susp [] X) \<approx> s2 (Susp [] X))"
+
+lemma not_in_domn: "X\<notin>(domn s)\<Longrightarrow> (s (Susp [] X)) = (Susp [] X)"
+apply(auto simp only: domn_def)
+done
+
+lemma subst_swap_comm: "subst s (swap pi t) = swap pi (subst s t)"
+apply(induct_tac t)
+apply(auto simp add: swap_append subst_susp)
+done
+
+lemma subst_not_occurs: "\<not>(occurs X t) \<longrightarrow> subst [(X,t2)] t = t"
+apply(induct t)
+apply(auto simp add: subst_susp)
+done
+
+lemma [simp]: "subst [] t = t"
+apply(induct_tac t, auto simp add: subst_susp)
+done
+
+lemma [simp]: "subst (s\<bullet>[]) = subst s"
+apply(auto simp add: comp_def)
+done
+
+lemma [simp]: "subst ([]\<bullet>s) = subst s"
+apply(rule ext)
+apply(induct_tac x)
+apply(auto)
+apply(induct_tac s rule: alist_rec.induct)
+apply(auto simp add: comp_def subst_susp)
+done
+
+lemma subst_comp_expand: "subst (s1\<bullet>s2) t = subst s1 (subst s2 t)"
+apply(induct_tac t)
+apply(auto)
+apply(induct_tac s2 rule: alist_rec.induct)
+apply(auto simp add: comp_def subst_susp subst_swap_comm)
+done
+
+lemma subst_assoc: "subst (s1\<bullet>(s2\<bullet>s3))=subst ((s1\<bullet>s2)\<bullet>s3)"
+apply(rule ext)
+apply(induct_tac x)
+apply(auto)
+apply(simp add: subst_comp_expand)
+done
+
+lemma fresh_subst: "nabla1\<turnstile>a\<sharp>t\<Longrightarrow> nabla2\<Turnstile>(subst s) nabla1 \<longrightarrow> nabla2\<turnstile>a\<sharp>subst s t"
+apply(erule fresh.induct)
+apply(auto)
+--Susp
+apply(simp add: ext_subst_def subst_susp)
+apply(drule_tac x="(swapas (rev pi) a, X)" in bspec)
+apply(assumption)
+apply(simp)
+apply(rule fresh_swap_right[THEN mp])
+apply(assumption)
+done
+
+lemma equ_subst: "nabla1\<turnstile>t1\<approx>t2\<Longrightarrow> nabla2\<Turnstile> (subst s) nabla1 \<longrightarrow> nabla2\<turnstile>(subst s t1)\<approx>(subst s t2)"
+apply(erule equ.induct)
+apply(auto)
+apply(rule_tac "nabla1.1"="nabla" in fresh_subst[THEN mp])
+apply(assumption)+
+apply(simp add: subst_swap_comm)
+-- Susp
+apply(simp only: subst_susp)
+apply(rule equ_pi1_pi2_add[THEN mp])
+apply(simp only: ext_subst_def subst_susp)
+apply(force)
+done
+
+lemma unif_1: 
+  "\<lbrakk>nabla\<turnstile>subst s (Susp pi X)\<approx>subst s t\<rbrakk>\<Longrightarrow> nabla\<Turnstile> subst (s\<bullet>[(X,swap (rev pi) t)])\<approx>subst s"
+apply(simp only: subst_equ_def)
+apply(case_tac "pi=[]")
+apply(simp add: subst_susp comp_def)
+apply(force intro: equ_sym equ_refl)
+apply(subgoal_tac "domn (subst (s\<bullet>[(X,swap (rev pi) t)]))=domn(subst s)\<union>{X}")--A
+apply(simp)
+apply(rule conjI)
+apply(simp add: subst_comp_expand)
+apply(simp add: subst_susp)
+apply(simp only: subst_swap_comm)
+apply(simp only: equ_pi_to_left)
+apply(rule equ_sym)
+apply(assumption)
+apply(rule ballI)
+apply(simp only: subst_comp_expand)
+apply(simp add: subst_susp)
+apply(force intro: equ_sym equ_refl simp add: subst_swap_comm equ_pi_to_left)
+--A
+apply(simp only: domn_def)
+apply(auto)
+apply(simp add: subst_comp_expand)
+apply(simp add: subst_susp subst_swap_comm)
+apply(simp only: subst_comp_expand)
+apply(simp add: subst_susp subst_swap_comm)
+apply(drule swap_empty[THEN mp])
+apply(simp)
+apply(simp only: subst_comp_expand)
+apply(simp only: subst_susp)
+apply(auto)
+apply(case_tac "x=X")
+apply(simp)
+apply(simp add: subst_swap_comm)
+apply(drule swap_empty[THEN mp])
+apply(simp)
+apply(simp add: subst_susp)
+done
+
+lemma subst_equ_a:
+"\<lbrakk>nabla\<Turnstile>(subst s1) \<approx> (subst s2)\<rbrakk>\<Longrightarrow> \<forall>t2. nabla\<turnstile>(subst s2 t1)\<approx>t2 \<longrightarrow> nabla\<turnstile>(subst s1 t1)\<approx>t2"
+apply(rule allI)
+apply(induct t1)
+--Abst.ab
+apply(rule impI)
+apply(simp)
+apply(ind_cases "nabla \<turnstile> Abst list (subst s1 trm) \<approx> t2")
+apply(best)
+--Abst.aa
+apply(force)
+--Susp
+apply(rule impI)
+apply(simp only: subst_equ_def)
+apply(case_tac "list2\<in>domn (subst s1) \<union> domn (subst s2)")
+apply(drule_tac x="list2" in bspec)
+apply(assumption)
+apply(simp)
+apply(subgoal_tac "nabla \<turnstile> subst s2 (Susp [] list2) \<approx> swap (rev list1) t2")--A
+apply(drule_tac "t1.0"="subst s1 (Susp [] list2)" and
+                "t2.0"="subst s2 (Susp [] list2)" and 
+                "t3.0"="swap (rev list1) t2" in equ_trans)
+apply(assumption)
+apply(simp only: equ_pi_to_right)
+apply(simp add: subst_swap_comm[THEN sym])
+--A
+apply(simp only: equ_pi_to_right)
+apply(simp add: subst_swap_comm[THEN sym])
+apply(simp)
+apply(erule conjE)
+apply(drule not_in_domn)+
+apply(subgoal_tac "subst s1 (Susp list1 list2)=swap list1 (subst s1 (Susp [] list2))")--B
+apply(subgoal_tac "subst s2 (Susp list1 list2)=swap list1 (subst s2 (Susp [] list2))")--C
+apply(simp)
+--BC
+apply(simp (no_asm) add: subst_swap_comm[THEN sym])
+apply(simp (no_asm) add: subst_swap_comm[THEN sym])
+--Unit
+apply(force)
+--Atom
+apply(force)
+--Paar
+apply(rule impI)
+apply(simp)
+apply(ind_cases "nabla \<turnstile> Paar (subst sigma1 trm1) (subst sigma1 trm2) \<approx> t2")
+apply(best)
+--Func
+apply(rule impI)
+apply(simp)
+apply(ind_cases "nabla \<turnstile> Func list (subst sigma1 trm) \<approx> t2")
+apply(best)
+done
+
+lemma unif_2a: "\<lbrakk>nabla\<Turnstile>subst s1\<approx>subst s2\<rbrakk>\<Longrightarrow> 
+                (nabla\<turnstile>subst s2 t1 \<approx> subst s2 t2)\<longrightarrow>(nabla\<turnstile>subst s1 t1 \<approx> subst s1 t2)"
+apply(rule impI)
+apply(frule_tac "t1.0"="t1" in subst_equ_a)
+apply(drule_tac x="subst s2 t2" in spec)
+apply(simp)
+apply(drule equ_sym)
+apply(drule equ_sym) 
+apply(frule_tac "t1.0"="t2" in subst_equ_a)
+apply(drule_tac x="subst s1 t1" in spec)
+apply(rule equ_sym)
+apply(simp)
+done
+
+
+lemma unif_2b: "\<lbrakk>nabla\<Turnstile>subst s1\<approx> subst s2\<rbrakk>\<Longrightarrow>nabla\<turnstile>a\<sharp> subst s2 t\<longrightarrow>nabla\<turnstile>a\<sharp>subst s1 t"
+apply(induct t)
+--Abst
+apply(simp)
+apply(rule impI)
+apply(case_tac "a=list")
+apply(force)
+apply(force dest!: fresh_abst_ab_elim)
+--Susp
+apply(rule impI)
+apply(subgoal_tac "subst s1 (Susp list1 list2)= swap list1 (subst s1 (Susp [] list2))")--A
+apply(subgoal_tac "subst s2 (Susp list1 list2)= swap list1 (subst s2 (Susp [] list2))")--B
+apply(simp add: subst_equ_def)
+apply(case_tac "list2\<in>domn (subst s1) \<union> domn (subst s2)")
+apply(drule_tac x="list2" in bspec)
+apply(assumption)
+apply(rule fresh_swap_right[THEN mp])
+apply(rule_tac "t1.1"=" subst s2 (Susp [] list2)" in l3_jud[THEN mp])
+apply(rule equ_sym)
+apply(simp)
+apply(rule fresh_swap_left[THEN mp])
+apply(simp)
+apply(simp)
+apply(erule conjE)
+apply(drule not_in_domn)+
+apply(simp add: subst_swap_comm)
+--AB
+apply(simp (no_asm) add: subst_swap_comm[THEN sym])
+apply(simp (no_asm) add: subst_swap_comm[THEN sym])
+--Unit
+apply(force)
+--Atom
+apply(force)
+--Paar
+apply(force dest!: fresh_paar_elim)
+--Func
+apply(force dest!:  fresh_func_elim)
+done
+
+lemma subst_equ_to_trm: "nabla\<Turnstile>subst s1 \<approx> subst s2\<Longrightarrow> nabla\<turnstile>subst s1 t\<approx>subst s2 t"
+apply(induct_tac t)
+apply(auto simp add: subst_equ_def)
+apply(case_tac "list2\<in>domn (subst s1) \<union> domn (subst s2)")
+apply(simp only: subst_susp)
+apply(simp only: equ_pi_to_left[THEN sym])
+apply(simp only: equ_involutive_left)
+apply(simp)
+apply(erule conjE)
+apply(drule not_in_domn)+
+apply(subgoal_tac "subst s1 (Susp list1 list2)=swap list1 (subst s1 (Susp [] list2))")--A
+apply(subgoal_tac "subst s2 (Susp list1 list2)=swap list1 (subst s2 (Susp [] list2))")--B
+apply(simp)
+apply(rule equ_refl)
+apply(simp (no_asm_use) add: subst_swap_comm[THEN sym])+
+done
+
+lemma subst_cancel_right: "\<lbrakk>nabla\<Turnstile>(subst s1)\<approx>(subst s2)\<rbrakk>\<Longrightarrow>nabla\<Turnstile>(subst (s1\<bullet>s))\<approx>(subst (s2\<bullet>s))" 
+apply(simp (no_asm) only: subst_equ_def)
+apply(rule ballI)
+apply(simp only: subst_comp_expand)
+apply(rule subst_equ_to_trm)
+apply(assumption)
+done
+
+lemma subst_trans: "\<lbrakk>nabla\<Turnstile>subst s1\<approx>subst s2; nabla\<Turnstile>subst s2\<approx>subst s3\<rbrakk>\<Longrightarrow>nabla\<Turnstile>subst s1\<approx>subst s3"
+apply(simp add: subst_equ_def)
+apply(auto)
+apply(case_tac "X \<in>domn (subst s2)")
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(rule_tac "t2.0"="subst s2 (Susp [] X)" in equ_trans)
+apply(assumption)+
+apply(case_tac "X \<in>domn (subst s3)")
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(rule_tac "t2.0"="subst s2 (Susp [] X)" in equ_trans)
+apply(assumption)+
+apply(drule not_in_domn)+
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(simp)
+apply(case_tac "X \<in>domn (subst s1)")
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(rule_tac "t2.0"="subst s2 (Susp [] X)" in equ_trans)
+apply(assumption)+
+apply(case_tac "X \<in>domn (subst s2)")
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(rule_tac "t2.0"="subst s2 (Susp [] X)" in equ_trans)
+apply(assumption)+
+apply(drule not_in_domn)+
+apply(simp)
+apply(rotate_tac 1)
+apply(drule_tac x="X" in bspec)
+apply(force)
+apply(simp)
+done
+
+(* if occurs holds, then one subterm is equal to (subst s (Susp pi X)) *)
+
+lemma occurs_sub_trm_equ: 
+  "occurs X t1 \<longrightarrow> (\<exists>t2\<in>sub_trms (subst s t1). (\<exists>pi.(nabla\<turnstile>subst s (Susp pi1 X)\<approx>(swap pi t2))))" 
+apply(induct_tac t1)
+apply(auto)
+apply(simp only: subst_susp)
+apply(rule_tac x="swap list1 (look_up X s)" in bexI)
+apply(rule_tac x="pi1@(rev list1)" in exI)
+apply(simp add: swap_append)
+apply(simp add: equ_pi_to_left[THEN sym])
+apply(simp only: equ_involutive_left)
+apply(rule equ_refl)
+apply(rule t_sub_trms_t)
+done
+
+end