(* Authors: Christian Urban and Mathilde Arnaud                   *)
(*                                                                *)
(* A formalisation of the Church-Rosser proof by Masako Takahashi.*)
(* This formalisation follows with some very slight exceptions    *)
(* the version of this proof given by Randy Pollack in the paper: *)
(*                                                                *)
(*  Polishing Up the Tait-Martin Löf Proof of the                 *)
(*  Church-Rosser Theorem (1995).                                 *)

theory CR_Takahashi
  imports "../Nominal"
begin

atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

section \<open>Lemmas about Capture-Avoiding Substitution\<close>

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma forget:
  shows "x\<sharp>t \<Longrightarrow> t[x::=s] = t"
by (nominal_induct t avoiding: x s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

lemma substitution_lemma:
  assumes a: "x\<noteq>y" "x\<sharp>u"
  shows "t[x::=s][y::=u] = t[y::=u][x::=s[y::=u]]"
using a
by (nominal_induct t avoiding: x y s u rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

lemma subst_rename:
  assumes a: "y\<sharp>t"
  shows "t[x::=s] = ([(y,x)]\<bullet>t)[y::=s]"
using a
by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
   (auto simp add: swap_simps fresh_atm abs_fresh)

section \<open>Beta-Reduction\<close>

inductive
  "Beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
  b1[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> App t1 s \<longrightarrow>\<^sub>\<beta> App t2 s"
| b2[intro]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>\<beta> Lam [x].t2"
| b4[intro]: "App (Lam [x].t) s \<longrightarrow>\<^sub>\<beta> t[x::=s]"

section \<open>Transitive Closure of Beta\<close>

inductive
  "Beta_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta>\<^sup>* _" [80,80] 80)
where
  bs1[intro]: "t \<longrightarrow>\<^sub>\<beta>\<^sup>* t"
| bs2[intro]: "t \<longrightarrow>\<^sub>\<beta> s \<Longrightarrow> t \<longrightarrow>\<^sub>\<beta>\<^sup>* s"
| bs3[intro,trans]: "\<lbrakk>t1\<longrightarrow>\<^sub>\<beta>\<^sup>* t2; t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3\<rbrakk> \<Longrightarrow> t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3"

section \<open>One-Reduction\<close>

inductive
  One :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1 _" [80,80] 80)
where
  o1[intro]: "Var x\<longrightarrow>\<^sub>1 Var x"
| o2[intro]: "\<lbrakk>t1\<longrightarrow>\<^sub>1t2; s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> App t1 s1 \<longrightarrow>\<^sub>1 App t2 s2"
| o3[intro]: "t1\<longrightarrow>\<^sub>1t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>1 Lam [x].t2"
| o4[intro]: "\<lbrakk>x\<sharp>(s1,s2); t1\<longrightarrow>\<^sub>1t2; s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]"

equivariance One
nominal_inductive One
  by (simp_all add: abs_fresh fresh_fact)

lemma One_refl:
  shows "t \<longrightarrow>\<^sub>1 t"
by (nominal_induct t rule: lam.strong_induct) (auto)

lemma One_subst:
  assumes a: "t1 \<longrightarrow>\<^sub>1 t2" "s1 \<longrightarrow>\<^sub>1 s2"
  shows "t1[x::=s1] \<longrightarrow>\<^sub>1 t2[x::=s2]"
using a
by (nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct)
   (auto simp add: substitution_lemma fresh_atm fresh_fact)

lemma better_o4_intro:
  assumes a: "t1 \<longrightarrow>\<^sub>1 t2" "s1 \<longrightarrow>\<^sub>1 s2"
  shows "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp, blast)
  have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]\<bullet>t1)) s1" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>\<^sub>1  ([(y,x)]\<bullet>t2)[y::=s2]" using fs a by (auto simp add: One.eqvt)
  also have "\<dots> = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric])
  finally show "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]" by simp
qed

lemma One_Var:
  assumes a: "Var x \<longrightarrow>\<^sub>1 M"
  shows "M = Var x"
using a by (cases rule: One.cases) (simp_all)

lemma One_Lam:
  assumes a: "Lam [x].t \<longrightarrow>\<^sub>1 s" "x\<sharp>s"
  shows "\<exists>t'. s = Lam [x].t' \<and> t \<longrightarrow>\<^sub>1 t'"
using a
by (cases rule: One.strong_cases)
   (auto simp add: lam.inject abs_fresh alpha)

lemma One_App:
  assumes a: "App t s \<longrightarrow>\<^sub>1 r"
  shows "(\<exists>t' s'. r = App t' s' \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s') \<or>
         (\<exists>x p p' s'. r = p'[x::=s'] \<and> t = Lam [x].p \<and> p \<longrightarrow>\<^sub>1 p' \<and> s \<longrightarrow>\<^sub>1 s' \<and> x\<sharp>(s,s'))"
using a by (cases rule: One.cases) (auto simp add: lam.inject)

lemma One_Redex:
  assumes a: "App (Lam [x].t) s \<longrightarrow>\<^sub>1 r" "x\<sharp>(s,r)"
  shows "(\<exists>t' s'. r = App (Lam [x].t') s' \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s') \<or>
         (\<exists>t' s'. r = t'[x::=s'] \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s')"
using a
by (cases rule: One.strong_cases)
   (auto dest: One_Lam simp add: lam.inject abs_fresh alpha fresh_prod)

section \<open>Transitive Closure of One\<close>

inductive
  "One_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1\<^sup>* _" [80,80] 80)
where
  os1[intro]: "t \<longrightarrow>\<^sub>1\<^sup>* t"
| os2[intro]: "t \<longrightarrow>\<^sub>1 s \<Longrightarrow> t \<longrightarrow>\<^sub>1\<^sup>* s"
| os3[intro]: "\<lbrakk>t1\<longrightarrow>\<^sub>1\<^sup>* t2; t2 \<longrightarrow>\<^sub>1\<^sup>* t3\<rbrakk> \<Longrightarrow> t1 \<longrightarrow>\<^sub>1\<^sup>* t3"

section \<open>Complete Development Reduction\<close>

inductive
  Dev :: "lam \<Rightarrow> lam \<Rightarrow> bool" (" _ \<longrightarrow>\<^sub>d _" [80,80]80)
where
  d1[intro]: "Var x \<longrightarrow>\<^sub>d Var x"
| d2[intro]: "t \<longrightarrow>\<^sub>d s \<Longrightarrow> Lam [x].t \<longrightarrow>\<^sub>d Lam[x].s"
| d3[intro]: "\<lbrakk>\<not>(\<exists>y t'. t1 = Lam [y].t'); t1 \<longrightarrow>\<^sub>d t2; s1 \<longrightarrow>\<^sub>d s2\<rbrakk> \<Longrightarrow> App t1 s1 \<longrightarrow>\<^sub>d App t2 s2"
| d4[intro]: "\<lbrakk>x\<sharp>(s1,s2); t1 \<longrightarrow>\<^sub>d t2; s1 \<longrightarrow>\<^sub>d s2\<rbrakk> \<Longrightarrow> App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]"

equivariance Dev
nominal_inductive Dev
  by (simp_all add: abs_fresh fresh_fact)

lemma better_d4_intro:
  assumes a: "t1 \<longrightarrow>\<^sub>d t2" "s1 \<longrightarrow>\<^sub>d s2"
  shows "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp,blast)
  have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]\<bullet>t1)) s1" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>\<^sub>d  ([(y,x)]\<bullet>t2)[y::=s2]" using fs a by (auto simp add: Dev.eqvt)
  also have "\<dots> = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric])
  finally show "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]" by simp
qed

lemma Dev_preserves_fresh:
  fixes x::"name"
  assumes a: "M\<longrightarrow>\<^sub>d N"
  shows "x\<sharp>M \<Longrightarrow> x\<sharp>N"
using a
by (induct) (auto simp add: abs_fresh fresh_fact)

lemma Dev_Lam:
  assumes a: "Lam [x].M \<longrightarrow>\<^sub>d N"
  shows "\<exists>N'. N = Lam [x].N' \<and> M \<longrightarrow>\<^sub>d N'"
proof -
  from a have "x\<sharp>Lam [x].M" by (simp add: abs_fresh)
  with a have "x\<sharp>N" by (simp add: Dev_preserves_fresh)
  with a show "\<exists>N'. N = Lam [x].N' \<and> M \<longrightarrow>\<^sub>d N'"
    by (cases rule: Dev.strong_cases)
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma Development_existence:
  shows "\<exists>M'. M \<longrightarrow>\<^sub>d M'"
by (nominal_induct M rule: lam.strong_induct)
   (auto dest!: Dev_Lam intro: better_d4_intro)

lemma Triangle:
  assumes a: "t \<longrightarrow>\<^sub>d t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "t2 \<longrightarrow>\<^sub>1 t1"
using a
proof(nominal_induct avoiding: t2 rule: Dev.strong_induct)
  case (d4 x s1 s2 t1 t1' t2)
  have  fc: "x\<sharp>t2" "x\<sharp>s1" by fact+
  have "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2" by fact
  then obtain t' s' where reds:
             "(t2 = App (Lam [x].t') s' \<and> t1 \<longrightarrow>\<^sub>1 t' \<and> s1 \<longrightarrow>\<^sub>1 s') \<or>
              (t2 = t'[x::=s'] \<and> t1 \<longrightarrow>\<^sub>1 t' \<and> s1 \<longrightarrow>\<^sub>1 s')"
  using fc by (auto dest!: One_Redex)
  have ih1: "t1 \<longrightarrow>\<^sub>1 t' \<Longrightarrow>  t' \<longrightarrow>\<^sub>1 t1'" by fact
  have ih2: "s1 \<longrightarrow>\<^sub>1 s' \<Longrightarrow>  s' \<longrightarrow>\<^sub>1 s2" by fact
  { assume "t1 \<longrightarrow>\<^sub>1 t'" "s1 \<longrightarrow>\<^sub>1 s'"
    then have "App (Lam [x].t') s' \<longrightarrow>\<^sub>1 t1'[x::=s2]"
      using ih1 ih2 by (auto intro: better_o4_intro)
  }
  moreover
  { assume "t1 \<longrightarrow>\<^sub>1 t'" "s1 \<longrightarrow>\<^sub>1 s'"
    then have "t'[x::=s'] \<longrightarrow>\<^sub>1 t1'[x::=s2]"
      using ih1 ih2 by (auto intro: One_subst)
  }
  ultimately show "t2 \<longrightarrow>\<^sub>1 t1'[x::=s2]" using reds by auto
qed (auto dest!: One_Lam One_Var One_App)

lemma Diamond_for_One:
  assumes a: "t \<longrightarrow>\<^sub>1 t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "\<exists>t3. t2 \<longrightarrow>\<^sub>1 t3 \<and> t1 \<longrightarrow>\<^sub>1 t3"
proof -
  obtain tc where "t \<longrightarrow>\<^sub>d tc" using Development_existence by blast
  with a have "t2 \<longrightarrow>\<^sub>1 tc" and "t1 \<longrightarrow>\<^sub>1 tc" by (simp_all add: Triangle)
  then show "\<exists>t3. t2 \<longrightarrow>\<^sub>1 t3 \<and> t1 \<longrightarrow>\<^sub>1 t3" by blast
qed

lemma Rectangle_for_One:
  assumes a:  "t \<longrightarrow>\<^sub>1\<^sup>* t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "\<exists>t3. t1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3"
using a Diamond_for_One by (induct arbitrary: t2) (blast)+

lemma CR_for_One_star:
  assumes a: "t \<longrightarrow>\<^sub>1\<^sup>* t1" "t \<longrightarrow>\<^sub>1\<^sup>* t2"
    shows "\<exists>t3. t2 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> t1 \<longrightarrow>\<^sub>1\<^sup>* t3"
using a Rectangle_for_One by (induct arbitrary: t2) (blast)+

section \<open>Establishing the Equivalence of Beta-star and One-star\<close>

lemma Beta_Lam_cong:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "Lam [x].t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* Lam [x].t2"
using a by (induct) (blast)+

lemma Beta_App_cong_aux:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "App t1 s\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s"
    and "App s t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App s t2"
using a by (induct) (blast)+

lemma Beta_App_cong:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2" "s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* s2"
  shows "App t1 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2"
using a by (blast intro: Beta_App_cong_aux)

lemmas Beta_congs = Beta_Lam_cong Beta_App_cong

lemma One_implies_Beta_star:
  assumes a: "t \<longrightarrow>\<^sub>1 s"
  shows "t \<longrightarrow>\<^sub>\<beta>\<^sup>* s"
using a by (induct) (auto intro!: Beta_congs)

lemma One_congs:
  assumes a: "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
  shows "Lam [x].t1 \<longrightarrow>\<^sub>1\<^sup>* Lam [x].t2"
  and   "App t1 s \<longrightarrow>\<^sub>1\<^sup>* App t2 s"
  and   "App s t1 \<longrightarrow>\<^sub>1\<^sup>* App s t2"
using a by (induct) (auto intro: One_refl)

lemma Beta_implies_One_star:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta> t2"
  shows "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
using a by (induct) (auto intro: One_refl One_congs better_o4_intro)

lemma Beta_star_equals_One_star:
  shows "t1 \<longrightarrow>\<^sub>1\<^sup>* t2 = t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
proof
  assume "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
  then show "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2" by (induct) (auto intro: One_implies_Beta_star)
next
  assume "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  then show "t1 \<longrightarrow>\<^sub>1\<^sup>* t2" by (induct) (auto intro: Beta_implies_One_star)
qed

section \<open>The Church-Rosser Theorem\<close>

theorem CR_for_Beta_star:
  assumes a: "t \<longrightarrow>\<^sub>\<beta>\<^sup>* t1" "t\<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "\<exists>t3. t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3"
proof -
  from a have "t \<longrightarrow>\<^sub>1\<^sup>* t1" and "t\<longrightarrow>\<^sub>1\<^sup>* t2" by (simp_all add: Beta_star_equals_One_star)
  then have "\<exists>t3. t1 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by (simp add: CR_for_One_star)
  then show "\<exists>t3. t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3" by (simp add: Beta_star_equals_One_star)
