theory ClosureConversion
  imports Closure "../04Stack/Stack" "../03Debruijn/Multisubst"
begin

primrec declosure :: "closure \<Rightarrow> dexpr" where
  "declosure (CConst k) = DConst k"
| "declosure (CLam t cs e) = multisubst (map declosure cs) (DLam t e)"

fun declosure_stack :: "cframe list \<Rightarrow> frame list" where
  "declosure_stack [] = []"
| "declosure_stack (CApp1 cs e # s) = FApp1 (multisubst (map declosure cs) e) # declosure_stack s"
| "declosure_stack (CApp2 c # s) = FApp2 (declosure c) # declosure_stack s"
| "declosure_stack (CReturn cs # s) = FReturn # declosure_stack s"

primrec declosure_state :: "closure_state \<Rightarrow> stack_state" where
  "declosure_state (CSE s cs e) = SS False (declosure_stack s) (multisubst (map declosure cs) e)"
| "declosure_state (CSC s c) = SS True (declosure_stack s) (declosure c)"

lemma [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> [] \<turnstile>\<^sub>d declosure c : t"
  and [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> subst_pairs ts (map declosure cs)"
proof (induction c t and cs ts rule: typecheck_closure_typecheck_closure_list.inducts)
  case (tcc_lam cs ts t\<^sub>1 e t\<^sub>2)
  then obtain e' where "multisubst (map declosure cs) (DLam t\<^sub>1 e) = DLam t\<^sub>1 e' \<and> ([t\<^sub>1] \<turnstile>\<^sub>d e' : t\<^sub>2) \<and>
    (\<forall>e\<^sub>2. ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1) \<longrightarrow> multisubst (insert_at 0 e\<^sub>2 (map declosure cs)) e = substd 0 e\<^sub>2 e')"
      by fastforce
  thus ?case by simp
qed simp_all

lemma [simp]: "s :\<^sub>c t' \<rightarrow> t \<Longrightarrow> declosure_stack s : t' \<rightarrow> t"
proof (induction s t' t rule: typecheck_cstack.induct)
  case (tcc_scons_app1 cs ts e t\<^sub>1 s t\<^sub>2 t)
  hence "subst_pairs ts (map declosure cs)" by simp
  moreover from tcc_scons_app1 have "ts \<turnstile>\<^sub>d e : t\<^sub>1" by simp
  ultimately have "[] \<turnstile>\<^sub>d multisubst (map declosure cs) e : t\<^sub>1" by simp
  with tcc_scons_app1 show ?case by simp
next
  case (tcc_scons_app2 c t\<^sub>1 t\<^sub>2 s t)
  hence "[] \<turnstile>\<^sub>d declosure c : Arrow t\<^sub>1 t\<^sub>2" by simp
  moreover from tcc_scons_app2 have "declosure_stack s : t\<^sub>2 \<rightarrow> t" by simp
  ultimately show ?case by simp
qed simp_all

theorem typesafec [simp]: "\<Sigma> :\<^sub>c t \<Longrightarrow> declosure_state \<Sigma> :\<^sub>s t"
proof (induction \<Sigma> t rule: typecheck_closure_state.induct)
  case (tcc_state_ev s t' t cs ts e)
  hence "subst_pairs ts (map declosure cs)" by simp
  moreover from tcc_state_ev have "ts \<turnstile>\<^sub>d e : t'" by simp
  ultimately have "[] \<turnstile>\<^sub>d multisubst (map declosure cs) e : t'" by simp
  moreover from tcc_state_ev have "declosure_stack s : t' \<rightarrow> t" by simp
  ultimately show ?case by simp
next
  case (tcc_state_ret s t' t c)
  hence "declosure_stack s : t' \<rightarrow> t" by simp
  moreover from tcc_state_ret have "[] \<turnstile>\<^sub>d declosure c : t'" by simp
  ultimately show ?case by simp
qed

lemma multisubst_closure [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> multisubst es (declosure c) = declosure c"
  and [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> v \<in> set (map declosure cs) \<Longrightarrow> multisubst es v = v"
proof (induction c t and cs ts rule: typecheck_closure_typecheck_closure_list.inducts)
  case (tcc_lam cs ts t\<^sub>1 e t\<^sub>2)
  moreover hence "subst_pairs ts (map declosure cs)" by simp
  ultimately obtain e' where E: "multisubst (map declosure cs) (DLam t\<^sub>1 e) = DLam t\<^sub>1 e' \<and>
    ([t\<^sub>1] \<turnstile>\<^sub>d e' : t\<^sub>2) \<and> (\<forall>e\<^sub>2. ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1) \<longrightarrow>
      multisubst (insert_at 0 e\<^sub>2 (map declosure cs)) e = substd 0 e\<^sub>2 e')" by fastforce
  hence "[] \<turnstile>\<^sub>d DLam t\<^sub>1 e' : Arrow t\<^sub>1 t\<^sub>2" by simp
  hence "multisubst es (DLam t\<^sub>1 e') = DLam t\<^sub>1 e'" by simp
  with E show ?case by simp
qed auto

lemma [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> substd 0 e' (declosure c) = declosure c"
proof -
  assume "c :\<^sub>c\<^sub>l t"
  hence "multisubst [e'] (declosure c) = declosure c" by (metis multisubst_closure)
  thus ?thesis by simp
qed

theorem correctc: "\<Sigma> \<leadsto>\<^sub>c \<Sigma>' \<Longrightarrow> \<Sigma> :\<^sub>c t \<Longrightarrow> iter (\<leadsto>\<^sub>s) (declosure_state \<Sigma>) (declosure_state \<Sigma>')"
proof (induction \<Sigma> \<Sigma>' rule: evalc.induct)
  case (evc_var cs x c s)
  then obtain t' ts where "(s :\<^sub>c t' \<rightarrow> t) \<and> (cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> lookup ts x = Some t'" by fastforce
  hence "\<And>v es. v \<in> set (map declosure cs) \<Longrightarrow> multisubst es v = v" by auto
  moreover from evc_var have "lookup (map declosure cs) x = Some (declosure c)" by simp
  ultimately have "multisubst (map declosure cs) (DVar x) = declosure c" by (metis multisubst_var)
  thus ?case by simp
next
  case (evc_lam s cs t e)
  obtain e' where "multisubst (map declosure cs) (DLam t e) = DLam t e'" by fastforce
  hence "SS False (declosure_stack s) (multisubst (map declosure cs) (DLam t e)) \<leadsto>\<^sub>s
    SS True (declosure_stack s) (multisubst (map declosure cs) (DLam t e))" by simp
  hence "iter (\<leadsto>\<^sub>s) (SS False (declosure_stack s) (multisubst (map declosure cs) (DLam t e)))
    (SS True (declosure_stack s) (multisubst (map declosure cs) (DLam t e)))"
      by (metis iter_step iter_refl)
  thus ?case by simp
next
  case (evc_app s cs e\<^sub>1 e\<^sub>2)
  have "SS False (declosure_stack s) (DApp (multisubst (map declosure cs) e\<^sub>1)
    (multisubst (map declosure cs) e\<^sub>2)) \<leadsto>\<^sub>s
      SS False (FApp1 (multisubst (map declosure cs) e\<^sub>2) # declosure_stack s)
        (multisubst (map declosure cs) e\<^sub>1)" by simp
  hence "iter (\<leadsto>\<^sub>s) (SS False (declosure_stack s) (DApp (multisubst (map declosure cs) e\<^sub>1)
    (multisubst (map declosure cs) e\<^sub>2)))
      (SS False (FApp1 (multisubst (map declosure cs) e\<^sub>2) # declosure_stack s)
        (multisubst (map declosure cs) e\<^sub>1))" by (metis iter_step iter_refl)
  thus ?case by simp
next
  case (retc_app1 cs e\<^sub>2 s c\<^sub>1)
  have "SS True (FApp1 (multisubst (map declosure cs) e\<^sub>2) # declosure_stack s) (declosure c\<^sub>1) \<leadsto>\<^sub>s
    SS False (FApp2 (declosure c\<^sub>1) # declosure_stack s) (multisubst (map declosure cs) e\<^sub>2)" by simp
  hence "iter (\<leadsto>\<^sub>s) (SS True (FApp1 (multisubst (map declosure cs) e\<^sub>2) # declosure_stack s)
    (declosure c\<^sub>1))
      (SS False (FApp2 (declosure c\<^sub>1) # declosure_stack s) (multisubst (map declosure cs) e\<^sub>2))"
        by (metis iter_step iter_refl)
  thus ?case by simp
next
  case (retc_app2 t\<^sub>1 cs e\<^sub>1 s c\<^sub>2)
  then obtain ts t\<^sub>2 where T: "(cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e\<^sub>1 : t\<^sub>2) \<and> (s :\<^sub>c t\<^sub>2 \<rightarrow> t) \<and>
    (c\<^sub>2 :\<^sub>c\<^sub>l t\<^sub>1)" by fastforce
  hence "subst_pairs ts (map declosure cs) \<and> insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e\<^sub>1 : t\<^sub>2" by simp
  then obtain e' where "multisubst (map declosure cs) (DLam t\<^sub>1 e\<^sub>1) = DLam t\<^sub>1 e' \<and> ([t\<^sub>1] \<turnstile>\<^sub>d e' : t\<^sub>2) \<and>
    (\<forall>e\<^sub>2. ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1) \<longrightarrow> multisubst (insert_at 0 e\<^sub>2 (map declosure cs)) e\<^sub>1 = substd 0 e\<^sub>2 e')"
      by fastforce
  with T have "multisubst (map declosure cs) (DLam t\<^sub>1 e\<^sub>1) = DLam t\<^sub>1 e' \<and>
    multisubst (insert_at 0 (declosure c\<^sub>2) (map declosure cs)) e\<^sub>1 = substd 0 (declosure c\<^sub>2) e'"
      by simp
  hence "SS True (FApp2 (multisubst (map declosure cs) (DLam t\<^sub>1 e\<^sub>1)) # declosure_stack s)
    (declosure c\<^sub>2) \<leadsto>\<^sub>s (SS False (FReturn # declosure_stack s)
      (multisubst (map declosure cs) (substd 0 (declosure c\<^sub>2) e\<^sub>1)))"
    by (induction cs) simp_all
  hence "iter (\<leadsto>\<^sub>s) (SS True (FApp2 (multisubst (map declosure cs) (DLam t\<^sub>1 e\<^sub>1)) # declosure_stack s)
    (declosure c\<^sub>2))
      (SS False (FReturn # declosure_stack s)
        (multisubst (map declosure cs) (substd 0 (declosure c\<^sub>2) e\<^sub>1)))"
    by (metis iter_step iter_refl)
  thus ?case by simp
next
  case (retc_ret cs s c)
  have "SS True (FReturn # declosure_stack s) (declosure c) \<leadsto>\<^sub>s
    SS True (declosure_stack s) (declosure c)" by simp
  hence "iter (\<leadsto>\<^sub>s) (SS True (FReturn # declosure_stack s) (declosure c))
    (SS True (declosure_stack s) (declosure c))" by (metis iter_step iter_refl)
  thus ?case by simp
qed simp_all

lemma [simp]: "[] = declosure_stack s \<Longrightarrow> s = []"
  by (induction s rule: declosure_stack.induct) simp_all

lemma [simp]: "FApp1 e # s = declosure_stack s\<^sub>c \<Longrightarrow> \<exists>cs e' s\<^sub>c'. s\<^sub>c = CApp1 cs e' # s\<^sub>c' \<and>
    e = multisubst (map declosure cs) e' \<and> s = declosure_stack s\<^sub>c'"
  by (induction s\<^sub>c rule: declosure_stack.induct) simp_all

lemma [simp]: "FApp2 e # s = declosure_stack s\<^sub>c \<Longrightarrow>
    \<exists>c s\<^sub>c'. s\<^sub>c = CApp2 c # s\<^sub>c' \<and> e = declosure c \<and> s = declosure_stack s\<^sub>c'"
  by (induction s\<^sub>c rule: declosure_stack.induct) simp_all

lemma [simp]: "FReturn # s = declosure_stack s\<^sub>c \<Longrightarrow> \<exists>cs s\<^sub>c'. s\<^sub>c = CReturn cs # s\<^sub>c'"
  by (induction s\<^sub>c rule: declosure_stack.induct) simp_all

lemma [dest]: "SS b s e = declosure_state \<Sigma> \<Longrightarrow>
  \<exists>s'. s = declosure_stack s' \<and>
    ((\<exists>cs e'. \<not> b \<and> \<Sigma> = CSE s' cs e' \<and> e = multisubst (map declosure cs) e') \<or>
      (\<exists>c. b \<and> \<Sigma> = CSC s' c \<and> e = declosure c))"
  by (induction \<Sigma>) simp_all

lemma [dest]: "DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) (DLam t e) \<Longrightarrow> False"
proof -
  assume "DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) (DLam t e)"
  moreover obtain e' where "multisubst (map declosure cs) (DLam t e) = DLam t e'" by fastforce
  ultimately show ?thesis by simp
qed

lemma [simp]: "DLam t e = declosure c \<Longrightarrow>
  \<exists>cs e'. c = CLam t cs e' \<and> (\<forall>e\<^sub>2. (\<forall>ee. substd 0 ee e\<^sub>2 = e\<^sub>2) \<longrightarrow>
    substd 0 e\<^sub>2 e = multisubst (map declosure cs) (substd 0 e\<^sub>2 e'))"
proof (induction c)
  case (CLam tt cs e')
  moreover obtain ee' where "multisubst (map declosure cs) (DLam tt e') = DLam tt ee' \<and>
    (\<forall>e\<^sub>2. (\<forall>ee. substd 0 ee e\<^sub>2 = e\<^sub>2) \<longrightarrow>
      substd 0 e\<^sub>2 ee' = multisubst (map declosure cs) (substd 0 e\<^sub>2 e'))" by fastforce
  ultimately show ?case by simp
qed simp_all

lemma [dest]: "DApp e\<^sub>1 e\<^sub>2 = declosure c \<Longrightarrow> False"
  by (induction c) auto

lemma [dest]: "DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) (declosure c) \<Longrightarrow> False"
proof (induction c)
  case (CLam t cs' e)
  moreover obtain e' where "multisubst (map declosure cs') (DLam t e) = DLam t e'" by fastforce
  ultimately show ?case by auto
qed simp_all

lemma [dest]: "DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) (DVar x) \<Longrightarrow> False"
  by (induction cs x rule: lookup.induct) auto

lemma [simp]: "DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) e \<Longrightarrow> \<exists>e\<^sub>1' e\<^sub>2'. e = DApp e\<^sub>1' e\<^sub>2' \<and>
    e\<^sub>1 = multisubst (map declosure cs) e\<^sub>1' \<and> e\<^sub>2 = multisubst (map declosure cs) e\<^sub>2'"
  by (induction e) auto

lemma [dest]: "DConst k = multisubst es (declosure c) \<Longrightarrow> c = CConst k"
proof (induction c)
  case (CLam t cs e)
  moreover obtain e' where "multisubst (map declosure cs) (DLam t e) = DLam t e'" by fastforce
  moreover obtain e'' where "multisubst es (DLam t e') = DLam t e''" by fastforce
  ultimately show ?case by simp
qed simp_all

lemma [dest]: "DConst k = multisubst (map declosure cs) (DVar x) \<Longrightarrow> lookup cs x = Some (CConst k)"
  by (induction cs x rule: lookup.induct) auto

lemma [dest]: "DConst k = multisubst (map declosure cs) e \<Longrightarrow>
    e = DConst k \<or> (\<exists>x. e = DVar x \<and> lookup cs x = Some (CConst k))"
proof (induction e)
  case (DLam t e)
  moreover then obtain e' where "multisubst (map declosure cs) (DLam t e) = DLam t e'" by force
  ultimately show ?case by simp
qed auto

lemma [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> incrd x (declosure c) = declosure c"
  and [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> ts \<turnstile>\<^sub>d e : tt \<Longrightarrow>
    incrd x (multisubst (map declosure cs) e) = multisubst (map declosure cs) e"
proof (induction c t and cs ts arbitrary: and e tt
       rule: typecheck_closure_typecheck_closure_list.inducts)
  case (tcc_lam cs ts t\<^sub>1 e t\<^sub>2)
  moreover hence "ts \<turnstile>\<^sub>d DLam t\<^sub>1 e : Arrow t\<^sub>1 t\<^sub>2" by simp
  ultimately have "incrd x (multisubst (map declosure cs) (DLam t\<^sub>1 e)) =
    multisubst (map declosure cs) (DLam t\<^sub>1 e)" by blast
  thus ?case by simp
next
  case (tcc_cons c t cs ts)
  hence "[] \<turnstile>\<^sub>d declosure c : t" by simp
  hence "ts \<turnstile>\<^sub>d declosure c : t" using tc_postpend by fastforce
  moreover from tcc_cons have "insert_at 0 t ts \<turnstile>\<^sub>d e : tt" by (cases ts) simp_all
  ultimately have "ts \<turnstile>\<^sub>d substd 0 (declosure c) e : tt" by simp
  with tcc_cons show ?case by simp
qed simp_all

lemma [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> True"
  and [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e : t\<^sub>2 \<Longrightarrow>
  multisubst (map declosure cs') (multisubst (map declosure cs) (DLam t\<^sub>1 e)) =
    multisubst (map declosure cs) (DLam t\<^sub>1 e)"
proof (induction c t and cs ts arbitrary: and e
       rule: typecheck_closure_typecheck_closure_list.inducts)
  case tcc_nil
  thus ?case by (induction cs') simp_all
next
  case (tcc_cons c t cs ts)
  hence "[] \<turnstile>\<^sub>d declosure c : t" by simp
  hence "insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d declosure c : t" using tc_postpend by fastforce
  with tcc_cons show ?case by (cases ts) simp_all
qed simp_all

lemma [dest]: "c :\<^sub>c\<^sub>l tt \<Longrightarrow> DLam t e = multisubst (map declosure cs) (declosure c) \<Longrightarrow>
  \<exists>cs' e'. c = CLam t cs' e' \<and>
    multisubst (map declosure cs') (DLam t e') = multisubst (map declosure cd) (declosure c)"
proof (induction c)
  case (CLam t\<^sub>1 cs' e')
  then obtain t\<^sub>2 ts where T: "tt = Arrow t\<^sub>1 t\<^sub>2 \<and> (cs' :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e' : t\<^sub>2)"
    by fastforce
  hence M: "multisubst (map declosure cs') (DLam t\<^sub>1 e') =
      multisubst (map declosure cd) (multisubst (map declosure cs') (DLam t\<^sub>1 e'))" by fastforce
  obtain e2 where E: "multisubst (map declosure cs') (DLam t\<^sub>1 e') = DLam t\<^sub>1 e2" by fastforce
  obtain e3 where "multisubst (map declosure cs) (DLam t\<^sub>1 e2) = DLam t\<^sub>1 e3" by fastforce
  with CLam M E show ?case by simp
qed simp_all

lemma [dest]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> lookup ts x = Some tt \<Longrightarrow>
  DLam t e = multisubst (map declosure cs) (DVar x) \<Longrightarrow>
    \<exists>cs' e'. lookup cs x = Some (CLam t cs' e') \<and>
      multisubst (map declosure cs') (DLam t e') = multisubst (map declosure cs) (DVar x)"
  by (induction cs x arbitrary: ts rule: lookup.induct) fastforce+

lemma [dest]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> ts \<turnstile>\<^sub>d e : t' \<Longrightarrow> DLam t e' = multisubst (map declosure cs) e \<Longrightarrow>
  (\<exists>e''. e = DLam t e'') \<or> (\<exists>x cs' e''. e = DVar x \<and> lookup cs x = Some (CLam t cs' e'') \<and>
    multisubst (map declosure cs') (DLam t e'') = DLam t e')"
proof (induction e)
  case (DLam t e)
  moreover then obtain e' where "multisubst (map declosure cs) (DLam t e) = DLam t e'" by fastforce
  ultimately show ?case by simp
qed auto

lemma [simp]: "lookup cs x = Some c \<Longrightarrow> c :\<^sub>c\<^sub>l t \<Longrightarrow>
    multisubst (map declosure cs) (DVar x) = declosure c"
  by (induction cs x rule: lookup.induct) simp_all

lemma [simp]: "vald (multisubst (map declosure cs) e) \<Longrightarrow> CSE s cs e :\<^sub>c t \<Longrightarrow>
  \<exists>c. CSE s cs e \<leadsto>\<^sub>c CSC s c \<and> multisubst (map declosure cs) e = declosure c"
proof (induction e)
  case (DVar x)
  then obtain t' ts where "(s :\<^sub>c t' \<rightarrow> t) \<and> (cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (lookup ts x = Some t')" by fastforce
  then obtain c where "lookup cs x = Some c \<and> c :\<^sub>c\<^sub>l t'" by fastforce
  hence "CSE s cs (DVar x) \<leadsto>\<^sub>c CSC s c \<and> multisubst (map declosure cs) (DVar x) = declosure c"
    by fastforce
  thus ?case by blast
next
  case (DConst k)
  have "CSE s cs (DConst k) \<leadsto>\<^sub>c CSC s (CConst k) \<and>
    multisubst (map declosure cs) (DConst k) = declosure (CConst k)" by simp
  thus ?case by blast
next
  case (DLam tt e)
  hence "CSE s cs (DLam tt e) \<leadsto>\<^sub>c CSC s (CLam tt cs e) \<and>
    multisubst (map declosure cs) (DLam tt e) = declosure (CLam tt cs e)" by simp
  thus ?case by blast
qed simp_all

theorem completec [simp]: "declosure_state \<Sigma>\<^sub>c \<leadsto>\<^sub>s \<Sigma>\<^sub>s' \<Longrightarrow> \<Sigma>\<^sub>c :\<^sub>c t \<Longrightarrow>
    \<exists>\<Sigma>\<^sub>c'. iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c \<Sigma>\<^sub>c' \<and> \<Sigma>\<^sub>s' = declosure_state \<Sigma>\<^sub>c'"
proof (induction "declosure_state \<Sigma>\<^sub>c" \<Sigma>\<^sub>s' rule: evals.induct)
  case (evs_const s k)
  then obtain s' cs e' where S: "s = declosure_stack s' \<and> \<Sigma>\<^sub>c = CSE s' cs e' \<and>
    DConst k = multisubst (map declosure cs) e'" by fastforce
  thus ?case
  proof (cases "e' = DConst k")
    case True
    have "CSE s' cs (DConst k) \<leadsto>\<^sub>c CSC s' (CConst k)" by simp
    hence "iter (\<leadsto>\<^sub>c) (CSE s' cs (DConst k)) (CSC s' (CConst k))" by (metis iter_refl iter_step)
    with S True show ?thesis by fastforce
  next
    case False
    with S obtain x where E: "e' = DVar x \<and> lookup cs x = Some (CConst k)" by fastforce
    hence "CSE s' cs (DVar x) \<leadsto>\<^sub>c CSC s' (CConst k)" by simp
    hence X: "iter (\<leadsto>\<^sub>c) (CSE s' cs (DVar x)) (CSC s' (CConst k))" by simp
    from S have "SS True s (DConst k) = declosure_state (CSC s' (CConst k))" by simp
    with S E X show ?thesis by blast
  qed
next
  case (evs_lam s tt e)
  then obtain s' cs e' where S: "s = declosure_stack s' \<and> \<Sigma>\<^sub>c = CSE s' cs e' \<and>
    DLam tt e = multisubst (map declosure cs) e'" by fastforce
  with evs_lam obtain t' ts where T: "(s' :\<^sub>c t' \<rightarrow> t) \<and> (cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and>
    latest_environment s' = Some cs \<and> ts \<turnstile>\<^sub>d e' : t'" by fastforce
  thus ?case
  proof (cases "\<exists>e''. e' = DLam tt e''")
    case True
    then obtain e'' where E: "e' = DLam tt e''" by fastforce
    have "CSE s' cs (DLam tt e'') \<leadsto>\<^sub>c CSC s' (CLam tt cs e'')" by simp
    hence "iter (\<leadsto>\<^sub>c) (CSE s' cs (DLam tt e'')) (CSC s' (CLam tt cs e''))"
      by (metis iter_refl iter_step)
    with S E show ?thesis by fastforce
  next
    case False
    with S T obtain x cs' e'' where E: "e' = DVar x \<and> lookup cs x = Some (CLam tt cs' e'') \<and>
      multisubst (map declosure cs') (DLam tt e'') = DLam tt e" by blast
    hence "CSE s' cs (DVar x) \<leadsto>\<^sub>c CSC s' (CLam tt cs' e'')" by simp
    hence X: "iter (\<leadsto>\<^sub>c) (CSE s' cs (DVar x)) (CSC s' (CLam tt cs' e''))" by simp
    from S E have "multisubst (map declosure cs) e' = multisubst (map declosure cs') (DLam tt e'')"
      by metis
    with S have "SS True s (DLam tt e) = declosure_state (CSC s' (CLam tt cs' e''))" by simp
    with S E X show ?thesis by blast
  qed
next
  case (evs_app1 s e\<^sub>1 e\<^sub>2)
  then obtain s' cs e' where S: "s = declosure_stack s' \<and> \<Sigma>\<^sub>c = CSE s' cs e' \<and>
    DApp e\<^sub>1 e\<^sub>2 = multisubst (map declosure cs) e'" by fastforce
  then obtain e\<^sub>1' e\<^sub>2' where E: "e' = DApp e\<^sub>1' e\<^sub>2' \<and>
    e\<^sub>1 = multisubst (map declosure cs) e\<^sub>1' \<and> e\<^sub>2 = multisubst (map declosure cs) e\<^sub>2'" by fastforce
  have "CSE s' cs (DApp e\<^sub>1' e\<^sub>2') \<leadsto>\<^sub>c CSE (CApp1 cs e\<^sub>2' # s') cs e\<^sub>1'" by simp
  hence "iter (\<leadsto>\<^sub>c) (CSE s' cs (DApp e\<^sub>1' e\<^sub>2')) (CSE (CApp1 cs e\<^sub>2' # s') cs e\<^sub>1')"
    by (metis iter_refl iter_step)
  with S E show ?case by fastforce
next
  case (evs_app2 e\<^sub>2 s e\<^sub>1)
  then obtain s\<^sub>c c where S: "FApp1 e\<^sub>2 # s = declosure_stack s\<^sub>c \<and> \<Sigma>\<^sub>c = CSC s\<^sub>c c \<and> e\<^sub>1 = declosure c"
    by fastforce
  then obtain cs' e\<^sub>2' s\<^sub>c' where S': "s\<^sub>c = CApp1 cs' e\<^sub>2' # s\<^sub>c' \<and>
    e\<^sub>2 = multisubst (map declosure cs') e\<^sub>2' \<and> s = declosure_stack s\<^sub>c'" by fastforce
  have "CSC (CApp1 cs' e\<^sub>2' # s\<^sub>c') c \<leadsto>\<^sub>c CSE (CApp2 c # s\<^sub>c') cs' e\<^sub>2'" by simp
  hence "iter (\<leadsto>\<^sub>c) (CSC (CApp1 cs' e\<^sub>2' # s\<^sub>c') c) (CSE (CApp2 c # s\<^sub>c') cs' e\<^sub>2')"
    by (metis iter_refl iter_step)
  with S S' show ?case by fastforce
next
  case (evs_app3 t\<^sub>1 e\<^sub>1 s e\<^sub>2)
  then obtain s\<^sub>c c\<^sub>2 where S: "FApp2 (DLam t\<^sub>1 e\<^sub>1) # s = declosure_stack s\<^sub>c \<and> \<Sigma>\<^sub>c = CSC s\<^sub>c c\<^sub>2 \<and>
    e\<^sub>2 = declosure c\<^sub>2" by fastforce
  then obtain c s\<^sub>c' where S': "s\<^sub>c = CApp2 c # s\<^sub>c' \<and> DLam t\<^sub>1 e\<^sub>1 = declosure c \<and>
    s = declosure_stack s\<^sub>c'" by fastforce
  then obtain cs' e\<^sub>1' where C: "c = CLam t\<^sub>1 cs' e\<^sub>1' \<and> (\<forall>e\<^sub>2. (\<forall>ee. substd 0 ee e\<^sub>2 = e\<^sub>2) \<longrightarrow>
    substd 0 e\<^sub>2 e\<^sub>1 = multisubst (map declosure cs') (substd 0 e\<^sub>2 e\<^sub>1'))" by fastforce
  have X: "CSC (CApp2 (CLam t\<^sub>1 cs' e\<^sub>1') # s\<^sub>c') c\<^sub>2 \<leadsto>\<^sub>c CSE (CReturn (c\<^sub>2 # cs') # s\<^sub>c') (c\<^sub>2 # cs') e\<^sub>1'"
    by simp
  with evs_app3 S S' C have "CSE (CReturn (c\<^sub>2 # cs') # s\<^sub>c') (c\<^sub>2 # cs') e\<^sub>1' :\<^sub>c t"
    by (metis preservationc)
  then obtain t' ts where "(s\<^sub>c' :\<^sub>c t' \<rightarrow> t) \<and> (c\<^sub>2 # cs' :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (ts \<turnstile>\<^sub>d e\<^sub>1' : t')" by fastforce
  with S have "\<forall>ee. substd 0 ee e\<^sub>2 = e\<^sub>2" by fastforce
  with S S' C have "SS False (FReturn # s) (substd 0 e\<^sub>2 e\<^sub>1) =
    declosure_state (CSE (CReturn (c\<^sub>2 # cs') # s\<^sub>c') (c\<^sub>2 # cs') e\<^sub>1')" by simp
  with S S' C X show ?case by (metis iter_step iter_refl)
next
  case (evs_ret s e)
  then obtain s\<^sub>c c where S: "FReturn # s = declosure_stack s\<^sub>c \<and> \<Sigma>\<^sub>c = CSC s\<^sub>c c \<and> e = declosure c"
    by fastforce
  then obtain cs s\<^sub>c' where S': "s\<^sub>c = CReturn cs # s\<^sub>c'" by fastforce
  have "CSC (CReturn cs # s\<^sub>c') c \<leadsto>\<^sub>c CSC s\<^sub>c' c" by simp
  hence "iter (\<leadsto>\<^sub>c) (CSC (CReturn cs # s\<^sub>c') c) (CSC s\<^sub>c' c)" by (metis iter_refl iter_step)
  with S S' show ?case by fastforce
qed

lemma [simp]: "iter (\<leadsto>\<^sub>s) (declosure_state \<Sigma>\<^sub>c) \<Sigma>\<^sub>s' \<Longrightarrow> \<Sigma>\<^sub>c :\<^sub>c t \<Longrightarrow>
  \<exists>\<Sigma>\<^sub>c'. iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c \<Sigma>\<^sub>c' \<and> \<Sigma>\<^sub>s' = declosure_state \<Sigma>\<^sub>c'"
proof (induction "declosure_state \<Sigma>\<^sub>c" \<Sigma>\<^sub>s' arbitrary: \<Sigma>\<^sub>c rule: iter.induct)
  case (iter_step \<Sigma>\<^sub>s' \<Sigma>\<^sub>s'')
  moreover then obtain \<Sigma>\<^sub>c' where X: "iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c \<Sigma>\<^sub>c' \<and> \<Sigma>\<^sub>s' = declosure_state \<Sigma>\<^sub>c'" by fastforce
  moreover with iter_step have "\<Sigma>\<^sub>c' :\<^sub>c t" by fastforce
  ultimately obtain \<Sigma>\<^sub>c'' where "iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c' \<Sigma>\<^sub>c'' \<and> \<Sigma>\<^sub>s'' = declosure_state \<Sigma>\<^sub>c''" by fastforce
  with X have "iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c \<Sigma>\<^sub>c'' \<and> \<Sigma>\<^sub>s'' = declosure_state \<Sigma>\<^sub>c''" by (metis iter_append)
  thus ?case by fastforce
qed force+

lemma [simp]: "vald (multisubst (map declosure cs) e) \<Longrightarrow> \<exists>c. CSE s cs e \<leadsto>\<^sub>c CSC s c"
proof (induction e)
  case (DVar x)
  then obtain c where "lookup cs x = Some c" by (induction cs x rule: lookup.induct) simp_all
  hence "CSE s cs (DVar x) \<leadsto>\<^sub>c CSC s c" by simp
  thus ?case by fastforce
next
  case (DConst k)
  have "CSE s cs (DConst k) \<leadsto>\<^sub>c CSC s (CConst k)" by simp
  thus ?case by fastforce
next
  case (DLam t e)
  have "CSE s cs (DLam t e) \<leadsto>\<^sub>c CSC s (CLam t cs e)" by simp
  thus ?case by fastforce
qed simp_all

lemma [simp]: "\<Sigma>\<^sub>c :\<^sub>c t \<Longrightarrow> iter (\<leadsto>\<^sub>s) (declosure_state \<Sigma>\<^sub>c) (SS True [] v) \<Longrightarrow>
  vald v \<Longrightarrow> \<exists>c. iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c (CSC [] c) \<and> declosure c = v"
proof -
  assume VD: "vald v" and TC: "\<Sigma>\<^sub>c :\<^sub>c t" and "iter (\<leadsto>\<^sub>s) (declosure_state \<Sigma>\<^sub>c) (SS True [] v)"
  then obtain \<Sigma>\<^sub>c' where E: "iter (\<leadsto>\<^sub>c) \<Sigma>\<^sub>c \<Sigma>\<^sub>c' \<and> SS True [] v = declosure_state \<Sigma>\<^sub>c'" by fastforce
  then obtain s' c where "[] = declosure_stack s' \<and> \<Sigma>\<^sub>c' = CSC s' c \<and> v = declosure c" by fastforce
  moreover hence "s' = []" by simp
  ultimately have S: "(\<exists>cs e. \<Sigma>\<^sub>c' = CSE [] cs e \<and> v = multisubst (map declosure cs) e) \<or>
    (\<exists>c. \<Sigma>\<^sub>c' = CSC [] c \<and> v = declosure c)" by simp
  with E show ?thesis by fastforce
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Transport For Functions\<close>
theory Transport_Functions
  imports
    Transport_Functions_Galois_Equivalence
    Transport_Functions_Galois_Relator
    Transport_Functions_Order_Base
    Transport_Functions_Order_Equivalence
    Transport_Functions_Relation_Simplifications
begin

paragraph \<open>Summary\<close>
text \<open>Composition under (dependent) (monotone) function relators.
See the Transport paper for more details.\<close>

subsubsection \<open>Summary of Main Results\<close>

text \<open>More precise results can be found in the corresponding subtheories.\<close>

paragraph \<open>Monotone Dependent Function Relator\<close>

context transport_Mono_Dep_Fun_Rel
begin

interpretation flip : transport_Mono_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2
  rewrites "flip.t1.counit \<equiv> \<eta>\<^sub>1" and "flip.t1.unit \<equiv> \<epsilon>\<^sub>1"
  by (simp_all only: t1.flip_counit_eq_unit t1.flip_unit_eq_counit)

subparagraph \<open>Closure of Order and Galois Concepts\<close>

theorem preorder_galois_connection_if_galois_connectionI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<stileturn> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([_ x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | (x2 \<le>\<^bsub>L1\<^esub> x3 \<and> x4 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x3)] \<Rrightarrow> (\<ge>)) L2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | \<epsilon>\<^sub>1 x2' \<le>\<^bsub>R1\<^esub> x1'] \<Rrightarrow>\<^sub>m [x3' _ \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) l2"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)) r2"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_galois_connectionI
    galois_connection_left_right_if_mono_if_galois_connectionI'
    preorder_on_in_field_leftI flip.preorder_on_in_field_leftI
    tdfr.transitive_leftI' flip.tdfr.transitive_leftI
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_leftI
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_rightI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on
      in_field_if_in_dom in_field_if_in_codom)

theorem preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([x1 _ \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 _ \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "([x1' _ \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' _ \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) l2"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)) r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_equivalence_if_galois_equivalenceI
    galois_equivalence_if_mono_if_preorder_equivalenceI'
    preorder_on_in_field_leftI flip.preorder_on_in_field_leftI
    tdfr.transitive_leftI' flip.tdfr.transitive_leftI
    tdfr.transitive_left2_if_preorder_equivalenceI
    tdfr.transitive_right2_if_preorder_equivalenceI
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_leftI
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_rightI
    tdfr.galois_equivalence_if_mono_if_galois_equivalence_mono_assms_leftI
    flip.tdfr.galois_equivalence_if_mono_if_galois_equivalence_mono_assms_leftI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on
    in_field_if_in_dom in_field_if_in_codom)

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([x1 _ \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 _ \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "([x1' _ \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' _ \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) l2"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)) r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro partial_equivalence_rel_equivalence_if_galois_equivalenceI
    galois_equivalence_if_mono_if_preorder_equivalenceI'
    tdfr.transitive_left2_if_preorder_equivalenceI
    tdfr.transitive_right2_if_preorder_equivalenceI
    partial_equivalence_rel_leftI flip.partial_equivalence_rel_leftI
    tdfr.partial_equivalence_rel_left2_if_partial_equivalence_rel_equivalenceI
    tdfr.partial_equivalence_rel_right2_if_partial_equivalence_rel_equivalenceI)
  auto

subparagraph \<open>Simplification of Left and Right Relations\<close>

text \<open>See @{thm "left_rel_eq_tdfr_leftI_if_equivalencesI"}.\<close>

subparagraph \<open>Simplification of Galois relator\<close>

text \<open>See
@{thm "Galois_eq_Dep_Fun_Rel_Galois_restrict_if_mono_if_galois_connectionI"
"Galois_eq_Dep_Fun_Rel_Galois_restrict_if_preorder_equivalenceI"
"Dep_Fun_Rel_Galois_restrict_left_right_eq_Dep_Fun_Rel_GaloisI"
"Dep_Fun_Rel_Galois_restrict_left_right_restrict_left_right_eq"}\<close>

end

paragraph \<open>Monotone Function Relator\<close>

context transport_Mono_Fun_Rel
begin

interpretation flip : transport_Mono_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

subparagraph \<open>Closure of Order and Galois Concepts\<close>

lemma preorder_galois_connection_if_galois_connectionI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)" "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<stileturn> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)" "transitive (\<le>\<^bsub>R2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro tpdfr.preorder_galois_connectionI
    galois_connection_left_rightI
    tpdfr.preorder_on_in_field_leftI flip.tpdfr.preorder_on_in_field_leftI
    tfr.transitive_leftI' flip.tfr.transitive_leftI)
  auto

theorem preorder_galois_connectionI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_galois_connection_if_galois_connectionI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on
    in_field_if_in_dom in_field_if_in_codom)

theorem preorder_equivalence_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)" "reflexive_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)" "transitive (\<le>\<^bsub>R2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro tpdfr.preorder_equivalence_if_galois_equivalenceI
    galois_equivalenceI
    tpdfr.preorder_on_in_field_leftI flip.tpdfr.preorder_on_in_field_leftI
    tfr.transitive_leftI flip.tfr.transitive_leftI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_dom)

theorem preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_equivalence_if_galois_equivalenceI) auto

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro tpdfr.partial_equivalence_rel_equivalence_if_galois_equivalenceI
    galois_equivalenceI
    partial_equivalence_rel_leftI flip.partial_equivalence_rel_leftI)
  auto

subparagraph \<open>Simplification of Left and Right Relations\<close>

text \<open>See @{thm "left_rel_eq_tfr_leftI"}.\<close>

subparagraph \<open>Simplification of Galois relator\<close>

text \<open>See @{thm "Galois_eq_Fun_Rel_Galois_restrictI"
"Fun_Rel_Galois_restrict_left_right_eq_Fun_Rel_GaloisI"
"Fun_Rel_Galois_restrict_left_right_restrict_left_right_eq"}.\<close>

end

paragraph \<open>Dependent Function Relator\<close>

text \<open>While a general transport of functions is only possible for the monotone
function relator (see above), the locales @{locale "transport_Dep_Fun_Rel"} and
@{locale "transport_Fun_Rel"} contain special cases to transport functions
that are proven to be monotone using the standard function space.

Moreover, in the special case of equivalences on partial equivalence relations,
the standard function space is monotone - see
@{thm "transport_Mono_Dep_Fun_Rel.left_rel_eq_tdfr_leftI_if_equivalencesI"}
As such, we can derive general transport theorems from the monotone cases
above.\<close>

context transport_Dep_Fun_Rel
begin

interpretation tpdfr : transport_Mono_Dep_Fun_Rel L1 R1 l1 r1 L2 R2 l2 r2 .
interpretation flip : transport_Mono_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "([x1' x2' \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) l2"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)) r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  from assms have "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) = (tpdfr.L \<equiv>\<^bsub>PER\<^esub> tpdfr.R)"
    by (subst tpdfr.left_rel_eq_tdfr_leftI_if_equivalencesI
        flip.left_rel_eq_tdfr_leftI_if_equivalencesI,
      auto intro!: partial_equivalence_rel_left2_if_partial_equivalence_rel_equivalenceI
        partial_equivalence_rel_right2_if_partial_equivalence_rel_equivalenceI
      iff: t1.galois_equivalence_right_left_iff_galois_equivalence_left_right)+
  with assms show ?thesis
    by (auto intro!: tpdfr.partial_equivalence_rel_equivalenceI)
qed

end

paragraph \<open>Function Relator\<close>

context transport_Fun_Rel
begin

interpretation tpfr : transport_Mono_Fun_Rel L1 R1 l1 r1 L2 R2 l2 r2 .
interpretation flip_tpfr : transport_Mono_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  from assms have "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) = (tpfr.tpdfr.L \<equiv>\<^bsub>PER\<^esub> tpfr.tpdfr.R)"
    by (subst tpfr.left_rel_eq_tfr_leftI flip_tpfr.left_rel_eq_tfr_leftI; auto)+
  with assms show ?thesis by (auto intro!: tpfr.partial_equivalence_rel_equivalenceI)
qed

end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Basic Setup\<close>
theory Transport_Compositions_Agree_Base
  imports
    HOL_Basics.Galois_Relator
    Transport_Base
begin

locale transport_comp_agree =
  g1 : galois L1 R1 l1 r1 + g2 : galois L2 R2 l2 r2
  for L1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R1 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l1 :: "'a \<Rightarrow> 'b"
  and r1 :: "'b \<Rightarrow> 'a"
  and L2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and R2 :: "'c \<Rightarrow> 'c \<Rightarrow> bool"
  and l2 :: "'b \<Rightarrow> 'c"
  and r2 :: "'c \<Rightarrow> 'b"
begin

text \<open>This locale collects results about the composition of transportable
components under the assumption that the relations @{term "R1"} and
@{term "L2"} agree (in one sense or another) whenever required. Such an
agreement may not necessarily hold in practice, and the resulting theorems are
not particularly pretty. However, in the special case where @{term "R1 = L2"},
most side-conditions disappear and the results are very simple.\<close>

notation L1 (infix "\<le>\<^bsub>L1\<^esub>" 50)
notation R1 (infix "\<le>\<^bsub>R1\<^esub>" 50)
notation L2 (infix "\<le>\<^bsub>L2\<^esub>" 50)
notation R2 (infix "\<le>\<^bsub>R2\<^esub>" 50)

notation g1.ge_left (infix "\<ge>\<^bsub>L1\<^esub>" 50)
notation g1.ge_right (infix "\<ge>\<^bsub>R1\<^esub>" 50)
notation g2.ge_left (infix "\<ge>\<^bsub>L2\<^esub>" 50)
notation g2.ge_right (infix "\<ge>\<^bsub>R2\<^esub>" 50)

notation g1.Galois (infix "\<^bsub>L1\<^esub>\<lessapprox>" 50)
notation g1.flip_Galois (infix "\<^bsub>R1\<^esub>\<lessapprox>" 50)
notation g2.Galois (infix "\<^bsub>L2\<^esub>\<lessapprox>" 50)
notation g2.flip_Galois (infix "\<^bsub>R2\<^esub>\<lessapprox>" 50)

notation g1.ge_Galois (infix "\<greaterapprox>\<^bsub>L1\<^esub>" 50)
notation g1.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R1\<^esub>" 50)
notation g2.ge_Galois (infix "\<greaterapprox>\<^bsub>L2\<^esub>" 50)
notation g2.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R2\<^esub>" 50)

notation g1.flip_inv_Galois (infix "\<^bsub>R1\<^esub>\<greaterapprox>" 50)
notation g1.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R1\<^esub>" 50)
notation g2.flip_inv_Galois (infix "\<^bsub>R2\<^esub>\<greaterapprox>" 50)
notation g2.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R2\<^esub>" 50)

notation g1.flip_flip_inv_Galois (infix "\<^bsub>L1\<^esub>\<greaterapprox>" 50)
notation g1.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L1\<^esub>" 50)
notation g2.flip_flip_inv_Galois (infix "\<^bsub>L2\<^esub>\<greaterapprox>" 50)
notation g2.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L2\<^esub>" 50)

notation g1.unit ("\<eta>\<^sub>1")
notation g1.counit ("\<epsilon>\<^sub>1")
notation g2.unit ("\<eta>\<^sub>2")
notation g2.counit ("\<epsilon>\<^sub>2")

abbreviation (input) "L \<equiv> L1"

definition "l \<equiv> l2 \<circ> l1"

lemma left_eq_comp: "l = l2 \<circ> l1"
  unfolding l_def ..

lemma left_eq [simp]: "l x = l2 (l1 x)"
  unfolding left_eq_comp by simp

context
begin

interpretation flip : transport_comp_agree R2 L2 r2 l2 R1 L1 r1 l1 .

abbreviation (input) "R \<equiv> flip.L"
abbreviation "r \<equiv> flip.l"

lemma right_eq_comp: "r = r1 \<circ> r2"
  unfolding flip.l_def ..

lemma right_eq [simp]: "r z = r1 (r2 z)"
  unfolding right_eq_comp by simp

lemmas transport_defs = left_eq_comp right_eq_comp

end

sublocale transport L R l r .

(*FIXME: somehow the notation for the fixed parameters L and R, defined in
Order_Functions_Base.thy, is lost. We hence re-declare it here.*)
notation L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation R (infix "\<le>\<^bsub>R\<^esub>" 50)

end

locale transport_comp_same =
  transport_comp_agree L1 R1 l1 r1 R1 R2 l2 r2
  for L1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R1 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l1 :: "'a \<Rightarrow> 'b"
  and r1 :: "'b \<Rightarrow> 'a"
  and R2 :: "'c \<Rightarrow> 'c \<Rightarrow> bool"
  and l2 :: "'b \<Rightarrow> 'c"
  and r2 :: "'c \<Rightarrow> 'b"
begin

text \<open>This locale is a special case of @{locale "transport_comp_agree"} where
the left and right components both use @{term "(\<le>\<^bsub>R1\<^esub>)"} as their right and left
relation, respectively. This is the special case that is most prominent in the
literature. The resulting theorems are quite simple, but often not applicable
in practice.\<close>

end

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Quicksort.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Example: Quicksort on Heap Lists"

theory Quicksort
imports "../Vcg" "../HeapList" "HOL-Library.Permutation"
begin

record globals_heap =
  next_' :: "ref \<Rightarrow> ref"
  cont_' :: "ref \<Rightarrow> nat"

record 'g vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  le_'   :: "ref"
  gt_'   :: "ref"
  hd_'   :: "ref"
  tl_'   :: "ref"

procedures
  append(p,q|p) =
    "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"

  append_spec:
   "\<forall>\<sigma> Ps Qs.
     \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
           \<acute>p :== PROC append(\<acute>p,\<acute>q)
         \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  append_modifies:
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in append_impl) append_modifies:
  shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in append_impl) append_spec:
  shows "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>
            \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
                \<acute>p :== PROC append(\<acute>p,\<acute>q)
            \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply fastforce
  done

primrec sorted:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list  \<Rightarrow> bool"
where
"sorted le [] = True" |
"sorted le (x#xs) = ((\<forall>y\<in>set xs. le x y) \<and> sorted le xs)"

lemma perm_set_eq:
  assumes perm: "xs <~~> ys"
  shows "set xs = set ys"
  using perm
  by induct auto

lemma perm_Cons_eq [iff]: "x#xs <~~> x#ys = (xs <~~> ys)"
  by auto

lemma perm_app_Cons_eq1 : "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
proof -
  have app_Cons: "xs@y#ys <~~> y#xs@ys"
    by (rule perm_sym, rule perm_append_Cons)
  show ?thesis
  proof
    assume "xs@y#ys <~~> zs"
    with app_Cons [THEN perm_sym]
    show "y#xs@ys <~~> zs"
      by (rule perm.trans)
  next
    assume " y#xs@ys <~~> zs"
    with app_Cons
    show "xs@y#ys <~~> zs"
      by (rule perm.trans)
  qed
qed

lemma perm_app_Cons_eq2 : "zs <~~> xs@y#ys = (zs <~~> y#xs@ys)"
proof -
  have "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
    by (rule perm_app_Cons_eq1)
  thus ?thesis
    by (iprover intro: perm_sym)
qed

lemmas perm_app_Cons_simps = perm_app_Cons_eq1 [THEN sym]
                             perm_app_Cons_eq2 [THEN sym]

lemma sorted_append[simp]:
 "sorted le (xs@ys) = (sorted le xs \<and> sorted le ys \<and>
                       (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
by (induct xs, auto)

lemma perm_append_blocks:
  assumes ws_ys: "ws <~~> ys"
  assumes xs_zs: "xs <~~> zs"
  shows "ws@xs <~~> ys@zs"
using ws_ys
proof (induct)
  case (swap l x y)
  from xs_zs
  show "(l # x # y) @ xs <~~> (x # l # y) @ zs"
  by (induct) auto
qed (insert xs_zs , auto)

procedures quickSort(p|p) =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI"

  quickSort_spec:
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC quickSort(\<acute>p)
       \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
        sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
        Ps <~~> sortedPs) \<and>
        (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  quickSort_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in quickSort_impl) quickSort_modifies:
  shows
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

lemma (in quickSort_impl) quickSort_spec:
shows
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace>
                  \<acute>p :== PROC quickSort(\<acute>p)
                \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
                 sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
                 Ps <~~> sortedPs) \<and>
                 (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (hoare_rule anno =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null
       INV \<lbrace> (\<exists>les grs tls. List \<acute>le \<acute>next les \<and> List \<acute>gt \<acute>next grs \<and>
               List \<acute>tl \<acute>next tls \<and>
               Ps <~~> \<acute>p#tls@les@grs \<and>
               distinct(\<acute>p#tls@les@grs) \<and>
               (\<forall>x\<in>set les. x\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont) \<and>
               (\<forall>x\<in>set grs. \<acute>p\<rightarrow>\<acute>cont < x\<rightarrow>\<acute>cont)) \<and>
               \<acute>p=\<^bsup>\<sigma>\<^esup>p \<and>
               \<acute>cont=\<^bsup>\<sigma>\<^esup>cont \<and>
               List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>
               (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>
       DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI" in HoarePartial.annotateI)
apply vcg
apply   fastforce
apply  clarsimp
apply  (rule conjI)
apply   clarify
apply   (rule conjI)
apply    (rule_tac x="tl#les" in exI)
apply    simp
apply    (rule_tac x="grs" in exI)
apply    simp
apply    (rule_tac x="ps" in exI)
apply    simp
apply    (erule perm.trans)
apply    simp
apply    (simp add: perm_app_Cons_simps)
apply   (simp add: perm_set_eq)
apply  clarify
apply  (rule conjI)
apply   (rule_tac x="les" in exI)
apply   simp
apply   (rule_tac x="tl#grs" in exI)
apply   simp
apply   (rule_tac x="ps" in exI)
apply   simp
apply   (erule perm.trans)
apply   simp
apply   (simp add: perm_app_Cons_simps)
apply  (simp add: perm_set_eq)
apply clarsimp
apply (rule_tac ?x=grs in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  clarify
apply  (erule_tac x=x in allE)back
apply  blast
apply clarsimp
apply (rule_tac x="sortedPs" in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  (clarsimp)
apply  (erule_tac x=x in allE) back back
apply  (fast dest!: perm_set_eq)
apply (rule_tac x="p#sortedPsa" in exI)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (force dest!: perm_set_eq)
apply clarsimp
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (erule perm.trans)
apply  (simp add:  perm_app_Cons_simps list_all_iff)
apply  (fastforce intro!: perm_append_blocks)
apply clarsimp
apply (erule_tac x=x in allE)+
apply (force dest!: perm_set_eq)
done

end


theory Ex05
imports "~~/src/HOL/IMP/Big_Step" Main
begin

definition "Or b1 b2 \<equiv> Not (And (Not b1) (Not b2))"

term "op \<sim>"

lemma "IF (And b1 b2) THEN c1 ELSE c2
  \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"
  (* usamos split_if cuando el if esta en la conclusión, si esta en las premisas usamos split_if_asm *)
  apply (auto split: split_if_asm)
  apply (rule IfTrue)
  apply assumption
  apply (rule IfTrue)
  apply assumption
  apply assumption

  apply (rule IfTrue)
  apply assumption
  apply (rule IfFalse)
  apply assumption
  apply assumption

  apply (rule IfFalse)
  apply assumption
  apply assumption
  done
(*
lemma
  defines "b1 \<equiv> Bc True" and "b2 \<equiv> Bc False" and "c \<equiv> SKIP"
  shows "\<not>(WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c)"
  unfolding b1_def b2_def
  apply auto
  apply (rule exI[where x="<>"])
  apply (rule exI[where x="<>"])
  apply (auto)

*)

lemma "\<not>(WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c)"
proof
  assume "WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c"

end


theory WTMiscEnv
  imports TypeEnv LiftEnv
begin

fun fun_ty where
  "fun_ty (FunTy t1 t2 r a) = True"
| "fun_ty tau = False"

fun max_aff where
  "max_aff Aff a = Aff"
| "max_aff a Aff = Aff"
| "max_aff Prim Prim = Prim"
| "max_aff a1 a2 = Ref"

fun as_aff where
  "as_aff OwnPerm = Aff"
| "as_aff UsePerm = Ref"
| "as_aff NoPerm = Prim"

fun req_type where
  "req_type (FunTy t1 t2 r a) = a"
| "req_type (ArrayTy tau) = Ref"
| "req_type (PairTy t1 t2 r) = as_aff r(*(if r = OwnPerm then Aff else max_aff (req_type t1) (req_type t2))*)"
  (*if req_type t1 = Aff \<or> req_type t2 = Aff then Aff else Ref*)
| "req_type (ChanTy tau c) = Ref"
| "req_type tau = Prim"

definition unlim where
  "unlim tau = (req_type tau \<noteq> Aff)"

definition non_prim_entry where
  "non_prim_entry env x = (\<exists> tau. env x = Some tau \<and> req_type tau \<noteq> Prim)"

definition np_use_env where
  "np_use_env env r_s = (\<lambda> x. if non_prim_entry env x then r_s x else NoPerm)"

definition null_use_env where
  "null_use_env r_s = (\<forall> x. r_s x = NoPerm)"

definition aff_use_env where
  "aff_use_env r_s a = (case a of
    Aff \<Rightarrow> True
    | Ref \<Rightarrow> weak_use_env r_s
    | Prim \<Rightarrow> null_use_env r_s
  )"

definition start_req_perm where
  "start_req_perm tau = (case req_type tau of
    Aff \<Rightarrow> OwnPerm
  | other \<Rightarrow> UsePerm)"

definition end_req_perm where
  "end_req_perm tau = (case req_type tau of
    Aff \<Rightarrow> OwnPerm
  | Ref \<Rightarrow> UsePerm
  | other \<Rightarrow> NoPerm)"

definition req_use_env where
  "req_use_env x tau = one_use_env x (start_req_perm tau)"

definition ereq_use_env where
  "ereq_use_env x tau = one_use_env x (end_req_perm tau)"

    (*
      ####################################
        P1. specialized perm-env lemmas
      ####################################
    *)

    (* - basic perm lemmas *)

lemma req_use_none: "req_use_env x tau x \<noteq> NoPerm"
  apply (simp add: req_use_env_def)
  apply (simp add: start_req_perm_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma req_use_none_alt: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> req_use_env x tau y = NoPerm"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  done

lemma ereq_use_none: "\<lbrakk> req_type tau \<noteq> Prim \<rbrakk> \<Longrightarrow> ereq_use_env x tau x \<noteq> NoPerm"
  apply (simp add: ereq_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma ereq_use_none_alt: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> ereq_use_env x tau y = NoPerm"
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  done

    (* - affinity lemmas *)

lemma max_aff_prim: "\<lbrakk> max_aff a1 a2 = Prim \<rbrakk> \<Longrightarrow> a1 = Prim \<and> a2 = Prim"
  apply (case_tac a1)
    apply (auto)
   apply (case_tac a2)
     apply (auto)
  apply (case_tac a2)
    apply (auto)
  done

    (* - ordering lemmas *)

lemma req_leq_use_env: "\<lbrakk> leq_use_env (req_use_env x tau) r_s; r_s x = r_x x \<rbrakk> \<Longrightarrow> leq_use_env (req_use_env x tau) r_x"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "x = xa")
   apply (auto)
  done

lemma req_leq_use_envx: "\<lbrakk> leq_perm (start_req_perm tau) (r_s x) \<rbrakk> \<Longrightarrow> leq_use_env (req_use_env x tau) r_s"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (auto)
  done

    (* - disjointness lemmas *)

lemma disj_req_use_env1: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env (req_use_env x tau) r_s"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

lemma disj_req_use_env2: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env r_s (req_use_env x tau)"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

    (* - affine env lemmas *)

lemma leq_null_use_env: "\<lbrakk> null_use_env r_s; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> null_use_env r_x"
  apply (simp add: null_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma dist_np_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (np_use_env env r_x) (np_use_env env r_s)"
  apply (simp add: leq_use_env_def)
  apply (simp add: np_use_env_def)
  done

lemma aff_leq_use_env: "\<lbrakk> aff_use_env r_s a; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> aff_use_env r_x a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (rule_tac r_s="r_s" in leq_weak_use_env)
    apply (simp_all)
  apply (rule_tac r_s="r_s" in leq_null_use_env)
   apply (simp_all)
  done

lemma aff_diff_use_env: "\<lbrakk> aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (diff_use_env r_s r_x) a"
  apply (rule_tac r_s="r_s" in aff_leq_use_env)
   apply (auto)
  apply (rule_tac self_diff_leq_use_env)
  done

lemma aff_rem_use_env: "\<lbrakk> aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (rem_use_env r_s x) a"
  apply (rule_tac r_s="r_s" in aff_leq_use_env)
   apply (auto)
  apply (rule_tac self_rem_leq_use_env)
  done

lemma aff_comp_use_env: "\<lbrakk> aff_use_env r_x a; aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (comp_use_env r_x r_s) a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (simp add: comp_use_env_def)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (erule_tac x="x" in allE)
   apply (erule_tac x="x" in allE)
   apply (case_tac "r_x x")
     apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: null_use_env_def)
  done

lemma aff_empty_use_env: "aff_use_env empty_use_env a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (simp add: empty_use_env_def)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (simp add: empty_use_env_def)
  done

(*
lemma aff_comp_use_env: "\<lbrakk> aff_use_env r_x a; aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (comp_use_env r_x r_s) a"
  apply (simp add: comp_use_env_def)
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
   apply (auto)
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma aff_empty_use_env: "aff_use_env empty_use_env a"
  apply (simp add: aff_use_env_def)
  apply (auto)
  apply (simp add: weak_use_env_def)
  apply (simp add: empty_use_env_def)
  done    *)

    (* ################# UNSORTED *)

lemma weak_ereq_use_env: "\<lbrakk> unlim tau \<rbrakk> \<Longrightarrow> weak_use_env (ereq_use_env x tau)"
  apply (simp add: weak_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (case_tac "req_type tau")
    apply (auto)
  apply (simp add: unlim_def)
  done

(*
lemma weak_req_use_env: "\<lbrakk> unlim tau \<rbrakk> \<Longrightarrow> weak_use_env (req_use_env x tau)"
  apply (simp add: weak_use_env_def)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: start_req_perm_def)
  apply (simp add: aff_fun_ty_def)
  done    *)

lemma self_ereq_leq_use_env: "leq_use_env (ereq_use_env x tau) (req_use_env x tau)"
  apply (simp add: leq_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (simp add: start_req_perm_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma ereq_leq_use_env: "\<lbrakk> leq_use_env (req_use_env x tau) r_s \<rbrakk> \<Longrightarrow> leq_use_env (ereq_use_env x tau) r_s"
  apply (rule_tac r_sb="req_use_env x tau" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_ereq_leq_use_env)
  done

lemma ereq_leq_use_envx: "\<lbrakk> leq_perm (end_req_perm tau) (r_s x) \<rbrakk> \<Longrightarrow> leq_use_env (ereq_use_env x tau) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  done

lemma one_mini_disj_use_env1: "\<lbrakk> r_x x \<noteq> OwnPerm \<or> r = NoPerm \<or> r_ex x = OwnPerm \<rbrakk> \<Longrightarrow> mini_disj_use_env r_x (diff_use_env (one_use_env x r) r_ex)"
  apply (simp add: diff_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
     apply (case_tac "r_ex xa")
       apply (auto)
    apply (case_tac "r_ex x")
      apply (auto)
   apply (case_tac "r_ex xa")
     apply (auto)
  apply (case_tac "r_ex xa")
    apply (auto)
  done

lemma one_mini_disj_use_env2: "\<lbrakk> r \<noteq> OwnPerm \<or> r_ex x = OwnPerm \<or> r_x x = NoPerm \<rbrakk> \<Longrightarrow> mini_disj_use_env (diff_use_env (one_use_env x r) r_ex) r_x"
apply (simp add: diff_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
     apply (case_tac "r_ex x")
       apply (auto)
    apply (case_tac "r_ex xa")
      apply (auto)
   apply (case_tac "r_ex xa")
     apply (auto)
  apply (case_tac "r_ex xa")
    apply (auto)
  done

lemma diff_one_leq_use_env: "leq_use_env (diff_use_env (one_use_env x r) (one_use_env x OwnPerm)) r_s"
  apply (simp add: diff_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (simp add: one_use_env_def)
  done

end


theory Geometry_Plane
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"subtype_def\", \"subtype_pred_def\", \"ga_assoc___Xx__\",
     \"ga_right_unit___Xx__\", \"ga_left_unit___Xx__\", \"inv_Group\",
     \"rinv_Group\", \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"left_zero\", \"right_zero\",
     \"ga_comm___Xx___1\", \"noZeroDiv\", \"zeroNeqOne\", \"Ax1\",
     \"ga_assoc___Xx___2\", \"ga_right_unit___Xx___2\",
     \"ga_left_unit___Xx___2\", \"inv_Group_1\", \"rinv_Group_1\",
     \"binary_inverse\", \"Ax1_1\", \"refl\", \"trans\", \"antisym\",
     \"dichotomy_TotalOrder\", \"FWO_plus_left\", \"FWO_times_left\",
     \"FWO_plus_right\", \"FWO_times_right\", \"FWO_plus\", \"inf_def\",
     \"Real_completeness\", \"geq_def_ExtPartialOrder\",
     \"less_def_ExtPartialOrder\", \"greater_def_ExtPartialOrder\",
     \"ga_comm_inf\", \"ga_comm_sup\", \"inf_def_ExtPartialOrder\",
     \"sup_def_ExtPartialOrder\", \"ga_comm_min\", \"ga_comm_max\",
     \"ga_assoc_min\", \"ga_assoc_max\", \"ga_left_comm_min\",
     \"ga_left_comm_max\", \"min_def_ExtTotalOrder\",
     \"max_def_ExtTotalOrder\", \"min_inf_relation\",
     \"max_sup_relation\", \"RealNonNeg_pred_def\",
     \"RealPos_pred_def\", \"Ax3\", \"Ax4\", \"RealNonNeg_subtype\",
     \"RealPos_subtype\", \"abs_def\",
     \"times_cancel_right_nonneg_leq\", \"times_leq_nonneg_cond\",
     \"sqr_def\", \"sqrt_def\", \"Pos_def\", \"X2_def_Real\",
     \"X3_def_Real\", \"X4_def_Real\", \"X5_def_Real\", \"X6_def_Real\",
     \"X7_def_Real\", \"X8_def_Real\", \"X9_def_Real\",
     \"ZeroToNine_type\", \"decimal_def\", \"ga_select_C1\",
     \"ga_select_C2\", \"ga_select_C3\", \"Zero_Point\",
     \"Point_choice\", \"ga_select_C1_1\", \"ga_select_C2_1\",
     \"ga_select_C3_1\", \"Zero_Vector\", \"VectorStar_pred_def\",
     \"Ax7\", \"VectorStar_subtype\", \"def_of_vector_addition\",
     \"def_of_minus_vector\", \"binary_inverse_1_1\",
     \"scalar_multiplication\", \"scalar_product\", \"vector_product\",
     \"ONB1\", \"ONB2\", \"ONB3\", \"cross_left_homogenity\",
     \"cross_product_antisymmetric\", \"ga_assoc___Xx___3_1\",
     \"ga_right_unit___Xx___3_1\", \"ga_left_unit___Xx___3_1\",
     \"inv_Group_2_1\", \"rinv_Group_2_1\", \"ga_comm___Xx___3\",
     \"unit\", \"mix_assoc\", \"distr_Field\", \"distr_Space\",
     \"zero_by_left_zero\", \"zero_by_right_zero\",
     \"inverse_by_XMinus1\", \"distributive\", \"homogeneous\",
     \"symmetric\", \"pos_definite\", \"right_distributive\",
     \"right_homogeneous\", \"non_degenerate\", \"lindep_def\",
     \"lindep_reflexivity\", \"lindep_symmetry\",
     \"simple_lindep_condition\", \"lindep_nonlindep_transitivity\",
     \"norm_from_inner_prod_def\", \"proj_def\", \"orthcomp_def\",
     \"orthogonal_def\", \"orth_symmetric\", \"lindep_orth_transitive\",
     \"orthogonal_existence_theorem\",
     \"orthogonal_on_zero_projection\",
     \"orthogonal_projection_theorem\",
     \"orthogonal_decomposition_theorem\",
     \"unique_orthogonal_decomposition\", \"cross_product_orthogonal\",
     \"cross_product_zero_iff_lindep\", \"e1e2_nonlindep\",
     \"point_vector_map\", \"plus_injective\", \"plus_surjective\",
     \"point_vector_plus_associative\", \"vec_def\",
     \"transitivity_of_vec_plus\", \"plus_vec_identity\",
     \"set_comprehension\", \"abbrev_of_set_comprehension\",
     \"function_image\", \"emptySet_empty\", \"allSet_contains_all\",
     \"def_of_isIn\", \"def_of_subset\", \"def_of_union\",
     \"def_of_bigunion\", \"def_of_intersection\",
     \"def_of_difference\", \"def_of_disjoint\", \"def_of_productset\",
     \"emptySet_union_right_unit\", \"function_image_structure\",
     \"def_of_interval\", \"abbrev_of_interval\",
     \"plus_PointSet_Vector\", \"plus_Point_VectorSet\",
     \"plus_PointSet_VectorSet\", \"def_of_Plane\",
     \"plane_condition_for_2_points\",
     \"plane_condition_for_point_and_vector\"]"

typedecl NonZero
typedecl PointSet
typedecl Real
typedecl RealNonNeg
typedecl RealPos
typedecl RealSet
typedecl ('a1) Set
typedecl VectorSet
typedecl VectorStar
typedecl ZeroToNine

datatype Point = X_P "Real" "Real" "Real" ("P/'(_,/ _,/ _')" [3,3,3] 999)
datatype Vector = X_V "Real" "Real" "Real" ("V/'(_,/ _,/ _')" [3,3,3] 999)

consts
C1X1 :: "Point => Real" ("C1''/'(_')" [3] 999)
C1X2 :: "Vector => Real" ("C1''''/'(_')" [3] 999)
C2X1 :: "Point => Real" ("C2''/'(_')" [3] 999)
C2X2 :: "Vector => Real" ("C2''''/'(_')" [3] 999)
C3X1 :: "Point => Real" ("C3''/'(_')" [3] 999)
C3X2 :: "Vector => Real" ("C3''''/'(_')" [3] 999)
Plane :: "Point * VectorStar => Point => bool"
X0X1 :: "Point" ("0''")
X0X2 :: "Real" ("0''''")
X0X3 :: "Vector" ("0'_3")
X1X1 :: "NonZero" ("1''")
X1X2 :: "Real" ("1''''")
X2 :: "Real" ("2''")
X3 :: "Real" ("3''")
X4 :: "Real" ("4''")
X5 :: "Real" ("5''")
X6 :: "Real" ("6''")
X7 :: "Real" ("7''")
X8 :: "Real" ("8''")
X9 :: "Real" ("9''")
XLBrace__XRBrace :: "('S => bool) => 'S => bool"
XMinus__XX1 :: "Real => Real" ("(-''/ _)" [56] 56)
XMinus__XX2 :: "Vector => Vector" ("(-''''/ _)" [56] 56)
XOSqBr__XPeriodXPeriodXPeriod__XCSqBr :: "Real * Real => Real => bool"
XVBarXVBar__XVBarXVBar :: "Vector => Real" ("(||/ _/ ||)" [10] 999)
X_Pos :: "Real => bool" ("Pos/'(_')" [3] 999)
X_RealNonNeg_inj :: "RealNonNeg => Real" ("RealNonNeg'_inj/'(_')" [3] 999)
X_RealNonNeg_pred :: "Real => bool" ("RealNonNeg'_pred/'(_')" [3] 999)
X_RealNonNeg_proj :: "Real => RealNonNeg" ("RealNonNeg'_proj/'(_')" [3] 999)
X_RealPos_inj :: "RealPos => Real" ("RealPos'_inj/'(_')" [3] 999)
X_RealPos_pred :: "Real => bool" ("RealPos'_pred/'(_')" [3] 999)
X_RealPos_proj :: "Real => RealPos" ("RealPos'_proj/'(_')" [3] 999)
X_VectorStar_inj :: "VectorStar => Vector" ("VectorStar'_inj/'(_')" [3] 999)
X_VectorStar_pred :: "Vector => bool" ("VectorStar'_pred/'(_')" [3] 999)
X_VectorStar_proj :: "Vector => VectorStar" ("VectorStar'_proj/'(_')" [3] 999)
X__XAtXAt__X :: "ZeroToNine => Real => Real" ("(_/ @@/ _)" [54,54] 52)
X__XBslashXBslash__X :: "('S => bool) * ('S => bool) => 'S => bool"
X__XGtXEq__X :: "Real => Real => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Real => Real => bool" ("(_/ >''/ _)" [44,44] 42)
X__XHash__X :: "Vector => Vector => Vector" ("(_/ #''/ _)" [54,54] 52)
X__XLtXEq__X :: "Real => Real => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Real => Real => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinus__XX1 :: "Real => Real => Real" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Vector => Vector => Vector" ("(_/ -''''/ _)" [54,54] 52)
X__XPlus__XX1 :: "Point => Vector => Point" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Point * (Vector => bool) => Point => bool"
X__XPlus__XX3 :: "Real => Real => Real" ("(_/ +'_3/ _)" [54,54] 52)
X__XPlus__XX4 :: "Vector => Vector => Vector" ("(_/ +'_4/ _)" [54,54] 52)
X__XPlus__XX5 :: "(Point => bool) * Vector => Point => bool"
X__XPlus__XX6 :: "(Point => bool) * (Vector => bool) => Point => bool"
X__XSlash__X :: "Real => NonZero => Real" ("(_/ '/''/ _)" [54,54] 52)
X__Xx__XX1 :: "NonZero => NonZero => NonZero" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Real => Real => Real" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Real => Vector => Vector" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "Vector => Vector => Real" ("(_/ *'_4/ _)" [54,54] 52)
X__Xx__XX5 :: "('S => bool) * ('T => bool) => 'S * 'T => bool"
X__disjoint__X :: "('S => bool) => ('S => bool) => bool" ("(_/ disjoint/ _)" [44,44] 42)
X__intersection__X :: "('S => bool) * ('S => bool) => 'S => bool"
X__isIn__X :: "'S => ('S => bool) => bool" ("(_/ isIn/ _)" [44,44] 42)
X__subset__X :: "('S => bool) => ('S => bool) => bool" ("(_/ subset/ _)" [44,44] 42)
X__union__X :: "('S => bool) * ('S => bool) => 'S => bool"
X_abs :: "Real => RealNonNeg" ("abs''/'(_')" [3] 999)
X_allSet :: "'S => bool" ("allSet/'(_')" [3] 999)
X_choose :: "(Point => bool) => Point" ("choose''/'(_')" [3] 999)
X_emptySet :: "'S => bool" ("emptySet/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b partial" ("gn'_proj/'(_')" [3] 999)
X_image :: "('S => 'T) * ('S => bool) => 'T => bool"
X_inv :: "NonZero => NonZero" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
X_lindep :: "Vector => Vector => bool" ("lindep/'(_,/ _')" [3,3] 999)
X_max :: "Real => Real => Real" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Real => Real => Real" ("min''/'(_,/ _')" [3,3] 999)
X_orth :: "Vector => Vector => bool" ("orth/'(_,/ _')" [3,3] 999)
X_orthcomp :: "Vector => Vector => Vector" ("orthcomp/'(_,/ _')" [3,3] 999)
X_proj :: "Vector => Vector => Vector" ("proj/'(_,/ _')" [3,3] 999)
X_sqr :: "Real => RealNonNeg" ("sqr/'(_')" [3] 999)
X_sqrt :: "RealNonNeg => RealNonNeg" ("sqrt/'(_')" [3] 999)
X_sup :: "Real => Real => Real partial" ("sup/'(_,/ _')" [3,3] 999)
X_vec :: "Point => Point => Vector" ("vec/'(_,/ _')" [3,3] 999)
bigunion :: "(('S => bool) => bool) => 'S => bool"
closedinterval :: "Real * Real => Real => bool"
e1 :: "Vector"
e2 :: "Vector"
e3 :: "Vector"
infX1 :: "Real => Real => Real partial" ("inf''/'(_,/ _')" [3,3] 999)
infX2 :: "(Real => bool) => Real partial" ("inf''''/'(_')" [3] 999)
setFromProperty :: "('S => bool) => 'S => bool"

axioms
subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL X_P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(X_P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. X_P x --> x = injection (projection x))) &
  (ALL x. X_P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +_3 y) +_3 z = x +_3 (y +_3 z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +_3 0'' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0'' +_3 x = x"

inv_Group [rule_format] : "ALL x. -' x +_3 x = 0''"

rinv_Group [rule_format] : "ALL x. x +_3 -' x = 0''"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +_3 y = y +_3 x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1'' *'' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +_3 y) *'' z = (x *'' z) +_3 (y *'' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *'' (x +_3 y) = (z *'' x) +_3 (z *'' y)"

left_zero [rule_format] : "ALL x. 0'' *'' x = 0''"

right_zero [rule_format] : "ALL x. x *'' 0'' = 0''"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

noZeroDiv [rule_format] :
"ALL x. ALL y. x *'' y = 0'' --> x = 0'' | y = 0''"

zeroNeqOne [rule_format] : "~ 1'' = 0''"

Ax1 [rule_format] : "ALL x. defOp (gn_proj(x)) = (~ x = 0'')"

ga_assoc___Xx___2 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___2 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___2 [rule_format] : "ALL x. 1' *' x = x"

inv_Group_1 [rule_format] : "ALL x. inv'(x) *' x = 1'"

rinv_Group_1 [rule_format] : "ALL x. x *' inv'(x) = 1'"

binary_inverse [rule_format] : "ALL x. ALL y. x -' y = x +_3 -' y"

Ax1_1 [rule_format] :
"ALL x. ALL y. x /' y = x *'' gn_inj(inv'(y))"

refl [rule_format] : "ALL x. x <=' x"

trans [rule_format] :
"ALL x. ALL y. ALL z. x <=' y & y <=' z --> x <=' z"

antisym [rule_format] : "ALL x. ALL y. x <=' y & y <=' x --> x = y"

dichotomy_TotalOrder [rule_format] :
"ALL x. ALL y. x <=' y | y <=' x"

FWO_plus_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b --> a +_3 c <=' b +_3 c"

FWO_times_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b & 0'' <=' c --> a *'' c <=' b *'' c"

FWO_plus_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c --> a +_3 b <=' a +_3 c"

FWO_times_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c & 0'' <=' a --> a *'' b <=' a *'' c"

FWO_plus [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a <=' c & b <=' d --> a +_3 b <=' c +_3 d"

inf_def [rule_format] :
"ALL S.
 ALL m.
 inf''(S) = makePartial m =
 (ALL m2. (ALL x. S x --> x <=' m2) --> m <=' m2)"

Real_completeness [rule_format] :
"ALL S.
 (EX x. S x) & (EX B. ALL x. S x --> x <=' B) -->
 (EX m. makePartial m = inf''(S))"

geq_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >=' y) = (y <=' x)"

less_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x <' y) = (x <=' y & ~ x = y)"

greater_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >' y) = (y <' x)"

ga_comm_inf [rule_format] : "ALL x. ALL y. inf'(x, y) = inf'(y, x)"

ga_comm_sup [rule_format] : "ALL x. ALL y. sup(x, y) = sup(y, x)"

inf_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 inf'(x, y) = makePartial z =
 (z <=' x & z <=' y & (ALL t. t <=' x & t <=' y --> t <=' z))"

sup_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 sup(x, y) = makePartial z =
 (x <=' z & y <=' z & (ALL t. x <=' t & y <=' t --> z <=' t))"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

min_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. min'(x, y) = (if x <=' y then x else y)"

max_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. max'(x, y) = (if x <=' y then y else x)"

min_inf_relation [rule_format] :
"ALL x. ALL y. makePartial (min'(x, y)) = inf'(x, y)"

max_sup_relation [rule_format] :
"ALL x. ALL y. makePartial (max'(x, y)) = sup(x, y)"

RealNonNeg_pred_def [rule_format] :
"ALL x. RealNonNeg_pred(x) = (x >=' 0'')"

RealPos_pred_def [rule_format] :
"ALL x. RealPos_pred(x) = (x >' 0'')"

Ax3 [rule_format] :
"ALL x. defOp (gn_proj(x)) = RealNonNeg_pred(x)"

Ax4 [rule_format] : "ALL x. defOp (gn_proj(x)) = RealPos_pred(x)"

RealNonNeg_subtype [rule_format] :
"isSubtypeWithPred(X_RealNonNeg_pred, X_RealNonNeg_inj,
 X_RealNonNeg_proj)"

RealPos_subtype [rule_format] :
"isSubtypeWithPred(X_RealPos_pred, X_RealPos_inj, X_RealPos_proj)"

abs_def [rule_format] :
"ALL x.
 makePartial (abs'(x)) =
 (if 0'' <=' x then gn_proj(x) else gn_proj(-' x))"

times_cancel_right_nonneg_leq [rule_format] :
"ALL a. ALL b. ALL c. a *'' b <=' c *'' b & b >=' 0'' --> a <=' c"

times_leq_nonneg_cond [rule_format] :
"ALL a. ALL b. 0'' <=' a *'' b & b >=' 0'' --> 0'' <=' a"

sqr_def [rule_format] :
"ALL r. gn_inj(sqr(r)) = makePartial (r *'' r)"

sqrt_def [rule_format] : "ALL q. sqr(gn_inj(sqrt(q))) = q"

Pos_def [rule_format] : "ALL x. Pos(x) = (0'' <=' x)"

X2_def_Real [rule_format] : "2' = gn_inj(1') +_3 gn_inj(1')"

X3_def_Real [rule_format] : "3' = 2' +_3 gn_inj(1')"

X4_def_Real [rule_format] : "4' = 3' +_3 gn_inj(1')"

X5_def_Real [rule_format] : "5' = 4' +_3 gn_inj(1')"

X6_def_Real [rule_format] : "6' = 5' +_3 gn_inj(1')"

X7_def_Real [rule_format] : "7' = 6' +_3 gn_inj(1')"

X8_def_Real [rule_format] : "8' = 7' +_3 gn_inj(1')"

X9_def_Real [rule_format] : "9' = 8' +_3 gn_inj(1')"

ZeroToNine_type [rule_format] :
"ALL x.
 defOp (gn_proj(x)) =
 (((((((((x = 0'' | makePartial x = gn_inj(1')) | x = 2') |
        x = 3') |
       x = 4') |
      x = 5') |
     x = 6') |
    x = 7') |
   x = 8') |
  x = 9')"

decimal_def [rule_format] :
"ALL m.
 ALL X_n. m @@ X_n = (gn_inj(m) *'' (9' +_3 gn_inj(1'))) +_3 X_n"

ga_select_C1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C1'(P(x_1, x_2, x_3)) = x_1"

ga_select_C2 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C2'(P(x_1, x_2, x_3)) = x_2"

ga_select_C3 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C3'(P(x_1, x_2, x_3)) = x_3"

Zero_Point [rule_format] : "0' = P(0'', 0'', 0'')"

Point_choice [rule_format] :
"ALL X_P. (EX y. X_P y) --> X_P (choose'(X_P))"

ga_select_C1_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C1''(V(x_1, x_2, x_3)) = x_1"

ga_select_C2_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C2''(V(x_1, x_2, x_3)) = x_2"

ga_select_C3_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C3''(V(x_1, x_2, x_3)) = x_3"

Zero_Vector [rule_format] : "0_3 = V(0'', 0'', 0'')"

VectorStar_pred_def [rule_format] :
"ALL x. VectorStar_pred(x) = (~ x = 0_3)"

Ax7 [rule_format] :
"ALL x. defOp (gn_proj(x)) = VectorStar_pred(x)"

VectorStar_subtype [rule_format] :
"isSubtypeWithPred(X_VectorStar_pred, X_VectorStar_inj,
 X_VectorStar_proj)"

def_of_vector_addition [rule_format] :
"ALL x.
 ALL y.
 x +_4 y =
 V(C1''(x) +_3 C1''(y), C2''(x) +_3 C2''(y), C3''(x) +_3 C3''(y))"

def_of_minus_vector [rule_format] :
"ALL x. -'' x = V(-' C1''(x), -' C2''(x), -' C3''(x))"

binary_inverse_1_1 [rule_format] :
"ALL x. ALL y. x -'' y = x +_4 -'' y"

scalar_multiplication [rule_format] :
"ALL x.
 ALL y. x *_3 y = V(x *'' C1''(y), x *'' C2''(y), x *'' C3''(y))"

scalar_product [rule_format] :
"ALL x.
 ALL y.
 x *_4 y =
 ((C1''(x) *'' C1''(y)) +_3 (C2''(x) *'' C2''(y))) +_3
 (C3''(x) *'' C3''(y))"

vector_product [rule_format] :
"ALL x.
 ALL y.
 x #' y =
 V((C2''(x) *'' C3''(y)) -' (C2''(y) *'' C3''(x)),
 (C3''(x) *'' C1''(y)) -' (C3''(y) *'' C1''(x)),
 (C1''(x) *'' C2''(y)) -' (C1''(y) *'' C2''(x)))"

ONB1 [rule_format] : "e1 = V(gn_inj(1'), 0'', 0'')"

ONB2 [rule_format] : "e2 = V(0'', gn_inj(1'), 0'')"

ONB3 [rule_format] : "e3 = V(0'', 0'', gn_inj(1'))"

cross_left_homogenity [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x #' y) = (r *_3 x) #' y"

cross_product_antisymmetric [rule_format] :
"ALL x. ALL y. x #' y = -'' (y #' x)"

ga_assoc___Xx___3_1 [rule_format] :
"ALL x. ALL y. ALL z. (x +_4 y) +_4 z = x +_4 (y +_4 z)"

ga_right_unit___Xx___3_1 [rule_format] : "ALL x. x +_4 0_3 = x"

ga_left_unit___Xx___3_1 [rule_format] : "ALL x. 0_3 +_4 x = x"

inv_Group_2_1 [rule_format] : "ALL x. -'' x +_4 x = 0_3"

rinv_Group_2_1 [rule_format] : "ALL x. x +_4 -'' x = 0_3"

ga_comm___Xx___3 [rule_format] : "ALL x. ALL y. x +_4 y = y +_4 x"

unit [rule_format] : "ALL x. gn_inj(1') *_3 x = x"

mix_assoc [rule_format] :
"ALL r. ALL s. ALL x. (r *'' s) *_3 x = r *_3 (s *_3 x)"

distr_Field [rule_format] :
"ALL r. ALL s. ALL x. (r +_3 s) *_3 x = (r *_3 x) +_4 (s *_3 x)"

distr_Space [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x +_4 y) = (r *_3 x) +_4 (r *_3 y)"

zero_by_left_zero [rule_format] : "ALL x. 0'' *_3 x = 0_3"

zero_by_right_zero [rule_format] : "ALL r. r *_3 0_3 = 0_3"

inverse_by_XMinus1 [rule_format] :
"ALL x. -' gn_inj(1') *_3 x = -'' x"

distributive [rule_format] :
"ALL v. ALL v'. ALL w. (v +_4 v') *_4 w = (v *_4 w) +_3 (v' *_4 w)"

homogeneous [rule_format] :
"ALL a. ALL v. ALL w. (a *_3 v) *_4 w = a *'' (v *_4 w)"

symmetric [rule_format] : "ALL v. ALL w. v *_4 w = w *_4 v"

pos_definite [rule_format] : "ALL v. ~ v = 0_3 --> v *_4 v >' 0''"

right_distributive [rule_format] :
"ALL v. ALL v'. ALL w. w *_4 (v +_4 v') = (w *_4 v) +_3 (w *_4 v')"

right_homogeneous [rule_format] :
"ALL a. ALL v. ALL w. v *_4 (a *_3 w) = a *'' (v *_4 w)"

non_degenerate [rule_format] : "ALL v. v *_4 v = 0'' --> v = 0_3"

lindep_def [rule_format] :
"ALL x. ALL y. lindep(x, y) = (y = 0_3 | (EX r. x = r *_3 y))"

lindep_reflexivity [rule_format] : "ALL x. lindep(x, x)"

lindep_symmetry [rule_format] :
"ALL x. ALL y. lindep(x, y) --> lindep(y, x)"

simple_lindep_condition [rule_format] :
"ALL r. ALL x. ALL y. x = r *_3 y --> lindep(x, y)"

lindep_nonlindep_transitivity [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 (~ x = 0_3 & lindep(x, y)) & ~ lindep(y, z) --> ~ lindep(x, z)"

norm_from_inner_prod_def [rule_format] :
"ALL x.
 makePartial ( || x || ) =
 restrictOp (gn_proj(sqrt(makeTotal (gn_proj(x *_4 x)))))
 (defOp (gn_proj(x *_4 x)))"

proj_def [rule_format] :
"ALL v.
 ALL w.
 makePartial (proj(v, w)) =
 (if w = 0_3 then makePartial 0_3
     else restrictOp
          (makePartial (((v *_4 w) /' makeTotal (gn_proj(w *_4 w))) *_3 w))
          (defOp (gn_proj(w *_4 w))))"

orthcomp_def [rule_format] :
"ALL v. ALL w. orthcomp(v, w) = v -'' proj(v, w)"

orthogonal_def [rule_format] :
"ALL x. ALL y. orth(x, y) = (x *_4 y = 0'')"

orth_symmetric [rule_format] :
"ALL x. ALL y. orth(x, y) --> orth(y, x)"

lindep_orth_transitive [rule_format] :
"ALL x. ALL y. ALL z. lindep(x, y) & orth(y, z) --> orth(x, z)"

orthogonal_existence_theorem [rule_format] :
"ALL x.
 (EX a. EX b. ~ lindep(a, b)) --> (EX c. ~ c = 0_3 & orth(c, x))"

orthogonal_on_zero_projection [rule_format] :
"ALL x. ALL y. proj(x, y) = 0_3 --> orth(x, y)"

orthogonal_projection_theorem [rule_format] :
"ALL x. ALL y. orth(orthcomp(x, y), y)"

orthogonal_decomposition_theorem [rule_format] :
"ALL x. ALL y. proj(x, y) +_4 orthcomp(x, y) = x"

unique_orthogonal_decomposition [rule_format] :
"ALL v.
 ALL w.
 ALL x.
 ALL y.
 ALL z.
 ((((~ z = 0_3 & x +_4 y = v +_4 w) & lindep(x, z)) &
   lindep(v, z)) &
  orth(z, y)) &
 orth(z, w) -->
 x = v & y = w"

cross_product_orthogonal [rule_format] :
"ALL x. ALL y. orth(x, x #' y)"

cross_product_zero_iff_lindep [rule_format] :
"ALL x. ALL y. lindep(x, y) = (x #' y = 0_3)"

e1e2_nonlindep [rule_format] : "~ lindep(e1, e2)"

point_vector_map [rule_format] :
"ALL p.
 ALL v.
 p +' v =
 P(C1'(p) +_3 C1''(v), C2'(p) +_3 C2''(v), C3'(p) +_3 C3''(v))"

plus_injective [rule_format] :
"ALL p. ALL v. ALL w. p +' v = p +' w --> v = w"

plus_surjective [rule_format] : "ALL p. ALL q. EX y. p +' y = q"

point_vector_plus_associative [rule_format] :
"ALL p. ALL v. ALL w. p +' (v +_4 w) = (p +' v) +' w"

vec_def [rule_format] : "ALL p. ALL q. p +' vec(p, q) = q"

transitivity_of_vec_plus [rule_format] :
"ALL p. ALL q. ALL r. vec(p, q) +_4 vec(q, r) = vec(p, r)"

plus_vec_identity [rule_format] :
"ALL p. ALL q. ALL v. p +' v = q --> v = vec(p, q)"

set_comprehension [rule_format] : "ALL s. XLBrace__XRBrace s = s"

abbrev_of_set_comprehension [rule_format] :
"setFromProperty = XLBrace__XRBrace"

function_image [rule_format] :
"ALL XX. ALL f. X_image (f, XX) = (% x. EX y. y isIn XX & f y = x)"

emptySet_empty [rule_format] : "ALL x. ~ x isIn X_emptySet"

allSet_contains_all [rule_format] : "ALL x. x isIn X_allSet"

def_of_isIn [rule_format] : "ALL s. ALL x. (x isIn s) = s x"

def_of_subset [rule_format] :
"ALL s. ALL s'. (s subset s') = (ALL x. x isIn s --> x isIn s')"

def_of_union [rule_format] :
"ALL s.
 ALL s'.
 ALL x. (x isIn X__union__X (s, s')) = (x isIn s | x isIn s')"

def_of_bigunion [rule_format] :
"ALL XXXX.
 ALL x. (x isIn bigunion XXXX) = (EX XX. XX isIn XXXX & x isIn XX)"

def_of_intersection [rule_format] :
"ALL s.
 ALL s'.
 ALL x.
 (x isIn X__intersection__X (s, s')) = (x isIn s & x isIn s')"

def_of_difference [rule_format] :
"ALL s.
 ALL s'.
 ALL x.
 (x isIn X__XBslashXBslash__X (s, s')) = (x isIn s & ~ x isIn s')"

def_of_disjoint [rule_format] :
"ALL s.
 ALL s'.
 (s disjoint s') = (X__intersection__X (s, s') = X_emptySet)"

def_of_productset [rule_format] :
"ALL s.
 ALL t.
 ALL x.
 ALL y. ((x, y) isIn X__Xx__XX5 (s, t)) = (x isIn s & y isIn t)"

emptySet_union_right_unit [rule_format] :
"ALL a. X__union__X (a, X_emptySet) = a"

function_image_structure [rule_format] :
"ALL a.
 ALL f. ALL x. (x isIn X_image (f, a)) = (EX y. y isIn a & f y = x)"

def_of_interval [rule_format] :
"ALL a.
 ALL b.
 XOSqBr__XPeriodXPeriodXPeriod__XCSqBr (a, b) =
 (% r. r >=' a & r <=' b)"

abbrev_of_interval [rule_format] :
"closedinterval = XOSqBr__XPeriodXPeriodXPeriod__XCSqBr"

plus_PointSet_Vector [rule_format] :
"ALL X_P.
 ALL v. X__XPlus__XX5 (X_P, v) = X_image (% x. x +' v, X_P)"

plus_Point_VectorSet [rule_format] :
"ALL X_V.
 ALL p. X__XPlus__XX2 (p, X_V) = X_image (% x. p +' x, X_V)"

plus_PointSet_VectorSet [rule_format] :
"ALL X_P.
 ALL X_V.
 X__XPlus__XX6 (X_P, X_V) =
 bigunion (X_image (% x. X__XPlus__XX5 (X_P, x), X_V))"

def_of_Plane [rule_format] :
"ALL normal.
 ALL offset.
 Plane (offset, normal) =
 (% x. orth(vec(x, offset), gn_inj(normal)))"

declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare left_zero [simp]
declare right_zero [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___2 [simp]
declare ga_right_unit___Xx___2 [simp]
declare ga_left_unit___Xx___2 [simp]
declare inv_Group_1 [simp]
declare rinv_Group_1 [simp]
declare refl [simp]
declare FWO_plus_left [simp]
declare FWO_plus_right [simp]
declare ga_comm_inf [simp]
declare ga_comm_sup [simp]
declare ga_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_min [simp]
declare ga_assoc_max [simp]
declare ga_left_comm_min [simp]
declare ga_left_comm_max [simp]
declare min_inf_relation [simp]
declare max_sup_relation [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare RealNonNeg_subtype [simp]
declare RealPos_subtype [simp]
declare sqrt_def [simp]
declare ga_select_C1 [simp]
declare ga_select_C2 [simp]
declare ga_select_C3 [simp]
declare ga_select_C1_1 [simp]
declare ga_select_C2_1 [simp]
declare ga_select_C3_1 [simp]
declare Ax7 [simp]
declare VectorStar_subtype [simp]
declare ga_assoc___Xx___3_1 [simp]
declare ga_right_unit___Xx___3_1 [simp]
declare ga_left_unit___Xx___3_1 [simp]
declare inv_Group_2_1 [simp]
declare rinv_Group_2_1 [simp]
declare ga_comm___Xx___3 [simp]
declare unit [simp]
declare zero_by_left_zero [simp]
declare zero_by_right_zero [simp]
declare inverse_by_XMinus1 [simp]
declare lindep_reflexivity [simp]
declare lindep_symmetry [simp]
declare orth_symmetric [simp]
declare orthogonal_on_zero_projection [simp]
declare orthogonal_projection_theorem [simp]
declare orthogonal_decomposition_theorem [simp]
declare cross_product_orthogonal [simp]
declare e1e2_nonlindep [simp]
declare vec_def [simp]
declare transitivity_of_vec_plus [simp]
declare emptySet_empty [simp]
declare allSet_contains_all [simp]
declare def_of_isIn [simp]
declare emptySet_union_right_unit [simp]

theorem plane_condition_for_2_points :
"ALL normal.
 ALL offset.
 ALL x.
 ALL y.
 let plane = Plane (offset, normal)
 in x isIn plane & y isIn plane --> orth(vec(x, y), gn_inj(normal))"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Point
      Zero_Vector VectorStar_pred_def scalar_multiplication
      scalar_product vector_product ONB1 ONB2 ONB3 lindep_def
      norm_from_inner_prod_def proj_def orthcomp_def orthogonal_def
      point_vector_map vec_def set_comprehension
      abbrev_of_set_comprehension function_image def_of_interval
      abbrev_of_interval plus_PointSet_Vector plus_Point_VectorSet
      plus_PointSet_VectorSet def_of_Plane
by (auto)

ML "Header.record \"plane_condition_for_2_points\""

theorem plane_condition_for_point_and_vector :
"ALL normal.
 ALL offset.
 ALL v.
 ALL x.
 let plane = Plane (offset, normal)
 in x isIn plane & orth(v, gn_inj(normal)) --> x +' v isIn plane"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Point
      Zero_Vector VectorStar_pred_def scalar_multiplication
      scalar_product vector_product ONB1 ONB2 ONB3 lindep_def
      norm_from_inner_prod_def proj_def orthcomp_def orthogonal_def
      point_vector_map vec_def set_comprehension
      abbrev_of_set_comprehension function_image def_of_interval
      abbrev_of_interval plus_PointSet_Vector plus_Point_VectorSet
      plus_PointSet_VectorSet def_of_Plane
by (auto)

ML "Header.record \"plane_condition_for_point_and_vector\""

end