qed

end


header {* Implementation of Dijkstra's-Algorithm using the ICF *}
theory Dijkstra_Impl
imports
  Dijkstra
  GraphSpec
  HashGraphImpl
  "~~/src/HOL/Library/Code_Target_Numeral"
begin
text{*
  In this second refinement step, we use interfaces from the
  Isabelle Collection Framework (ICF) to implement the priority queue and
  the result map. Moreover, we use a graph interface (that is not contained
  in the ICF, but in this development) to represent the graph.

  The data types of the first refinement step were designed to fit the
  abstract data types of the used ICF-interfaces, which makes this refinement
  quite straightforward.

  Finally, we instantiate the ICF-interfaces by concrete implementations,
  obtaining an executable algorithm, for that we generate code using
  Isabelle/HOL's code generator.
*}

locale dijkstraC =
  g!: StdGraph g_ops +
  mr!: StdMap mr_ops +
  qw!: StdUprio qw_ops
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
begin
  definition "\<alpha>sc == map_prod qw.\<alpha> mr.\<alpha>"
  definition "dinvarC_add == \<lambda>(wl,res). qw.invar wl \<and> mr.invar res"

  definition cdinit :: "'G \<Rightarrow> 'V \<Rightarrow> ('qw\<times>'mr) nres" where
    "cdinit g v0 \<equiv> do {
      wl \<leftarrow> FOREACH (nodes (g.\<alpha> g))
        (\<lambda>v wl. RETURN (qw.insert wl v Weight.Infty)) (qw.empty ());
      RETURN (qw.insert wl v0 (Num 0),mr.sng v0 ([],0))
    }"

  definition cpop_min :: "('qw\<times>'mr) \<Rightarrow> ('V\<times>'W infty\<times>('qw\<times>'mr)) nres" where
    "cpop_min \<sigma> \<equiv> do {
      let (wl,res) = \<sigma>;
      let (v,w,wl')=qw.pop wl;
      RETURN (v,w,(wl',res))
    }"

  definition cupdate :: "'G \<Rightarrow> 'V \<Rightarrow> 'W infty \<Rightarrow> ('qw\<times>'mr) \<Rightarrow> ('qw\<times>'mr) nres"
    where
    "cupdate g v wv \<sigma> = do {
      ASSERT (dinvarC_add \<sigma>);
      let (wl,res)=\<sigma>;
      let pv=mpath' (mr.lookup v res);
      FOREACH (succ (g.\<alpha> g) v) (\<lambda>(w',v') (wl,res).
        if (wv + Num w' < mpath_weight' (mr.lookup v' res)) then do {
          RETURN (qw.insert wl v' (wv+Num w'),
                  mr.update v' ((v,w',v')#the pv,val wv + w') res)
        } else RETURN (wl,res)
      ) (wl,res)
    }"

  definition cdijkstra where
    "cdijkstra g v0 \<equiv> do {
      \<sigma>0 \<leftarrow> cdinit g v0;
      (_,res) \<leftarrow> WHILE\<^sub>T (\<lambda>(wl,_). \<not> qw.isEmpty wl)
            (\<lambda>\<sigma>. do { (v,wv,\<sigma>') \<leftarrow> cpop_min \<sigma>; cupdate g v wv \<sigma>' } )
            \<sigma>0;
      RETURN res
    }"

end

locale dijkstraC_fixg = dijkstraC g_ops mr_ops qw_ops +
  Dijkstra ga v0
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
  and ga :: "('V,'W) graph"
  and v0 :: 'V +
  fixes g :: 'G
  assumes g_rel: "(g,ga)\<in>br g.\<alpha> g.invar"
begin
  schematic_lemma cdinit_refines:
    notes [refine] = inj_on_id
    shows "cdinit g v0 \<le>\<Down>?R mdinit"
    using g_rel
    unfolding cdinit_def mdinit_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp_all add: \<alpha>sc_def dinvarC_add_def refine_rel_defs
      qw.correct mr.correct refine_hsimp)
    done

  schematic_lemma cpop_min_refines:
    "(\<sigma>,\<sigma>') \<in> build_rel \<alpha>sc dinvarC_add
      \<Longrightarrow> cpop_min \<sigma> \<le> \<Down>?R (mpop_min \<sigma>')"
    unfolding cpop_min_def mpop_min_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp add: \<alpha>sc_def dinvarC_add_def refine_hsimp refine_rel_defs)
    apply (simp add: \<alpha>sc_def dinvarC_add_def refine_hsimp refine_rel_defs)
    done

  schematic_lemma cupdate_refines:
    notes [refine] = inj_on_id
    shows "(\<sigma>,\<sigma>')\<in>build_rel \<alpha>sc dinvarC_add \<Longrightarrow> v=v' \<Longrightarrow> wv=wv' \<Longrightarrow>
    cupdate g v wv \<sigma> \<le> \<Down>?R (mupdate v' wv' \<sigma>')"
    unfolding cupdate_def mupdate_def
    using g_rel
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp_all add: \<alpha>sc_def dinvarC_add_def refine_rel_defs
      qw.correct mr.correct refine_hsimp)
    done

  lemma cdijkstra_refines:
    "cdijkstra g v0 \<le> \<Down>(build_rel mr.\<alpha> mr.invar) mdijkstra"
  proof -
    note [refine] = cdinit_refines cpop_min_refines cupdate_refines
    show ?thesis
      unfolding cdijkstra_def mdijkstra_def
      using g_rel
      apply (refine_rcg)

      apply (auto
        split: prod.split prod.split_asm
        simp add: qw.correct mr.correct dinvarC_add_def \<alpha>sc_def refine_hsimp
          refine_rel_defs)
      done
  qed
end

context dijkstraC
begin

  thm g.nodes_it_is_iterator

  schematic_lemma idijkstra_refines_aux:
    assumes "g.invar g"
    shows "RETURN ?f \<le> cdijkstra g v0"
    using assms
    unfolding cdijkstra_def cdinit_def cpop_min_def cupdate_def
    apply (refine_transfer)
    done

  concrete_definition idijkstra for g ?v0.0 uses idijkstra_refines_aux

  lemma idijkstra_refines:
    assumes "g.invar g"
    shows "RETURN (idijkstra g v0) \<le> cdijkstra g v0"
    using assms
    by (rule idijkstra.refine)

end

text {*
  The following theorem states correctness of the algorithm independent
  from the refinement framework.

  Intuitively, the first goal states that the abstraction of the returned
  result is correct, the second goal states that the result
  datastructure satisfies its invariant, and the third goal states
  that the cached weights in the returned result are correct.

  Note that this is the main theorem for a user of Dijkstra's algorithm in some
  bigger context. It may also be specialized for concrete instances of the
  implementation, as exemplarily done below.
  *}
theorem (in dijkstraC_fixg) idijkstra_correct:
  shows
  "weighted_graph.is_shortest_path_map ga v0 (\<alpha>r (mr.\<alpha> (idijkstra g v0)))"
    (is ?G1)
  and "mr.invar (idijkstra g v0)" (is ?G2)
  and "Dijkstra.res_invarm (mr.\<alpha> (idijkstra g v0))" (is ?G3)
proof -
  from g_rel have I: "g.invar g" by (simp add: refine_rel_defs)

  note idijkstra_refines[OF I]
  also note cdijkstra_refines
  also note mdijkstra_refines
  finally have Z: "RETURN (idijkstra g v0) \<le>
    \<Down>(build_rel (\<alpha>r \<circ> mr.\<alpha>) (\<lambda>m. mr.invar m \<and> res_invarm (mr.\<alpha> m)))
      dijkstra'"
    apply (subst (asm) conc_fun_chain)
    apply rule
    apply (simp only: br_chain)
    done
  also note dijkstra'_refines[simplified]
  also note dijkstra_correct
  finally show ?G1 ?G2 ?G3
    by (auto elim: RETURN_ref_SPECD simp: refine_rel_defs)
qed

theorem (in dijkstraC) idijkstra_correct:
  assumes INV: "g.invar g"
  assumes V0: "v0 \<in> nodes (g.\<alpha> g)"
  assumes nonneg_weights: "\<And>v w v'. (v,w,v')\<in>edges (g.\<alpha> g) \<Longrightarrow> 0\<le>w"
  shows
  "weighted_graph.is_shortest_path_map (g.\<alpha> g) v0
      (Dijkstra.\<alpha>r (mr.\<alpha> (idijkstra g v0)))" (is ?G1)
  and "Dijkstra.res_invarm (mr.\<alpha> (idijkstra g v0))" (is ?G2)
proof -
  interpret gv!: valid_graph "g.\<alpha> g" using g.valid INV .

  interpret dcg: dijkstraC_fixg g_ops mr_ops qw_ops "g.\<alpha> g" v0 g
    apply (rule dijkstraC_fixg.intro)
    apply unfold_locales
    apply (simp_all add: hlg.finite INV V0 hlg_ops_def
      nonneg_weights refine_rel_defs)
    done

  from dcg.idijkstra_correct show ?G1 ?G2 by simp_all
qed

text {*
  Example instantiation with HashSet.based graph,
  red-black-tree based result map, and finger-tree based priority queue.
*}
setup Locale_Code.open_block
interpretation hrf!: dijkstraC hlg_ops rm_ops aluprioi_ops
  by unfold_locales
setup Locale_Code.close_block

definition "hrf_dijkstra \<equiv> hrf.idijkstra"
lemmas hrf_dijkstra_correct = hrf.idijkstra_correct[folded hrf_dijkstra_def]

export_code hrf_dijkstra in SML
export_code hrf_dijkstra in OCaml
export_code hrf_dijkstra in Haskell
export_code hrf_dijkstra in Scala

definition hrfn_dijkstra :: "(nat,nat) hlg \<Rightarrow> _"
  where "hrfn_dijkstra \<equiv> hrf_dijkstra"

export_code hrfn_dijkstra in SML

lemmas hrfn_dijkstra_correct =
  hrf_dijkstra_correct[where ?'a = nat and ?'b = nat, folded hrfn_dijkstra_def]

term hrfn_dijkstra
term hlg.from_list

definition "test_hrfn_dijkstra
  \<equiv> rm.to_list
    (hrfn_dijkstra (hlg.from_list ([0..<4],[(0,3,1),(0,4,2),(2,1,3),(1,4,3)])) 0)"

ML_val {*
  @{code test_hrfn_dijkstra}

*}

end


(*  Title:      HOL/Import/HOL_Light_Maps.thy
    Author:     Cezary Kaliszyk, University of Innsbruck
    Author:     Alexander Krauss, QAware GmbH

Based on earlier code by Steven Obua and Sebastian Skalberg
*)

section \<open>Type and constant mappings of HOL Light importer\<close>

theory HOL_Light_Maps
imports Import_Setup
begin

lemma [import_const T]:
  "True = ((\<lambda>p :: bool. p) = (\<lambda>p. p))"
  by simp

lemma [import_const "/\\"]:
  "(\<and>) = (\<lambda>p q. (\<lambda>f. f p q :: bool) = (\<lambda>f. f True True))"
  by metis

lemma [import_const "==>"]:
  "(\<longrightarrow>) = (\<lambda>(p::bool) q::bool. (p \<and> q) = p)"
  by auto

lemma [import_const "!"]:
  "All = (\<lambda>P::'A \<Rightarrow> bool. P = (\<lambda>x::'A. True))"
  by auto

lemma [import_const "?"]:
  "Ex = (\<lambda>P::'A \<Rightarrow> bool. All (\<lambda>q::bool. (All (\<lambda>x::'A::type. (P x) \<longrightarrow> q)) \<longrightarrow> q))"
  by auto

lemma [import_const "\\/"]:
  "(\<or>) = (\<lambda>p q. \<forall>r. (p \<longrightarrow> r) \<longrightarrow> (q \<longrightarrow> r) \<longrightarrow> r)"
  by auto

lemma [import_const F]:
  "False = (\<forall>p. p)"
  by auto

lemma [import_const "~"]:
  "Not = (\<lambda>p. p \<longrightarrow> False)"
  by simp

lemma [import_const "?!"]:
  "Ex1 = (\<lambda>P::'A \<Rightarrow> bool. Ex P \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> x = y))"
  by auto

lemma [import_const "_FALSITY_"]: "False = False"
  by simp

lemma hl_ax1: "\<forall>t::'A \<Rightarrow> 'B. (\<lambda>x. t x) = t"
  by metis

lemma hl_ax2: "\<forall>P x::'A. P x \<longrightarrow> P (Eps P)"
  by (auto intro: someI)

lemma [import_const COND]:
  "If = (\<lambda>t (t1 :: 'A) t2. SOME x. (t = True \<longrightarrow> x = t1) \<and> (t = False \<longrightarrow> x = t2))"
  unfolding fun_eq_iff by auto

lemma [import_const o]:
  "(\<circ>) = (\<lambda>(f::'B \<Rightarrow> 'C) g x::'A. f (g x))"
  unfolding fun_eq_iff by simp

lemma [import_const I]: "id = (\<lambda>x::'A. x)"
  by auto

lemma [import_type 1 one_ABS one_REP]:
  "type_definition Rep_unit Abs_unit (Collect (\<lambda>b. b))"
  by (metis (full_types) Collect_cong singleton_conv2 type_definition_unit)

lemma [import_const one]: "() = (SOME x::unit. True)"
  by auto

lemma [import_const mk_pair]:
  "Pair_Rep = (\<lambda>(x::'A) (y::'B) (a::'A) b::'B. a = x \<and> b = y)"
  by (simp add: Pair_Rep_def fun_eq_iff)

lemma [import_type prod ABS_prod REP_prod]:
  "type_definition Rep_prod Abs_prod (Collect (\<lambda>x::'A \<Rightarrow> 'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b))"
  using type_definition_prod[unfolded Product_Type.prod_def] by simp

lemma [import_const ","]: "Pair = (\<lambda>(x::'A) y::'B. Abs_prod (Pair_Rep x y))"
  by (metis Pair_def)

lemma [import_const FST]:
  "fst = (\<lambda>p::'A \<times> 'B. SOME x::'A. \<exists>y::'B. p = (x, y))"
  by auto

lemma [import_const SND]:
  "snd = (\<lambda>p::'A \<times> 'B. SOME y::'B. \<exists>x::'A. p = (x, y))"
  by auto

lemma CURRY_DEF[import_const CURRY]:
  "curry = (\<lambda>(f::'A \<times> 'B \<Rightarrow> 'C) x y. f (x, y))"
  using curry_def .

lemma [import_const ONE_ONE : inj]:
  "inj = (\<lambda>(f::'A \<Rightarrow> 'B). \<forall>x1 x2. f x1 = f x2 \<longrightarrow> x1 = x2)"
  by (auto simp add: fun_eq_iff inj_on_def)

lemma [import_const ONTO : surj]:
  "surj = (\<lambda>(f::'A \<Rightarrow> 'B). \<forall>y. \<exists>x. y = f x)"
  by (auto simp add: fun_eq_iff)

lemma hl_ax3: "\<exists>f::ind \<Rightarrow> ind. inj f \<and> \<not> surj f"
  by (rule_tac x="Suc_Rep" in exI)
     (metis Suc_Rep_inject' injI Suc_Rep_not_Zero_Rep surjD)

import_type_map num : nat
import_const_map "_0" : zero_class.zero
import_const_map SUC : Suc

lemma NOT_SUC: "\<forall>n. Suc n \<noteq> 0"
  by simp

lemma SUC_INJ: "\<forall>m n. (Suc m = Suc n) = (m = n)"
  by simp

lemma num_INDUCTION:
  "\<forall>P. P 0 \<and> (\<forall>n. P n \<longrightarrow> P (Suc n)) \<longrightarrow> (\<forall>n. P n)"
  by (auto intro: nat.induct)

lemma [import_const NUMERAL]: "id = (\<lambda>x :: nat. x)"
  by auto

definition [simp]: "bit0 n = 2 * n"

lemma [import_const BIT0]:
  "bit0 = (SOME fn. fn (id 0) = id 0 \<and> (\<forall>n. fn (Suc n) = Suc (Suc (fn n))))"
  apply (auto intro!: some_equality[symmetric])
  apply (auto simp add: fun_eq_iff)
  apply (induct_tac x)
  apply auto
  done

definition [import_const BIT1, simp]:
  "bit1 = (\<lambda>x. Suc (bit0 x))"

definition [simp]: "pred n = n - 1"

lemma PRE[import_const PRE : pred]:
  "pred (id (0::nat)) = id (0::nat) \<and> (\<forall>n::nat. pred (Suc n) = n)"
  by simp

lemma ADD[import_const "+" : plus]:
  "(\<forall>n :: nat. (id 0) + n = n) \<and> (\<forall>m n. (Suc m) + n = Suc (m + n))"
  by simp

lemma MULT[import_const "*" : times]:
  "(\<forall>n :: nat. (id 0) * n = id 0) \<and> (\<forall>m n. (Suc m) * n = (m * n) + n)"
  by simp

lemma EXP[import_const EXP : power]:
  "(\<forall>m. m ^ (id 0) = id (bit1 0)) \<and> (\<forall>(m :: nat) n. m ^ (Suc n) = m * (m ^ n))"
  by simp

lemma LE[import_const "<=" : less_eq]:
  "(\<forall>m :: nat. m \<le> (id 0) = (m = id 0)) \<and> (\<forall>m n. m \<le> (Suc n) = (m = Suc n \<or> m \<le> n))"
  by auto

lemma LT[import_const "<" : less]:
  "(\<forall>m :: nat. m < (id 0) = False) \<and> (\<forall>m n. m < (Suc n) = (m = n \<or> m < n))"
  by auto

lemma DEF_GE[import_const ">=" : greater_eq]:
  "(\<ge>) = (\<lambda>x y :: nat. y \<le> x)"
  by simp

lemma DEF_GT[import_const ">" : greater]:
  "(>) = (\<lambda>x y :: nat. y < x)"
  by simp

lemma DEF_MAX[import_const "MAX"]:
  "max = (\<lambda>x y :: nat. if x \<le> y then y else x)"
  by (simp add: fun_eq_iff)

lemma DEF_MIN[import_const "MIN"]:
  "min = (\<lambda>x y :: nat. if x \<le> y then x else y)"
  by (simp add: fun_eq_iff)

definition even
where
  "even = Parity.even"

lemma EVEN[import_const "EVEN" : even]:
  "even (id 0::nat) = True \<and> (\<forall>n. even (Suc n) = (\<not> even n))"
  by (simp add: even_def)

lemma SUB[import_const "-" : minus]:
  "(\<forall>m::nat. m - (id 0) = m) \<and> (\<forall>m n. m - (Suc n) = pred (m - n))"
  by simp

lemma FACT[import_const "FACT" : fact]:
  "fact (id 0) = id (bit1 0) \<and> (\<forall>n. fact (Suc n) = Suc n * fact n)"
  by simp

import_const_map MOD : modulo
import_const_map DIV : divide

lemma DIVISION_0:
  "\<forall>m n::nat. if n = id 0 then m div n = id 0 \<and> m mod n = m else m = m div n * n + m mod n \<and> m mod n < n"
  by simp

lemmas [import_type sum "_dest_sum" "_mk_sum"] = type_definition_sum[where 'a="'A" and 'b="'B"]
import_const_map INL : Inl
import_const_map INR : Inr

lemma sum_INDUCT:
  "\<forall>P. (\<forall>a :: 'A. P (Inl a)) \<and> (\<forall>a :: 'B. P (Inr a)) \<longrightarrow> (\<forall>x. P x)"
  by (auto intro: sum.induct)

lemma sum_RECURSION:
  "\<forall>Inl' Inr'. \<exists>fn. (\<forall>a :: 'A. fn (Inl a) = (Inl' a :: 'Z)) \<and> (\<forall>a :: 'B. fn (Inr a) = Inr' a)"
  by (intro allI, rule_tac x="case_sum Inl' Inr'" in exI) auto

lemma OUTL[import_const "OUTL" : projl]:
  "Sum_Type.projl (Inl x) = x"
  by simp

lemma OUTR[import_const "OUTR" : projr]:
  "Sum_Type.projr (Inr y) = y"
  by simp

import_type_map list : list
import_const_map NIL : Nil
import_const_map CONS : Cons

lemma list_INDUCT:
  "\<forall>P::'A list \<Rightarrow> bool. P [] \<and> (\<forall>a0 a1. P a1 \<longrightarrow> P (a0 # a1)) \<longrightarrow> (\<forall>x. P x)"
  using list.induct by auto

lemma list_RECURSION:
 "\<forall>nil' cons'. \<exists>fn::'A list \<Rightarrow> 'Z. fn [] = nil' \<and> (\<forall>(a0::'A) a1::'A list. fn (a0 # a1) = cons' a0 a1 (fn a1))"
  by (intro allI, rule_tac x="rec_list nil' cons'" in exI) auto

lemma HD[import_const HD : hd]:
  "hd ((h::'A) # t) = h"
  by simp

lemma TL[import_const TL : tl]:
  "tl ((h::'A) # t) = t"
  by simp

lemma APPEND[import_const APPEND : append]:
  "(\<forall>l::'A list. [] @ l = l) \<and> (\<forall>(h::'A) t l. (h # t) @ l = h # t @ l)"
  by simp

lemma REVERSE[import_const REVERSE : rev]:
  "rev [] = ([] :: 'A list) \<and> rev ((x::'A) # l) = rev l @ [x]"
  by simp

lemma LENGTH[import_const LENGTH : length]:
  "length ([] :: 'A list) = id 0 \<and> (\<forall>(h::'A) t. length (h # t) = Suc (length t))"
  by simp

lemma MAP[import_const MAP : map]:
  "(\<forall>f::'A \<Rightarrow> 'B. map f [] = []) \<and>
       (\<forall>(f::'A \<Rightarrow> 'B) h t. map f (h # t) = f h # map f t)"
  by simp

lemma LAST[import_const LAST : last]:
  "last ((h::'A) # t) = (if t = [] then h else last t)"
  by simp

lemma BUTLAST[import_const BUTLAST : butlast]:
    "butlast [] = ([] :: 't18337 list) \<and>
     butlast ((h :: 't18337) # t) = (if t = [] then [] else h # butlast t)"
  by simp

lemma REPLICATE[import_const REPLICATE : replicate]:
  "replicate (id (0::nat)) (x::'t18358) = [] \<and>
   replicate (Suc n) x = x # replicate n x"
  by simp

lemma NULL[import_const NULL : List.null]:
  "List.null ([]::'t18373 list) = True \<and> List.null ((h::'t18373) # t) = False"
  unfolding null_def by simp

lemma ALL[import_const ALL : list_all]:
  "list_all (P::'t18393 \<Rightarrow> bool) [] = True \<and>
  list_all P (h # t) = (P h \<and> list_all P t)"
  by simp

lemma EX[import_const EX : list_ex]:
  "list_ex (P::'t18414 \<Rightarrow> bool) [] = False \<and>
  list_ex P (h # t) = (P h \<or> list_ex P t)"
  by simp

lemma ITLIST[import_const ITLIST : foldr]:
  "foldr (f::'t18437 \<Rightarrow> 't18436 \<Rightarrow> 't18436) [] b = b \<and>
  foldr f (h # t) b = f h (foldr f t b)"
  by simp

lemma ALL2_DEF[import_const ALL2 : list_all2]:
  "list_all2 (P::'t18495 \<Rightarrow> 't18502 \<Rightarrow> bool) [] (l2::'t18502 list) = (l2 = []) \<and>
  list_all2 P ((h1::'t18495) # (t1::'t18495 list)) l2 =
  (if l2 = [] then False else P h1 (hd l2) \<and> list_all2 P t1 (tl l2))"
  by simp (induct_tac l2, simp_all)

lemma FILTER[import_const FILTER : filter]:
  "filter (P::'t18680 \<Rightarrow> bool) [] = [] \<and>
  filter P ((h::'t18680) # t) = (if P h then h # filter P t else filter P t)"
  by simp

lemma ZIP[import_const ZIP : zip]:
 "zip [] [] = ([] :: ('t18824 \<times> 't18825) list) \<and>
  zip ((h1::'t18849) # t1) ((h2::'t18850) # t2) = (h1, h2) # zip t1 t2"
  by simp

lemma WF[import_const WF : wfP]:
  "\<forall>u. wfP u \<longleftrightarrow> (\<forall>P. (\<exists>x :: 'A. P x) \<longrightarrow> (\<exists>x. P x \<and> (\<forall>y. u y x \<longrightarrow> \<not> P y)))"
proof (intro allI iffI impI wfI_min[to_pred], elim exE wfE_min[to_pred])
  fix x :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and xa :: "'a" and Q
  assume a: "xa \<in> Q"
  assume "\<forall>P. Ex P \<longrightarrow> (\<exists>xa. P xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> P y))"
  then have "Ex (\<lambda>x. x \<in> Q) \<longrightarrow> (\<exists>xa. (\<lambda>x. x \<in> Q) xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> (\<lambda>x. x \<in> Q) y))" by auto
  then show "\<exists>z\<in>Q. \<forall>y. x y z \<longrightarrow> y \<notin> Q" using a by auto
next
  fix x P and xa :: 'A and z
  assume "P xa" "z \<in> {a. P a}" "\<And>y. x y z \<Longrightarrow> y \<notin> {a. P a}"
  then show "\<exists>xa. P xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> P y)" by auto
qed auto

end


(*  Title:      ZF/Bin.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

   The sign Pls stands for an infinite string of leading 0's.
   The sign Min stands for an infinite string of leading 1's.

A number can have multiple representations, namely leading 0's with sign
Pls and leading 1's with sign Min.  See twos-compl.ML/int_of_binary for
the numerical interpretation.

The representation expects that (m mod 2) is 0 or 1, even if m is negative;
For instance, \<not>5 div 2 = \<not>3 and \<not>5 mod 2 = 1; thus \<not>5 = (\<not>3)*2 + 1
*)

section\<open>Arithmetic on Binary Integers\<close>

theory Bin
imports Int Datatype
begin

consts  bin :: i
datatype
  "bin" = Pls
        | Min
        | Bit ("w \<in> bin", "b \<in> bool")     (infixl \<open>BIT\<close> 90)

consts
  integ_of  :: "i\<Rightarrow>i"
  NCons     :: "[i,i]\<Rightarrow>i"
  bin_succ  :: "i\<Rightarrow>i"
  bin_pred  :: "i\<Rightarrow>i"
  bin_minus :: "i\<Rightarrow>i"
  bin_adder :: "i\<Rightarrow>i"
  bin_mult  :: "[i,i]\<Rightarrow>i"

primrec
  integ_of_Pls:  "integ_of (Pls)     = $# 0"
  integ_of_Min:  "integ_of (Min)     = $-($#1)"
  integ_of_BIT:  "integ_of (w BIT b) = $#b $+ integ_of(w) $+ integ_of(w)"

    (** recall that cond(1,b,c)=b and cond(0,b,c)=0 **)

primrec (*NCons adds a bit, suppressing leading 0s and 1s*)
  NCons_Pls: "NCons (Pls,b)     = cond(b,Pls BIT b,Pls)"
  NCons_Min: "NCons (Min,b)     = cond(b,Min,Min BIT b)"
  NCons_BIT: "NCons (w BIT c,b) = w BIT c BIT b"

primrec (*successor.  If a BIT, can change a 0 to a 1 without recursion.*)
  bin_succ_Pls:  "bin_succ (Pls)     = Pls BIT 1"
  bin_succ_Min:  "bin_succ (Min)     = Pls"
  bin_succ_BIT:  "bin_succ (w BIT b) = cond(b, bin_succ(w) BIT 0, NCons(w,1))"

primrec (*predecessor*)
  bin_pred_Pls:  "bin_pred (Pls)     = Min"
  bin_pred_Min:  "bin_pred (Min)     = Min BIT 0"
  bin_pred_BIT:  "bin_pred (w BIT b) = cond(b, NCons(w,0), bin_pred(w) BIT 1)"

primrec (*unary negation*)
  bin_minus_Pls:
    "bin_minus (Pls)       = Pls"
  bin_minus_Min:
    "bin_minus (Min)       = Pls BIT 1"
  bin_minus_BIT:
    "bin_minus (w BIT b) = cond(b, bin_pred(NCons(bin_minus(w),0)),
                                bin_minus(w) BIT 0)"

primrec (*sum*)
  bin_adder_Pls:
    "bin_adder (Pls)     = (\<lambda>w\<in>bin. w)"
  bin_adder_Min:
    "bin_adder (Min)     = (\<lambda>w\<in>bin. bin_pred(w))"
  bin_adder_BIT:
    "bin_adder (v BIT x) =
       (\<lambda>w\<in>bin.
         bin_case (v BIT x, bin_pred(v BIT x),
                   \<lambda>w y. NCons(bin_adder (v) ` cond(x and y, bin_succ(w), w),
                               x xor y),
                   w))"

(*The bin_case above replaces the following mutually recursive function:
primrec
  "adding (v,x,Pls)     = v BIT x"
  "adding (v,x,Min)     = bin_pred(v BIT x)"
  "adding (v,x,w BIT y) = NCons(bin_adder (v, cond(x and y, bin_succ(w), w)),
                                x xor y)"
*)

definition
  bin_add   :: "[i,i]\<Rightarrow>i"  where
    "bin_add(v,w) \<equiv> bin_adder(v)`w"

primrec
  bin_mult_Pls:
    "bin_mult (Pls,w)     = Pls"
  bin_mult_Min:
    "bin_mult (Min,w)     = bin_minus(w)"
  bin_mult_BIT:
    "bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
                                 NCons(bin_mult(v,w),0))"

syntax
  "_Int0" :: i  (\<open>#' 0\<close>)
  "_Int1" :: i  (\<open>#' 1\<close>)
  "_Int2" :: i  (\<open>#' 2\<close>)
  "_Neg_Int1" :: i  (\<open>#-' 1\<close>)
  "_Neg_Int2" :: i  (\<open>#-' 2\<close>)
translations
  "#0" \<rightleftharpoons> "CONST integ_of(CONST Pls)"
  "#1" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1)"
  "#2" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1 BIT 0)"
  "#-1" \<rightleftharpoons> "CONST integ_of(CONST Min)"
  "#-2" \<rightleftharpoons> "CONST integ_of(CONST Min BIT 0)"

syntax
  "_Int" :: "num_token \<Rightarrow> i"  (\<open>#_\<close> 1000)
  "_Neg_Int" :: "num_token \<Rightarrow> i"  (\<open>#-_\<close> 1000)

ML_file \<open>Tools/numeral_syntax.ML\<close>

declare bin.intros [simp,TC]

lemma NCons_Pls_0: "NCons(Pls,0) = Pls"
by simp

lemma NCons_Pls_1: "NCons(Pls,1) = Pls BIT 1"
by simp

lemma NCons_Min_0: "NCons(Min,0) = Min BIT 0"
by simp

lemma NCons_Min_1: "NCons(Min,1) = Min"
by simp

lemma NCons_BIT: "NCons(w BIT x,b) = w BIT x BIT b"
by (simp add: bin.case_eqns)

lemmas NCons_simps [simp] =
    NCons_Pls_0 NCons_Pls_1 NCons_Min_0 NCons_Min_1 NCons_BIT

(** Type checking **)

lemma integ_of_type [TC]: "w \<in> bin \<Longrightarrow> integ_of(w) \<in> int"
apply (induct_tac "w")
apply (simp_all add: bool_into_nat)
done

lemma NCons_type [TC]: "\<lbrakk>w \<in> bin; b \<in> bool\<rbrakk> \<Longrightarrow> NCons(w,b) \<in> bin"
by (induct_tac "w", auto)

lemma bin_succ_type [TC]: "w \<in> bin \<Longrightarrow> bin_succ(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_pred_type [TC]: "w \<in> bin \<Longrightarrow> bin_pred(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_minus_type [TC]: "w \<in> bin \<Longrightarrow> bin_minus(w) \<in> bin"
by (induct_tac "w", auto)

(*This proof is complicated by the mutual recursion*)
lemma bin_add_type [rule_format]:
     "v \<in> bin \<Longrightarrow> \<forall>w\<in>bin. bin_add(v,w) \<in> bin"
  unfolding bin_add_def
apply (induct_tac "v")
apply (rule_tac [3] ballI)
apply (rename_tac [3] "w'")
apply (induct_tac [3] "w'")
apply (simp_all add: NCons_type)
done

declare bin_add_type [TC]

lemma bin_mult_type [TC]: "\<lbrakk>v \<in> bin; w \<in> bin\<rbrakk> \<Longrightarrow> bin_mult(v,w) \<in> bin"
by (induct_tac "v", auto)

subsubsection\<open>The Carry and Borrow Functions,
            \<^term>\<open>bin_succ\<close> and \<^term>\<open>bin_pred\<close>\<close>

(*NCons preserves the integer value of its argument*)
lemma integ_of_NCons [simp]:
     "\<lbrakk>w \<in> bin; b \<in> bool\<rbrakk> \<Longrightarrow> integ_of(NCons(w,b)) = integ_of(w BIT b)"
apply (erule bin.cases)
apply (auto elim!: boolE)
done

lemma integ_of_succ [simp]:
     "w \<in> bin \<Longrightarrow> integ_of(bin_succ(w)) = $#1 $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

lemma integ_of_pred [simp]:
     "w \<in> bin \<Longrightarrow> integ_of(bin_pred(w)) = $- ($#1) $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

subsubsection\<open>\<^term>\<open>bin_minus\<close>: Unary Negation of Binary Integers\<close>

lemma integ_of_minus: "w \<in> bin \<Longrightarrow> integ_of(bin_minus(w)) = $- integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac zminus_zadd_distrib  elim!: boolE)
done

subsubsection\<open>\<^term>\<open>bin_add\<close>: Binary Addition\<close>

lemma bin_add_Pls [simp]: "w \<in> bin \<Longrightarrow> bin_add(Pls,w) = w"
by (unfold bin_add_def, simp)

lemma bin_add_Pls_right: "w \<in> bin \<Longrightarrow> bin_add(w,Pls) = w"
  unfolding bin_add_def
apply (erule bin.induct, auto)
done

lemma bin_add_Min [simp]: "w \<in> bin \<Longrightarrow> bin_add(Min,w) = bin_pred(w)"
by (unfold bin_add_def, simp)

lemma bin_add_Min_right: "w \<in> bin \<Longrightarrow> bin_add(w,Min) = bin_pred(w)"
  unfolding bin_add_def
apply (erule bin.induct, auto)
done

lemma bin_add_BIT_Pls [simp]: "bin_add(v BIT x,Pls) = v BIT x"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_Min [simp]: "bin_add(v BIT x,Min) = bin_pred(v BIT x)"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_BIT [simp]:
     "\<lbrakk>w \<in> bin;  y \<in> bool\<rbrakk>
      \<Longrightarrow> bin_add(v BIT x, w BIT y) =
          NCons(bin_add(v, cond(x and y, bin_succ(w), w)), x xor y)"
by (unfold bin_add_def, simp)

lemma integ_of_add [rule_format]:
     "v \<in> bin \<Longrightarrow>
          \<forall>w\<in>bin. integ_of(bin_add(v,w)) = integ_of(v) $+ integ_of(w)"
apply (erule bin.induct, simp, simp)
apply (rule ballI)
apply (induct_tac "wa")
apply (auto simp add: zadd_ac elim!: boolE)
done

(*Subtraction*)
lemma diff_integ_of_eq:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $- integ_of(w) = integ_of(bin_add (v, bin_minus(w)))"
  unfolding zdiff_def
apply (simp add: integ_of_add integ_of_minus)
done

subsubsection\<open>\<^term>\<open>bin_mult\<close>: Binary Multiplication\<close>

lemma integ_of_mult:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(bin_mult(v,w)) = integ_of(v) $* integ_of(w)"
apply (induct_tac "v", simp)
apply (simp add: integ_of_minus)
apply (auto simp add: zadd_ac integ_of_add zadd_zmult_distrib  elim!: boolE)
done

subsection\<open>Computations\<close>

(** extra rules for bin_succ, bin_pred **)

lemma bin_succ_1: "bin_succ(w BIT 1) = bin_succ(w) BIT 0"
by simp

lemma bin_succ_0: "bin_succ(w BIT 0) = NCons(w,1)"
by simp

lemma bin_pred_1: "bin_pred(w BIT 1) = NCons(w,0)"
by simp

lemma bin_pred_0: "bin_pred(w BIT 0) = bin_pred(w) BIT 1"
by simp

(** extra rules for bin_minus **)

lemma bin_minus_1: "bin_minus(w BIT 1) = bin_pred(NCons(bin_minus(w), 0))"
by simp

lemma bin_minus_0: "bin_minus(w BIT 0) = bin_minus(w) BIT 0"
by simp

(** extra rules for bin_add **)

lemma bin_add_BIT_11: "w \<in> bin \<Longrightarrow> bin_add(v BIT 1, w BIT 1) =
                     NCons(bin_add(v, bin_succ(w)), 0)"
by simp

lemma bin_add_BIT_10: "w \<in> bin \<Longrightarrow> bin_add(v BIT 1, w BIT 0) =
                     NCons(bin_add(v,w), 1)"
by simp

lemma bin_add_BIT_0: "\<lbrakk>w \<in> bin;  y \<in> bool\<rbrakk>
      \<Longrightarrow> bin_add(v BIT 0, w BIT y) = NCons(bin_add(v,w), y)"
by simp

(** extra rules for bin_mult **)

lemma bin_mult_1: "bin_mult(v BIT 1, w) = bin_add(NCons(bin_mult(v,w),0), w)"
by simp

lemma bin_mult_0: "bin_mult(v BIT 0, w) = NCons(bin_mult(v,w),0)"
by simp

(** Simplification rules with integer constants **)

lemma int_of_0: "$#0 = #0"
by simp

lemma int_of_succ: "$# succ(n) = #1 $+ $#n"
by (simp add: int_of_add [symmetric] natify_succ)

lemma zminus_0 [simp]: "$- #0 = #0"
by simp

lemma zadd_0_intify [simp]: "#0 $+ z = intify(z)"
by simp

lemma zadd_0_right_intify [simp]: "z $+ #0 = intify(z)"
by simp

lemma zmult_1_intify [simp]: "#1 $* z = intify(z)"
by simp

lemma zmult_1_right_intify [simp]: "z $* #1 = intify(z)"
by (subst zmult_commute, simp)

lemma zmult_0 [simp]: "#0 $* z = #0"
by simp

lemma zmult_0_right [simp]: "z $* #0 = #0"
by (subst zmult_commute, simp)

lemma zmult_minus1 [simp]: "#-1 $* z = $-z"
by (simp add: zcompare_rls)

lemma zmult_minus1_right [simp]: "z $* #-1 = $-z"
apply (subst zmult_commute)
apply (rule zmult_minus1)
done

subsection\<open>Simplification Rules for Comparison of Binary Numbers\<close>
text\<open>Thanks to Norbert Voelker\<close>

(** Equals (=) **)

lemma eq_integ_of_eq:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> ((integ_of(v)) = integ_of(w)) \<longleftrightarrow>
          iszero (integ_of (bin_add (v, bin_minus(w))))"
  unfolding iszero_def
apply (simp add: zcompare_rls integ_of_add integ_of_minus)
done

lemma iszero_integ_of_Pls: "iszero (integ_of(Pls))"
by (unfold iszero_def, simp)

lemma nonzero_integ_of_Min: "\<not> iszero (integ_of(Min))"
  unfolding iszero_def
apply (simp add: zminus_equation)
done

lemma iszero_integ_of_BIT:
     "\<lbrakk>w \<in> bin; x \<in> bool\<rbrakk>
      \<Longrightarrow> iszero (integ_of (w BIT x)) \<longleftrightarrow> (x=0 \<and> iszero (integ_of(w)))"
apply (unfold iszero_def, simp)
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (safe elim!: boolE)
apply (simp_all (asm_lr) add: zcompare_rls zminus_zadd_distrib [symmetric]
                     int_of_add [symmetric])
done

lemma iszero_integ_of_0:
     "w \<in> bin \<Longrightarrow> iszero (integ_of (w BIT 0)) \<longleftrightarrow> iszero (integ_of(w))"
by (simp only: iszero_integ_of_BIT, blast)

lemma iszero_integ_of_1: "w \<in> bin \<Longrightarrow> \<not> iszero (integ_of (w BIT 1))"
by (simp only: iszero_integ_of_BIT, blast)

(** Less-than (<) **)

lemma less_integ_of_eq_neg:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $< integ_of(w)
          \<longleftrightarrow> znegative (integ_of (bin_add (v, bin_minus(w))))"
  unfolding zless_def zdiff_def
apply (simp add: integ_of_minus integ_of_add)
done

lemma not_neg_integ_of_Pls: "\<not> znegative (integ_of(Pls))"
by simp

lemma neg_integ_of_Min: "znegative (integ_of(Min))"
by simp

lemma neg_integ_of_BIT:
     "\<lbrakk>w \<in> bin; x \<in> bool\<rbrakk>
      \<Longrightarrow> znegative (integ_of (w BIT x)) \<longleftrightarrow> znegative (integ_of(w))"
apply simp
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (auto elim!: boolE simp add: int_of_add [symmetric]  zcompare_rls)
apply (simp_all add: zminus_zadd_distrib [symmetric] zdiff_def
                     int_of_add [symmetric])
apply (subgoal_tac "$#1 $- $# succ (succ (n #+ n)) = $- $# succ (n #+ n) ")
 apply (simp add: zdiff_def)
apply (simp add: equation_zminus int_of_diff [symmetric])
done

(** Less-than-or-equals (<=) **)

lemma le_integ_of_eq_not_less:
     "(integ_of(x) $\<le> (integ_of(w))) \<longleftrightarrow> \<not> (integ_of(w) $< (integ_of(x)))"
by (simp add: not_zless_iff_zle [THEN iff_sym])

(*Delete the original rewrites, with their clumsy conditional expressions*)
declare bin_succ_BIT [simp del]
        bin_pred_BIT [simp del]
        bin_minus_BIT [simp del]
        NCons_Pls [simp del]
        NCons_Min [simp del]
        bin_adder_BIT [simp del]
        bin_mult_BIT [simp del]

(*Hide the binary representation of integer constants*)
declare integ_of_Pls [simp del] integ_of_Min [simp del] integ_of_BIT [simp del]

lemmas bin_arith_extra_simps =
     integ_of_add [symmetric]
     integ_of_minus [symmetric]
     integ_of_mult [symmetric]
     bin_succ_1 bin_succ_0
     bin_pred_1 bin_pred_0
     bin_minus_1 bin_minus_0
     bin_add_Pls_right bin_add_Min_right
     bin_add_BIT_0 bin_add_BIT_10 bin_add_BIT_11
     diff_integ_of_eq
     bin_mult_1 bin_mult_0 NCons_simps

(*For making a minimal simpset, one must include these default simprules
  of thy.  Also include simp_thms, or at least (\<not>False)=True*)
lemmas bin_arith_simps =
     bin_pred_Pls bin_pred_Min
     bin_succ_Pls bin_succ_Min
     bin_add_Pls bin_add_Min
     bin_minus_Pls bin_minus_Min
     bin_mult_Pls bin_mult_Min
     bin_arith_extra_simps

(*Simplification of relational operations*)
lemmas bin_rel_simps =
     eq_integ_of_eq iszero_integ_of_Pls nonzero_integ_of_Min
     iszero_integ_of_0 iszero_integ_of_1
     less_integ_of_eq_neg
     not_neg_integ_of_Pls neg_integ_of_Min neg_integ_of_BIT
     le_integ_of_eq_not_less

declare bin_arith_simps [simp]
declare bin_rel_simps [simp]

(** Simplification of arithmetic when nested to the right **)

lemma add_integ_of_left [simp]:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $+ (integ_of(w) $+ z) = (integ_of(bin_add(v,w)) $+ z)"
by (simp add: zadd_assoc [symmetric])

lemma mult_integ_of_left [simp]:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $* (integ_of(w) $* z) = (integ_of(bin_mult(v,w)) $* z)"
by (simp add: zmult_assoc [symmetric])

lemma add_integ_of_diff1 [simp]:
    "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $+ (integ_of(w) $- c) = integ_of(bin_add(v,w)) $- (c)"
  unfolding zdiff_def
apply (rule add_integ_of_left, auto)
done

lemma add_integ_of_diff2 [simp]:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
      \<Longrightarrow> integ_of(v) $+ (c $- integ_of(w)) =
          integ_of (bin_add (v, bin_minus(w))) $+ (c)"
apply (subst diff_integ_of_eq [symmetric])
apply (simp_all add: zdiff_def zadd_ac)
done

(** More for integer constants **)

declare int_of_0 [simp] int_of_succ [simp]

lemma zdiff0 [simp]: "#0 $- x = $-x"
by (simp add: zdiff_def)

lemma zdiff0_right [simp]: "x $- #0 = intify(x)"
by (simp add: zdiff_def)

lemma zdiff_self [simp]: "x $- x = #0"
by (simp add: zdiff_def)

lemma znegative_iff_zless_0: "k \<in> int \<Longrightarrow> znegative(k) \<longleftrightarrow> k $< #0"
by (simp add: zless_def)

lemma zero_zless_imp_znegative_zminus: "\<lbrakk>#0 $< k; k \<in> int\<rbrakk> \<Longrightarrow> znegative($-k)"
by (simp add: zless_def)

lemma zero_zle_int_of [simp]: "#0 $\<le> $# n"
by (simp add: not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])

lemma nat_of_0 [simp]: "nat_of(#0) = 0"
by (simp only: natify_0 int_of_0 [symmetric] nat_of_int_of)

lemma nat_le_int0_lemma: "\<lbrakk>z $\<le> $#0; z \<in> int\<rbrakk> \<Longrightarrow> nat_of(z) = 0"
by (auto simp add: znegative_iff_zless_0 [THEN iff_sym] zle_def zneg_nat_of)

lemma nat_le_int0: "z $\<le> $#0 \<Longrightarrow> nat_of(z) = 0"
apply (subgoal_tac "nat_of (intify (z)) = 0")
apply (rule_tac [2] nat_le_int0_lemma, auto)
done

lemma int_of_eq_0_imp_natify_eq_0: "$# n = #0 \<Longrightarrow> natify(n) = 0"
by (rule not_znegative_imp_zero, auto)

lemma nat_of_zminus_int_of: "nat_of($- $# n) = 0"
by (simp add: nat_of_def int_of_def raw_nat_of zminus image_intrel_int)

lemma int_of_nat_of: "#0 $\<le> z \<Longrightarrow> $# nat_of(z) = intify(z)"
apply (rule not_zneg_nat_of_intify)
apply (simp add: znegative_iff_zless_0 not_zless_iff_zle)
done

declare int_of_nat_of [simp] nat_of_zminus_int_of [simp]

lemma int_of_nat_of_if: "$# nat_of(z) = (if #0 $\<le> z then intify(z) else #0)"
by (simp add: int_of_nat_of znegative_iff_zless_0 not_zle_iff_zless)

lemma zless_nat_iff_int_zless: "\<lbrakk>m \<in> nat; z \<in> int\<rbrakk> \<Longrightarrow> (m < nat_of(z)) \<longleftrightarrow> ($#m $< z)"
apply (case_tac "znegative (z) ")
apply (erule_tac [2] not_zneg_nat_of [THEN subst])
apply (auto dest: zless_trans dest!: zero_zle_int_of [THEN zle_zless_trans]
            simp add: znegative_iff_zless_0)
done

(** nat_of and zless **)

(*An alternative condition is  @{term"$#0 \<subseteq> w"}  *)
lemma zless_nat_conj_lemma: "$#0 $< z \<Longrightarrow> (nat_of(w) < nat_of(z)) \<longleftrightarrow> (w $< z)"
apply (rule iff_trans)
apply (rule zless_int_of [THEN iff_sym])
apply (auto simp add: int_of_nat_of_if simp del: zless_int_of)
apply (auto elim: zless_asym simp add: not_zle_iff_zless)
apply (blast intro: zless_zle_trans)
done

lemma zless_nat_conj: "(nat_of(w) < nat_of(z)) \<longleftrightarrow> ($#0 $< z \<and> w $< z)"
apply (case_tac "$#0 $< z")
apply (auto simp add: zless_nat_conj_lemma nat_le_int0 not_zless_iff_zle)
done

(*This simprule cannot be added unless we can find a way to make eq_integ_of_eq
  unconditional!
  [The condition "True" is a hack to prevent looping.
    Conditional rewrite rules are tried after unconditional ones, so a rule
    like eq_nat_number_of will be tried first to eliminate #mm=#nn.]
  lemma integ_of_reorient [simp]:
       "True \<Longrightarrow> (integ_of(w) = x) \<longleftrightarrow> (x = integ_of(w))"
  by auto
*)

lemma integ_of_minus_reorient [simp]:
     "(integ_of(w) = $- x) \<longleftrightarrow> ($- x = integ_of(w))"
by auto

lemma integ_of_add_reorient [simp]:
     "(integ_of(w) = x $+ y) \<longleftrightarrow> (x $+ y = integ_of(w))"
by auto

lemma integ_of_diff_reorient [simp]:
     "(integ_of(w) = x $- y) \<longleftrightarrow> (x $- y = integ_of(w))"
by auto

lemma integ_of_mult_reorient [simp]:
     "(integ_of(w) = x $* y) \<longleftrightarrow> (x $* y = integ_of(w))"
by auto

(** To simplify inequalities involving integer negation and literals,
    such as -x = #3
**)

lemmas [simp] =
  zminus_equation [where y = "integ_of(w)"]
  equation_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zless [where y = "integ_of(w)"]
  zless_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zle [where y = "integ_of(w)"]
  zle_zminus [where x = "integ_of(w)"]
  for w

lemmas [simp] =
  Let_def [where s = "integ_of(w)"] for w

(*** Simprocs for numeric literals ***)

(** Combining of literal coefficients in sums of products **)

lemma zless_iff_zdiff_zless_0: "(x $< y) \<longleftrightarrow> (x$-y $< #0)"
  by (simp add: zcompare_rls)

lemma eq_iff_zdiff_eq_0: "\<lbrakk>x \<in> int; y \<in> int\<rbrakk> \<Longrightarrow> (x = y) \<longleftrightarrow> (x$-y = #0)"
  by (simp add: zcompare_rls)

lemma zle_iff_zdiff_zle_0: "(x $\<le> y) \<longleftrightarrow> (x$-y $\<le> #0)"
  by (simp add: zcompare_rls)

(** For combine_numerals **)

lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k"
  by (simp add: zadd_zmult_distrib zadd_ac)

(** For cancel_numerals **)

lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m = intify(n))"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> (intify(m) = (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

context fixes n :: i
begin

lemmas rel_iff_rel_0_rls =
  zless_iff_zdiff_zless_0 [where y = "u $+ v"]
  eq_iff_zdiff_eq_0 [where y = "u $+ v"]
  zle_iff_zdiff_zle_0 [where y = "u $+ v"]
  zless_iff_zdiff_zless_0 [where y = n]
  eq_iff_zdiff_eq_0 [where y = n]
  zle_iff_zdiff_zle_0 [where y = n]
  for u v

lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $< n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> (m $< (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

end

lemma le_add_iff1: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $\<le> n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma le_add_iff2: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> (m $\<le> (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

ML_file \<open>int_arith.ML\<close>

subsection \<open>examples:\<close>

text \<open>\<open>combine_numerals_prod\<close> (products of separate literals)\<close>
lemma "#5 $* x $* #3 = y" apply simp oops

schematic_goal "y2 $+ ?x42 = y $+ y2" apply simp oops

lemma "oo : int \<Longrightarrow> l $+ (l $+ #2) $+ oo = oo" apply simp oops

lemma "#9$*x $+ y = x$*#23 $+ z" apply simp oops
lemma "y $+ x = x $+ z" apply simp oops

lemma "x : int \<Longrightarrow> x $+ y $+ z = x $+ z" apply simp oops
lemma "x : int \<Longrightarrow> y $+ (z $+ x) = z $+ x" apply simp oops
lemma "z : int \<Longrightarrow> x $+ y $+ z = (z $+ y) $+ (x $+ w)" apply simp oops
lemma "z : int \<Longrightarrow> x$*y $+ z = (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "#-3 $* x $+ y $\<le> x $* #2 $+ z" apply simp oops
lemma "y $+ x $\<le> x $+ z" apply simp oops
lemma "x $+ y $+ z $\<le> x $+ z" apply simp oops

lemma "y $+ (z $+ x) $< z $+ x" apply simp oops
lemma "x $+ y $+ z $< (z $+ y) $+ (x $+ w)" apply simp oops
lemma "x$*y $+ z $< (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "l $+ #2 $+ #2 $+ #2 $+ (l $+ #2) $+ (oo $+ #2) = uu" apply simp oops
lemma "u : int \<Longrightarrow> #2 $* u = u" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #5 = y" apply simp oops

lemma "y $- b $< b" apply simp oops
lemma "y $- (#3 $* b $+ c) $< b $- #2 $* c" apply simp oops

lemma "(#2 $* x $- (u $* v) $+ y) $- v $* #3 $* u = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u $* #4 = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u = w" apply simp oops
lemma "u $* v $- (x $* u $* v $+ (u $* v) $* #4 $+ y) = w" apply simp oops

lemma "(i $+ j $+ #12 $+ k) = u $+ #15 $+ y" apply simp oops
lemma "(i $+ j $* #2 $+ #12 $+ k) = j $+ #5 $+ y" apply simp oops

lemma "#2 $* y $+ #3 $* z $+ #6 $* w $+ #2 $* y $+ #3 $* z $+ #2 $* u = #2 $* y' $+ #3 $* z' $+ #6 $* w' $+ #2 $* y' $+ #3 $* z' $+ u $+ vv" apply simp oops

lemma "a $+ $-(b$+c) $+ b = d" apply simp oops
lemma "a $+ $-(b$+c) $- b = d" apply simp oops

text \<open>negative numerals\<close>
lemma "(i $+ j $+ #-2 $+ k) $- (u $+ #5 $+ y) = zz" apply simp oops
lemma "(i $+ j $+ #-3 $+ k) $< u $+ #5 $+ y" apply simp oops
lemma "(i $+ j $+ #3 $+ k) $< u $+ #-6 $+ y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #-15 = y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #-15 = y" apply simp oops

text \<open>Multiplying separated numerals\<close>
lemma "#6 $* ($# x $* #2) =  uu" apply simp oops
lemma "#4 $* ($# x $* $# x) $* (#2 $* $# x) =  uu" apply simp oops

end


(*  Title:       Right group actions
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(* After Isabelle 2012, this may be moved to ~~/src/HOL/Algebra *)

section "Right group actions"

theory Action
  imports "HOL-Algebra.Group"
begin

locale action = group +
  fixes act :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "<o" 69)
  assumes id_act [simp]: "b <o \<one> = b"
  and act_act':
  "g \<in> carrier G \<and> h \<in> carrier G \<longrightarrow> (b <o g) <o h = b <o (g \<otimes> h)"
begin

lemma act_act:
  assumes "g \<in> carrier G" and "h \<in> carrier G"
  shows "(b <o g) <o h = b <o (g \<otimes> h)"
proof -
  from \<open>g \<in> carrier G\<close> and \<open>h \<in> carrier G\<close> and act_act'
  show "(b <o g) <o h = b <o (g \<otimes> h)" by simp
qed

lemma act_act_inv [simp]:
  assumes "g \<in> carrier G"
  shows "b <o g <o inv g = b"
proof -
  from \<open>g \<in> carrier G\<close> have "inv g \<in> carrier G" by (rule inv_closed)
  with \<open>g \<in> carrier G\<close> have "b <o g <o inv g = b <o g \<otimes> inv g" by (rule act_act)
  with \<open>g \<in> carrier G\<close> show "b <o g <o inv g = b" by simp
qed

lemma act_inv_act [simp]:
  assumes "g \<in> carrier G"
  shows "b <o inv g <o g = b"
  using \<open>g \<in> carrier G\<close> and act_act_inv [of "inv g"]
  by simp

lemma act_inv_iff:
  assumes "g \<in> carrier G"
  shows "b <o inv g = c \<longleftrightarrow> b = c <o g"
proof
  assume "b <o inv g = c"
  hence "b <o inv g <o g = c <o g" by simp
  with \<open>g \<in> carrier G\<close> show "b = c <o g" by simp
next
  assume "b = c <o g"
  hence "b <o inv g = c <o g <o inv g" by simp
  with \<open>g \<in> carrier G\<close> show "b <o inv g = c" by simp
qed

end

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim
  imports Weak_Sim Strong_Bisim_SC Struct_Cong
begin

lemma weakMonoCoinduct: "\<And>x y xa xb P Q.
                         x \<le> y \<Longrightarrow>
                         (Q \<leadsto>\<^sup>^<{(xb, xa). x xb xa}> P) \<longrightarrow>
                        (Q \<leadsto>\<^sup>^<{(xb, xa). y xb xa}> P)"
apply auto
apply(rule weakMonotonic)
by(auto dest: le_funE)

coinductive_set weakBisimulation :: "(ccs \<times> ccs) set"
where
  "\<lbrakk>P \<leadsto>\<^sup>^<weakBisimulation> Q; (Q, P) \<in> weakBisimulation\<rbrakk> \<Longrightarrow> (P, Q) \<in> weakBisimulation"
monos weakMonoCoinduct

abbreviation
  weakBisimJudge ("_ \<approx> _" [70, 70] 65) where "P \<approx> Q \<equiv> (P, Q) \<in> weakBisimulation"

lemma weakBisimulationCoinductAux[consumes 1]:
  fixes P :: "ccs"
  and   Q :: "ccs"
  and   X :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(X \<union> weakBisimulation)> Q \<and> (Q, P) \<in> X"

  shows "P \<approx> Q"
proof -
  have "X \<union> weakBisimulation = {(P, Q). (P, Q) \<in> X \<or> (P, Q) \<in> weakBisimulation}" by auto
  with assms show ?thesis
    by coinduct simp
qed

lemma weakBisimulationCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: "ccs"
  and   Q :: "ccs"
  and   X :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> X"
  and     "\<And>R S. (R, S) \<in> X \<Longrightarrow> R \<leadsto>\<^sup>^<(X \<union> weakBisimulation)> S"
  and     "\<And>R S. (R, S) \<in> X \<Longrightarrow> (S, R) \<in> X"

  shows "P \<approx> Q"
proof -
  have "X \<union> weakBisimulation = {(P, Q). (P, Q) \<in> X \<or> (P, Q) \<in> weakBisimulation}" by auto
  with assms show ?thesis
    by coinduct simp
qed

lemma weakBisimWeakCoinductAux[consumes 1]:
  fixes P :: "ccs"
  and   Q :: "ccs"
  and   X :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<X> Q \<and> (Q, P) \<in> X"

  shows "P \<approx> Q"
using assms
by(coinduct rule: weakBisimulationCoinductAux) (blast intro: weakMonotonic)

lemma weakBisimWeakCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: "ccs"
  and   Q :: "ccs"
  and   X :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<X> Q"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<approx> Q"
proof -
  have "X \<union> weakBisim = {(P, Q). (P, Q) \<in> X \<or> (P, Q) \<in> weakBisim}" by auto
  with assms show ?thesis
  by(coinduct rule: weakBisimulationCoinduct) (blast intro: weakMonotonic)+
qed

  assumes "P \<approx> Q"

  shows "P \<leadsto>\<^sup>^<weakBisimulation> Q"
  and   "Q \<approx> P"
using assms
by(auto simp add: intro: weakBisimulation.cases)

lemma weakBisimulationI:
  fixes P :: "ccs"
  and   Q :: "ccs"

  assumes "P \<leadsto>\<^sup>^<weakBisimulation> Q"
  and     "Q \<approx> P"

  shows "P \<approx> Q"
using assms
by(auto intro: weakBisimulation.intros)

lemma reflexive:
  fixes P :: ccs

  shows "P \<approx> P"
proof -
  have "(P, P) \<in> Id" by blast
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct) (auto intro: Weak_Sim.reflexive)
qed

  assumes "P \<approx> Q"

  shows "Q \<approx> P"
using assms
by(rule weakBisimulationE)

  assumes "P \<approx> Q"
  and     "Q \<approx> R"

  shows "P \<approx> R"
proof -
  from assms have "(P, R) \<in> weakBisimulation O weakBisimulation" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimulationCoinduct)
    case(cSim P R)
    from \<open>(P, R) \<in> weakBisimulation O weakBisimulation\<close>
    obtain Q where "P \<approx> Q" and "Q \<approx> R" by auto
    note \<open>P \<approx> Q\<close>
    moreover from \<open>Q \<approx> R\<close> have "Q \<leadsto>\<^sup>^<weakBisimulation> R" by(rule weakBisimulationE)
    moreover have "weakBisimulation O weakBisimulation \<subseteq> (weakBisimulation O weakBisimulation) \<union> weakBisimulation"
      by auto
    moreover note weakBisimulationE(1)
    ultimately show ?case by(rule Weak_Sim.transitive)
  next
    case(cSym P R)
    thus ?case by(blast dest: symmetric)
  qed
qed

lemma bisimWeakBisimulation:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<sim> Q"

  shows "P \<approx> Q"
using assms
by(coinduct rule: weakBisimWeakCoinduct[where X=bisim])
  (auto dest: bisimE simWeakSim)

lemma structCongWeakBisimulation:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<approx> Q"
using assms

by(auto intro: bisimWeakBisimulation bisimStructCong)

lemma strongAppend:
  fixes P     :: ccs
  and   Q     :: ccs
  and   R     :: ccs
  and   Rel   :: "(ccs \<times> ccs) set"
  and   Rel'  :: "(ccs \<times> ccs) set"
  and   Rel'' :: "(ccs \<times> ccs) set"

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     QSimR: "Q \<leadsto>[Rel'] R"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"

  shows "P \<leadsto>\<^sup>^<Rel''> R"
using assms
by(simp add: weakSimulation_def simulation_def) blast

lemma weakBisimWeakUpto[case_names cSim cSym, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and rSim: "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(weakBisimulation O X O bisim)> Q"
  and rSym: "\<And> P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<approx> Q"
proof -
  let ?X = "weakBisimulation O X O weakBisimulation"
  let ?Y = "weakBisimulation O X O bisim"
  from \<open>(P, Q) \<in> X\<close> have "(P, Q) \<in> ?X" by(blast intro: Strong_Bisim.reflexive reflexive)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cSim P Q)
    {
      fix P P' Q' Q
      assume "P \<approx> P'" and "(P', Q') \<in> X" and "Q' \<approx> Q"
      from \<open>(P', Q') \<in> X\<close> have "(P', Q') \<in> ?Y" by(blast intro: reflexive Strong_Bisim.reflexive)
      moreover from \<open>Q' \<approx> Q\<close> have "Q' \<leadsto>\<^sup>^<weakBisimulation> Q" by(rule weakBisimulationE)
      moreover have "?Y O weakBisimulation \<subseteq> ?X" by(blast dest: bisimWeakBisimulation transitive)
      moreover {
        fix P Q
        assume "(P, Q) \<in> ?Y"
        then obtain P' Q' where "P \<approx> P'" and "(P', Q') \<in> X" and "Q' \<sim> Q" by auto
        from \<open>(P', Q') \<in> X\<close> have "P' \<leadsto>\<^sup>^<?Y> Q'" by(rule rSim)
        moreover from \<open>Q' \<sim> Q\<close> have "Q' \<leadsto>[bisim] Q" by(rule bisimE)
        moreover have "?Y O bisim \<subseteq> ?Y" by(auto dest: Strong_Bisim.transitive)
        ultimately have "P' \<leadsto>\<^sup>^<?Y> Q" by(rule strongAppend)
        moreover note \<open>P \<approx> P'\<close>
        moreover have "weakBisimulation O ?Y \<subseteq> ?Y" by(blast dest: transitive)
        ultimately have "P \<leadsto>\<^sup>^<?Y> Q" using weakBisimulationE(1)
          by(rule_tac Weak_Sim.transitive)
      }
      ultimately have "P' \<leadsto>\<^sup>^<?X> Q" by(rule Weak_Sim.transitive)
      moreover note \<open>P \<approx> P'\<close>
      moreover have "weakBisimulation O ?X \<subseteq> ?X" by(blast dest: transitive)
      ultimately have "P \<leadsto>\<^sup>^<?X> Q" using weakBisimulationE(1)
        by(rule_tac Weak_Sim.transitive)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    thus ?case
      apply auto
      by(blast dest: bisimE rSym weakBisimulationE)
  qed
qed

lemma weakBisimUpto[case_names cSim cSym, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and rSim: "\<And>R S. (R, S) \<in> X \<Longrightarrow> R \<leadsto>\<^sup>^<(weakBisimulation O (X \<union> weakBisimulation) O bisim)> S"
  and rSym: "\<And>R S. (R, S) \<in> X \<Longrightarrow> (S, R) \<in> X"

  shows "P \<approx> Q"
proof -
  from p have "(P, Q) \<in> X \<union> weakBisimulation" by simp
  thus ?thesis
    apply(coinduct rule: weakBisimWeakUpto)
    apply(auto dest: rSim rSym weakBisimulationE)
    apply(rule weakMonotonic)
    apply(blast dest: weakBisimulationE)
    apply(auto simp add: relcomp_unfold)
    by(metis reflexive Strong_Bisim.reflexive transitive)
qed

end


(* IsageoCoq2_R1

Tarski_Non_Euclidean.thy

Version 2.2.0 IsaGeoCoq2_R1
Version 2.1.0 IsaGeoCoq2_R1
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)

section "Tarski hyperbolic"

theory Tarski_Hyperbolic

imports
  Tarski_Postulate_Parallels

begin

subsection "Rappel"

lemma (in Tarski_neutral_dimensionless) Rappel1:
  assumes "archimedes_axiom"
  shows "aristotle_s_axiom"
  by (simp add: PPR_Proposition_6 assms)

lemma (in Tarski_neutral_dimensionless) Rappel2:
  shows "aristotle_s_axiom \<longleftrightarrow> greenberg_s_axiom"
proof
  show "aristotle_s_axiom \<Longrightarrow> greenberg_s_axiom"
    using aristotle_s_axiom_def greenberg_s_axiom_def aristotle__greenberg by blast
  show "greenberg_s_axiom \<Longrightarrow> aristotle_s_axiom"
    using Pambuccian by blast
qed

lemma (in Tarski_neutral_dimensionless) Rappel3:
  assumes "Postulate01"
  shows "aristotle_s_axiom \<and> greenberg_s_axiom"
  using InterAx1 Rappel2 assms by blast

subsection "Definitions"

lemma (in Tarski_neutral_dimensionless) Tarski_Pre_Non_Euclidean_aux_pre:
  assumes "\<exists> A B C D T. \<not> ((Bet A D T \<and> Bet B D C \<and> A \<noteq> D)
                         \<longrightarrow>
                      (\<exists> X Y. Bet A B X \<and> Bet A C Y \<and> Bet X T Y))"
  shows "\<exists> A0 B0 C0 D0 T0. (Bet A0 D0 T0 \<and> Bet B0 D0 C0 \<and> A0 \<noteq> D0 \<and>
                           (\<forall> X Y. ((Bet A0 B0 X \<and> Bet A0 C0 Y) \<longrightarrow> \<not> Bet X T0 Y)))"
  using assms by blast

locale Tarski_Non_Euclidean = Tarski_neutral_dimensionless +
  fixes A0 B0 C0 D0 T0
  assumes NERule1: "Bet A0 D0 T0" and
    NERule2: "Bet B0 D0 C0" and
    NERule3: "A0 \<noteq> D0" and
    not_tarski_s_parallel_postulate_aux:
    "\<forall> X Y. ((Bet A0 B0 X \<and> Bet A0 C0 Y) \<longrightarrow> \<not> Bet X T0 Y)"

lemma (in Tarski_Non_Euclidean) Tarski_Pre_Non_Euclidean_aux:
  shows "\<exists> A B C D T. \<not> ((Bet A D T \<and> Bet B D C \<and> A \<noteq> D)
                         \<longrightarrow>
                      (\<exists> X Y. Bet A B X \<and> Bet A C Y \<and> Bet X T Y))"
  using NERule1 NERule2 NERule3 not_tarski_s_parallel_postulate_aux by blast

locale Tarski_Aristotle_Non_Euclidean = Tarski_Non_Euclidean +
  assumes aristotle: "aristotle_s_axiom"

locale Tarski_Archimedean_Non_Euclidean = Tarski_Aristotle_Non_Euclidean +
  assumes archimedes: "archimedes_axiom"

subsection "Theorems - Postulates"

subsection "Tarski non euclidean (General)"

lemma (in Tarski_Non_Euclidean) NPost01:
  shows "\<not> Postulate01"
  using Postulate01_def Tarski_Pre_Non_Euclidean_aux tarski_s_parallel_postulate_def by blast

lemma (in Tarski_Non_Euclidean) NPost02:
  shows "\<not> Postulate02"
  using InterAx5 NPost01 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost03:
  shows "\<not> Postulate03"
  using NPost02 Postulate02_def Postulate03_def aristotle aristotle__greenberg
    playfair_bis__playfair triangle__playfair_bis by blast

lemma (in Tarski_Archimedean_Non_Euclidean) NPost04:
  shows "\<not> Postulate04"
  using NPost03 Thm10 archimedes by blast

lemma (in Tarski_Non_Euclidean) NPost05:
  shows "\<not> Postulate05"
  using NPost02 Postulate02_def Postulate05_def par_trans_implies_playfair by blast

lemma (in Tarski_Non_Euclidean) NPost06:
  shows "\<not> Postulate06"
  by (simp add: NPost02 equivalent_postulates_without_decidability_of_intersection_of_lines)

lemma (in Tarski_Non_Euclidean) NPost07:
  shows "\<not> Postulate07"
  using NPost02 equivalent_postulates_without_decidability_of_intersection_of_lines by blast

lemma (in Tarski_Non_Euclidean) NPost08:
  shows "\<not> Postulate08"
  using NPost06 equivalent_postulates_without_decidability_of_intersection_of_lines by blast

lemma (in Tarski_Non_Euclidean) NPost09:
  shows "\<not> Postulate09"
  by (simp add: NPost02 equivalent_postulates_without_decidability_of_intersection_of_lines)

lemma (in Tarski_Non_Euclidean) NPost10:
  shows "\<not> Postulate10"
  using NPost05 equivalent_postulates_without_decidability_of_intersection_of_lines by blast

lemma (in Tarski_Non_Euclidean) NPost11:
  shows "\<not> Postulate11"
  using NPost02 equivalent_postulates_without_decidability_of_intersection_of_lines by fastforce

lemma (in Tarski_Non_Euclidean) NPost12:
  shows "\<not> Postulate12"
  using NPost02 Postulate02_def Postulate12_def playfair_bis__playfair by blast

lemma (in Tarski_Non_Euclidean) NPost13:
  shows "\<not> Postulate13"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Non_Euclidean) NPost14:
  shows "\<not> Postulate14"
  using Cycle_2 NPost13 by blast

lemma (in Tarski_Non_Euclidean) NPost15:
  shows "\<not> Postulate15"
  using Cycle_1 NPost02 by blast

lemma (in Tarski_Non_Euclidean) NPost16:
  shows "\<not> Postulate16"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Non_Euclidean) NPost17:
  shows "\<not> Postulate17"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Non_Euclidean) NPost18:
  shows "\<not> Postulate18"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Non_Euclidean) NPost19:
  shows "\<not> Postulate19"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Non_Euclidean) NPost20:
  shows "\<not> Postulate20"
  using Cycle_2 NPost01 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost21:
  shows "\<not> Postulate21"
  using Cycle_3 NPost03 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost22:
  shows "\<not> Postulate22"
  using Cycle_3 NPost21 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost23:
  shows "\<not> Postulate23"
  using Cycle_3 NPost22 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost24:
  shows "\<not> Postulate24"
  using Cycle_3 NPost23 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost25:
  shows "\<not> Postulate25"
  using Cycle_3 NPost24 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost26:
  shows "\<not> Postulate26"
  using Cycle_3 NPost25 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost27:
  shows "\<not> Postulate27"
  using Cycle_3 NPost26 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost28:
  shows "\<not> Postulate28"
  using Cycle_3 NPost27 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost29:
  shows "\<not> Postulate29"
  using Cycle_3 NPost28 by blast

lemma (in Tarski_Aristotle_Non_Euclidean) NPost30:
  shows "\<not> Postulate30"
  using Cycle_3 NPost29 by blast

lemma (in Tarski_Archimedean_Non_Euclidean) NPost31:
  shows "\<not> Postulate31"
  by (simp add: NPost04 P31_P04)

lemma (in Tarski_Archimedean_Non_Euclidean) NPost32:
  shows "\<not> Postulate32"
  using NPost31 P31_P32 by blast

lemma (in Tarski_Archimedean_Non_Euclidean) NPost33:
  shows "\<not> Postulate33"
  using NPost04 P04_P33 by auto

lemma (in Tarski_Archimedean_Non_Euclidean) NPost34:
  shows "\<not> Postulate34"
  using NPost01 Thm10 archimedes by blast

lemma (in Tarski_Archimedean_Non_Euclidean) NPost35:
  shows "\<not> Postulate35"
  using NPost01 Thm10_4 archimedes by blast

subsection "Theorem"

theorem (in Tarski_Non_Euclidean) not_tarski_s_parallel_postulate_thm:
  shows "\<exists> A B C D T. (Bet A D T \<and> Bet B D C \<and> A \<noteq> D \<and>
                      (\<forall> X Y. (Bet A B X \<and> Bet A C Y) \<longrightarrow> \<not> Bet X T Y))"
  using Tarski_Pre_Non_Euclidean_aux by blast

theorem (in Tarski_Non_Euclidean) not_playfair_s_postulate_thm:
  shows "\<exists> A1 A2 B1 B2 C1 C2 P. A1 A2 Par B1 B2 \<and>
                                Col P B1 B2 \<and> A1 A2 Par C1 C2 \<and> Col P C1 C2 \<and>
                                (\<not> Col C1 B1 B2 \<or> \<not> Col C2 B1 B2)"
  using NPost02 Postulate02_def playfair_s_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_triangle_postulate_thm:
  shows "\<exists> A B C D E F. A B C TriSumA D E F \<and> \<not> Bet D E F"
  using NPost03 Postulate03_def triangle_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_postulate_of_transitivity_of_parallelism_thm:
  shows "\<exists> A1 A2 B1 B2 C1 C2. A1 A2 Par B1 B2 \<and> B1 B2 Par C1 C2 \<and> \<not> (A1 A2 Par C1 C2)"
  using NPost05 Postulate05_def
    postulate_of_transitivity_of_parallelism_def by blast

theorem (in Tarski_Non_Euclidean) not_midpoint_converse_postulate_thm:
  shows "\<exists> A B C P Q. \<not> Col A B C \<and> P Midpoint B C \<and> A B Par Q P \<and> Col A C Q \<and> \<not> Q Midpoint A C"
  using NPost06 midpoint_converse_postulate_def
    Postulate06_def by blast

theorem (in Tarski_Non_Euclidean) not_alternate_interior_angles_postulate_thm:
  shows "\<exists> A B C D. A C TS B D \<and> A B Par C D \<and> \<not> B A C CongA D C A"
  using NPost07 Postulate07_def alternate_interior_angles_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_consecutive_interior_angles_postulate_thm:
  shows "\<exists> A B C D. B C OS A D \<and> A B Par C D \<and> \<not> A B C SuppA B C D"
  using NPost08 Postulate08_def consecutive_interior_angles_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_perpendicular_transversal_postulate_thm:
  shows "\<exists> A B C D P Q. A B Par C D \<and> A B Perp P Q \<and> Coplanar C D P Q \<and> \<not> C D Perp P Q"
  using NPost09 Postulate09_def perpendicular_transversal_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_postulate_of_parallelism_of_perpendicular_transversals_thm:
  shows "\<exists> A1 A2 B1 B2 C1 C2 D1 D2.
   A1 A2 Par B1 B2 \<and> A1 A2 Perp C1 C2 \<and> B1 B2 Perp D1 D2 \<and>
   Coplanar A1 A2 C1 D1 \<and> Coplanar A1 A2 C1 D2 \<and>
   Coplanar A1 A2 C2 D1 \<and> Coplanar A1 A2 C2 D2 \<and> \<not> C1 C2 Par D1 D2"
  using NPost10 Postulate10_def
    postulate_of_parallelism_of_perpendicular_transversals_def by blast

theorem (in Tarski_Non_Euclidean) not_universal_posidonius_postulate:
  shows "\<exists> A1 A2 A3 A4 B1 B2 B3 B4.
   A1 A2 Par B1 B2 \<and> Col A1 A2 A3 \<and> Col B1 B2 B3 \<and> A1 A2 Perp A3 B3 \<and>
   Col A1 A2 A4 \<and> Col B1 B2 B4 \<and> A1 A2 Perp A4 B4 \<and> \<not> Cong A3 B3 A4 B4"
  using NPost11 Postulate11_def universal_posidonius_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_alternative_playfair_s_postulate_thm:
  shows "\<exists> A1 A2 B1 B2 C1 C2 P.
     P Perp2 A1 A2 B1 B2 \<and> \<not> Col A1 A2 P \<and> Col P B1 B2 \<and>
     Coplanar A1 A2 B1 B2 \<and> A1 A2 Par C1 C2 \<and> Col P C1 C2 \<and>
     (\<not> Col C1 B1 B2 \<or> \<not> Col C2 B1 B2)"
  using NPost02 Postulate02_def alternative_playfair_s_postulate_def
    playfair_bis__playfair by blast

theorem (in Tarski_Non_Euclidean) not_proclus_postulate_thm:
  shows "\<exists> A B C D P Q. (\<forall> Y. A B Par C D \<and> Col A B P \<and>
                        \<not> Col A B Q \<and> Coplanar C D P Q \<and> (\<not> Col P Q Y \<or> \<not> Col C D Y))"
  using NPost13 proclus_postulate_def Postulate13_def by blast

theorem (in Tarski_Non_Euclidean) not_alternative_proclus_postulate_thm:
  shows "\<exists> A B C D P Q. (\<forall> Y. P Perp2 A B C D \<and> \<not> Col C D P \<and> Coplanar A B C D \<and> Col A B P \<and>
    \<not> Col A B Q \<and> Coplanar C D P Q \<and> (\<not> Col P Q Y \<or> \<not> Col C D Y))"
  using NPost14 alternative_proclus_postulate_def Postulate14_def by blast

theorem (in Tarski_Non_Euclidean) not_triangle_circumscription_principle_thm:
  shows "\<exists> A B C. \<forall> D. (\<not> Col A B C \<and> (\<not> Cong A D B D \<or> \<not> Cong A D C D \<or> \<not> Coplanar A B C D))"
  using NPost15 Postulate15_def
    triangle_circumscription_principle_def by blast

theorem (in Tarski_Non_Euclidean) not_inverse_projection_postulate_thm:
  shows "\<exists> A B C P Q. \<forall> Y.
     Acute A B C \<and> B Out A P \<and> P \<noteq> Q \<and> Per B P Q \<and> Coplanar A B C Q \<and>
     (\<not> B Out C Y \<or> \<not> Col P Q Y)"
  using NPost16 Postulate16_def inverse_projection_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_euclid_5_thm:
  shows "\<exists> P Q R S T U. \<forall> I.
     BetS P T Q \<and> BetS R T S \<and> BetS Q U R \<and> \<not> Col P Q S \<and>
     Cong P T Q T \<and> Cong R T S T \<and> (\<not> BetS S Q I \<or> \<not> BetS P U I)"
  using NPost17 Postulate17_def euclid_5_def by blast

theorem (in Tarski_Non_Euclidean) not_strong_parallel_postulate_thm:
  shows "\<exists> P Q R S T U. \<forall> I.
    BetS P T Q \<and> BetS R T S \<and> \<not> Col P R U \<and> Coplanar P Q R U \<and>
    Cong P T Q T \<and> Cong R T S T \<and> (\<not> Col S Q I \<or> \<not> Col P U I)"
  using NPost18 Postulate18_def strong_parallel_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_alternative_strong_parallel_postulate_thm:
  shows "\<exists> A B C D P Q R. \<forall> Y.
   B C OS A D \<and> A B C B C D SumA P Q R \<and> \<not> Bet P Q R \<and> (\<not> Col B A Y \<or> \<not> Col C D Y)"
  using NPost19 Postulate19_def alternative_strong_parallel_postulate_def by blast

theorem (in Tarski_Non_Euclidean) not_euclid_s_parallel_postulate_thm:
  shows "\<exists> A B C D P Q R. \<forall> Y.
     B C OS A D \<and> SAMS A B C B C D \<and> A B C B C D SumA P Q R \<and>
     \<not> Bet P Q R \<and> (\<not> B Out A Y \<or> \<not> C Out D Y)"
  using NPost20 Postulate20_def euclid_s_parallel_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean)
not_postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights_thm:
  shows "\<forall> A B C D E F. A B C TriSumA D E F \<and> Bet D E F \<longrightarrow> Col A B C"
  using NPost21 Postulate21_def
    postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_posidonius_postulate_thm:
  shows "\<forall> A1 A2 B1 B2.
 Col A1 A2 B1 \<or> B1 = B2 \<or> \<not> Coplanar A1 A2 B1 B2 \<or>
    (\<exists> A3 A4 B3 B4.
              Col A1 A2 A3 \<and> Col B1 B2 B3 \<and> A1 A2 Perp A3 B3 \<and>
              Col A1 A2 A4 \<and> Col B1 B2 B4 \<and> A1 A2 Perp A4 B4 \<and>
        \<not> Cong A3 B3 A4 B4) "
  using NPost22 Postulate22_def posidonius_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_posidonius_postulate_thm_1:
  shows "\<forall> A1 A2 B.
 Col A1 A2 B \<or> (\<exists> A3 A4 B3 B4.
              Col A1 A2 A3 \<and> Col B B B3 \<and> A1 A2 Perp A3 B3 \<and>
              Col A1 A2 A4 \<and> Col B B B4 \<and> A1 A2 Perp A4 B4 \<and>
        \<not> Cong A3 B3 A4 B4)"
proof -
  {
    fix A1 A2 B
    have "Coplanar A1 A2 B B"
      using ncop_distincts by blast
    assume "\<not> Col A1 A2 B"
    hence "    (\<exists> A3 A4 B3 B4.
              Col A1 A2 A3 \<and> Col B B B3 \<and> A1 A2 Perp A3 B3 \<and>
              Col A1 A2 A4 \<and> Col B B B4 \<and> A1 A2 Perp A4 B4 \<and>
        \<not> Cong A3 B3 A4 B4)"
      by (metis(full_types) col_trivial_1 ncop_distincts not_posidonius_postulate_thm)
  }
  thus ?thesis
    by blast
qed

theorem (in Tarski_Aristotle_Non_Euclidean) not_postulate_of_existence_of_similar_triangles_thm:
  shows "\<forall> A B C D E F.
  (Col A B C \<or> Cong A B D E \<or> \<not> A B C CongA D E F \<or>
   \<not> B C A CongA E F D \<or> \<not> C A B CongA F D E)"
  using NPost23 Postulate23_def postulate_of_existence_of_similar_triangles_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_thales_postulate_thm:
  shows "\<exists> A B C M.
   M Midpoint A B \<and> Cong M A M C \<and> \<not> Per A C B"
  using NPost24 Postulate24_def thales_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_thales_converse_postulate_thm:
  shows "\<exists> A B C M. M Midpoint A B \<and> Per A C B \<and> \<not> Cong M A M C"
  using NPost25 Postulate25_def thales_converse_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_existential_thales_postulate_thm:
  shows "\<forall> A B C M. (M Midpoint A B \<and> Cong M A M C \<and> Per A C B) \<longrightarrow> Col A B C"
  using NPost26 Postulate26_def existential_thales_postulate_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean) not_postulate_of_right_saccheri_quadrilaterals_thm:
  shows "\<exists> A B C D. Saccheri A B C D \<and> \<not> Per A B C"
  using Cycle_3 NPost03 Postulate28_def ex_saccheri
    postulate_of_existence_of_a_right_saccheri_quadrilateral_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean)
  not_postulate_of_existence_of_a_right_saccheri_quadrilateral_thm:
  shows "\<forall> A B C D. \<not> (Saccheri A B C D \<and> Per A B C)"
  using Cycle_3 NPost26 Postulate28_def
    postulate_of_existence_of_a_right_saccheri_quadrilateral_def by blast

theorem (in Tarski_Aristotle_Non_Euclidean)
  not_postulate_of_right_lambert_quadrilaterals_thm:
  shows "\<exists> A B C D. Lambert A B C D \<and> \<not> Per B C D"
  using Cycle_3 NPost26 Postulate30_def postulate_of_right_lambert_quadrilaterals_def
    rectangle_principle__rectangle_existence by blast

theorem (in Tarski_Aristotle_Non_Euclidean)
  not_postulate_of_existence_of_a_right_lambert_quadrilateral_thm:
  shows "\<forall> A B C D. \<not> (Lambert A B C D \<and> Per B C D)"
  using Cycle_3 NPost29 Postulate30_def
    postulate_of_existence_of_a_right_lambert_quadrilateral_def by blast

end


section\<open>Preliminaries: Definitions of tangles and links\<close>
theory Preliminaries
imports Main
begin

text\<open>This theory contains the definition of a link. A link is defined as link diagrams upto
 equivalence moves. Link diagrams are defined in terms of the constituent tangles\<close>

text\<open>each  block is a horizontal block built by putting basic link bricks next to each other.
(1) vert is the straight line
(2) cup is the up facing cup
(3) cap is the bottom facing
(4) over is the positive cross
(5) under is the negative cross\<close>

datatype brick = vert
                |cup
                |cap
                |over
                |under

text\<open>block is obtained by putting bricks next to each other\<close>

type_synonym block = "brick list"

text\<open>wall are link diagrams obtained by placing a horizontal blocks a top each other\<close>

datatype wall =  basic block
                |prod block  wall  (infixr "*" 66)

text\<open>Concatenate gives us the block obtained by putting two blocks next to each other\<close>

primrec concatenate :: "block => block => block" (infixr "\<otimes>" 65) where
concatenates_Nil: "[] \<otimes> ys = ys" |
concatenates_Cons: "((x#xs)\<otimes>ys) = x#(xs\<otimes>ys)"

lemma empty_concatenate: "xs \<otimes> Nil = xs"
 by (induction xs) (auto)

text\<open>Associativity properties of Conscatenation\<close>
lemma leftright_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>(y\<otimes>z)"
 by (induction x) (auto)

lemma left_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>y\<otimes>z"
 by (induction x) (auto)

lemma right_associativity: "x\<otimes>(y\<otimes>z) =x \<otimes> y \<otimes>z"
 by auto

text\<open>Compose gives us the wall obtained by putting a wall above another, perhaps in an invalid way.
\<close>
primrec compose :: "wall => wall => wall" (infixr "\<circ>" 66) where
compose_Nil: "(basic x) \<circ>  ys = prod x ys" |
compose_Cons: "((prod x xs)\<circ>ys) = prod x (xs\<circ>ys)"

text\<open>Associativity properties of composition\<close>
lemma compose_leftassociativity: "(((x::wall) \<circ> y) \<circ> z) = (x\<circ>y \<circ>z)"
 by (induction x) (auto)

lemma compose_rightassociativity: "(x::wall) \<circ> (y \<circ> z) = (x\<circ>y \<circ>z)"
 by (induction x) (auto)

text\<open>block-length of a block is the number of bricks in a given block\<close>
primrec block_length::"block \<Rightarrow> nat"
where
"block_length [] = 0"|
"block_length (Cons x y) = 1 + (block_length y)"

(*domain tells us the number of incoming strands*)
 primrec domain::"brick \<Rightarrow> int"
 where
 "domain vert = 1"|
 "domain cup = 0"|
 "domain cap = 2"|
 "domain over = 2"|
 "domain under = 2"

lemma domain_non_negative:"\<forall>x.(domain x) \<ge> 0"

proof-
 have "\<forall>x.(x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)"
               by (metis brick.exhaust)
 moreover have
      "\<forall>x.(((x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)) \<longrightarrow> (domain x) \<ge> 0)"
              using domain.simps by (metis order_refl zero_le_numeral zero_le_one)
 ultimately show ?thesis by auto
qed

(*co-domain tells us the number of outgoing strands*)
 primrec codomain::"brick \<Rightarrow> int"
 where
 "codomain vert = 1"|
 "codomain cup = 2"|
 "codomain cap = 0"|
 "codomain over = 2"|
 "codomain under = 2"

(*domain-block tells us the number of incoming strands of a block*)
 primrec domain_block::"block \<Rightarrow> int "
 where
 "domain_block [] = 0"
 |"domain_block (Cons x y) = (domain x + (domain_block y))"

lemma domain_block_non_negative:"domain_block xs \<ge> 0"
 by (induction xs) (auto simp add:domain_non_negative)

(*codomain-block tells us the number of outgoing strands of a block*)

 primrec codomain_block::"block \<Rightarrow> int "
 where
 "codomain_block [] = 0"
 |"codomain_block (Cons x y) = (codomain x + (codomain_block y))"

(*domain-wall tells us the number of incoming strands of a wall*)

primrec domain_wall:: "wall \<Rightarrow> int" where
"domain_wall (basic x) = domain_block x"
|"domain_wall (x*ys) = domain_block x"

(*domain-wall tells us the number of incoming strands of a wall*)

fun codomain_wall:: "wall \<Rightarrow> int" where
"codomain_wall (basic x) = codomain_block x"
|"codomain_wall (x*ys) = codomain_wall ys"

lemma domain_wall_compose: "domain_wall (xs\<circ>ys) = domain_wall xs"
 by (induction xs) (auto)

lemma codomain_wall_compose: "codomain_wall (xs\<circ>ys) = codomain_wall ys"
 by (induction xs) (auto)

text\<open>this lemma tells us the number of incoming and outgoing strands
of a composition of two wall\<close>

text\<open>absolute value\<close>
definition abs::"int \<Rightarrow> int" where
"abs x \<equiv> if (x\<ge>0) then x else (0-x)"

text\<open>theorems about abs\<close>
lemma abs_zero: assumes "abs x = 0" shows "x = 0"
 using abs_def assms eq_iff_diff_eq_0
 by metis

lemma abs_zero_equality: assumes "abs (x - y) = 0" shows "x = y"
 using assms abs_zero  eq_iff_diff_eq_0
 by blast

lemma abs_non_negative: " abs x \<ge> 0"
 using abs_def diff_0 le_cases neg_0_le_iff_le
 by auto

lemma abs_non_negative_sum:  assumes " abs x + abs y = 0"
shows "abs x= 0" and "abs y = 0"
 using abs_def diff_0 abs_non_negative  neg_0_le_iff_le
 add_nonneg_eq_0_iff assms
 apply (metis)
 by (metis abs_non_negative add_nonneg_eq_0_iff assms)

text\<open>The following lemmas tell us that the number of incoming and outgoing strands of every brick
is a non negative integer\<close>

lemma domain_nonnegative: "(domain x) \<ge> 0"
 using domain.simps  brick.exhaust le_cases not_numeral_le_zero zero_le_one by (metis)

lemma codomain_nonnegative: "(codomain x) \<ge> 0"
 by (cases x)(auto)

text\<open>The following lemmas tell us that the number of incoming and outgoing strands of every block
is a non negative integer\<close>

lemma domain_block_nonnegative: "domain_block x \<ge> 0"
 by (induction x)(auto simp add: domain_nonnegative)

lemma codomain_block_nonnegative: "(codomain_block x) \<ge> 0"
 by (induction x)(auto simp add: codomain_nonnegative)

text\<open>The following lemmas tell us that if a block is appended to a block with incoming strands, then
the resultant block has incoming strands\<close>

lemma domain_positive: "((domain_block (x#Nil)) > 0) \<or> ((domain_block y) > 0)
\<Longrightarrow> (domain_block (x#y) > 0)"
proof-
 have "(domain_block (x#y)) =  (domain x) + (domain_block y)"  by auto
 also have " (domain x) = (domain_block (x#Nil))" by auto
 then have "(domain_block (x#Nil) > 0) = (domain x > 0)"  by auto
 then have "((domain x > 0) \<or> (domain_block y > 0)) \<Longrightarrow> (domain x + domain_block y)>0"
    using domain_nonnegative add_nonneg_pos add_pos_nonneg domain_block_nonnegative
    by metis
 from this
       show "((domain_block(x#Nil)) > 0) \<or> ((domain_block y) > 0)
                                        \<Longrightarrow> (domain_block (x#y) > 0)"
            by auto
qed

lemma domain_additive:  "(domain_block (x\<otimes>y))= (domain_block x) + (domain_block y)"
  by (induction x)(auto)

lemma codomain_additive:   "(codomain_block (x\<otimes>y))= (codomain_block x) + (codomain_block y)"
  by (induction x)(auto)

lemma domain_zero_sum: assumes "(domain_block x) + (domain_block y) = 0"
shows "domain_block x = 0" and "domain_block y = 0"
 using domain_block_nonnegative add_nonneg_eq_0_iff assms
 apply metis
 by (metis add_nonneg_eq_0_iff assms domain_block_nonnegative)

lemma domain_block_positive: assumes "domain_block y>0" or "domain_block y>0"
shows "(domain_block (x\<otimes>y)) > 0"
 apply (simp add: domain_additive)
 by (metis assms(1) domain_additive domain_block_nonnegative domain_zero_sum(2) less_le)

lemma codomain_block_positive: assumes "codomain_block y>0" or "codomain_block y>0"
shows "(codomain_block (x\<otimes>y)) > 0"
 apply (simp add: codomain_additive)
 using  assms(1) codomain_additive codomain_block_nonnegative eq_neg_iff_add_eq_0
        le_less_trans less_le neg_less_0_iff_less
 by (metis)

text\<open>We prove that if the first count of a block is zero, then it is composed of cups and empty bricks. In
order to do that we define the functions brick-is-cup and is-cup which check if a given block is
composed of cups or if the blocks are composed of blocks\<close>

primrec brick_is_cup::"brick \<Rightarrow> bool"
where
"brick_is_cup vert = False"|
"brick_is_cup cup = True"|
"brick_is_cup cap = False"|
"brick_is_cup over = False"|
"brick_is_cup under = False"

primrec is_cup::"block \<Rightarrow> bool"
where
"is_cup [] = True"|
"is_cup (x#y) = (if (x= cup) then (is_cup y) else False)"

lemma brickcount_zero_implies_cup:"(domain x= 0) \<Longrightarrow> (x = cup)"
 by (cases x) (auto)

lemma brickcount_zero_implies_brick_is_cup:"(domain x= 0) \<Longrightarrow> (brick_is_cup x)"
 by (cases x) (auto)

lemma domain_zero_implies_is_cup:"(domain_block x= 0) \<Longrightarrow> (is_cup x)"
proof(induction x)
 case Nil
  show ?case by auto
  next
 case (Cons a y)
  show ?case
  proof-
   have step1: "domain_block (a # y) =  (domain a) + (domain_block y)"
               by auto
   with domain_zero_sum have"domain_block y = 0"
               by (metis (full_types) Cons.prems domain_block_nonnegative domain_positive leD neq_iff)
   then have step2: "(is_cup y)"
               using Cons.IH by (auto)
   with step1 and domain_zero_sum
            have "domain a= 0"
                       using Cons.prems \<open>domain_block y = 0\<close> by linarith
   then have "brick_is_cup a"
               using brickcount_zero_implies_brick_is_cup by auto
   then have "a=cup"
        using brick_is_cup_def by (metis \<open>domain a = 0\<close> brickcount_zero_implies_cup)
   with step2 have "is_cup (a#y)"
        using is_cup_def by auto
   then show ?case by auto
 qed
qed

text\<open>We need a function that checks if a wall represents a knot diagram.\<close>

primrec is_tangle_diagram::"wall \<Rightarrow>  bool"
where
"is_tangle_diagram (basic x) = True"
|"is_tangle_diagram (x*xs) = (if is_tangle_diagram xs
                               then (codomain_block x = domain_wall xs)
                               else False)"

definition is_link_diagram::"wall \<Rightarrow>  bool"
where
"is_link_diagram x \<equiv> (if (is_tangle_diagram x)
                        then (abs (domain_wall x) + abs(codomain_wall x) = 0)
                         else False)"

end