chapter \<open>Section 6 Material and Gödel's First Incompleteness Theorem\<close>

theory Goedel_I
imports Pf_Predicates Functions
begin

section\<open>The Function W and Lemma 6.1\<close>

subsection\<open>Predicate form, defined on sequences\<close>

definition SeqWR :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqWR s k y \<equiv> LstSeq s k y \<and> app s 0 = 0 \<and>
                        (\<forall>l \<^bold>\<in> k. app s (succ l) = q_Eats (app s l) (app s l))"

nominal_function SeqWRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl); atom sl \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqWRP s k y = LstSeqP s k y AND
          HPair Zero Zero IN s AND
          All2 l k (Ex sl (HPair (Var l) (Var sl) IN s AND
                           HPair (SUCC (Var l)) (Q_Succ (Var sl)) IN s))"
  by (auto simp: eqvt_def SeqWRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqWRP_fresh_iff [simp]: "a \<sharp> SeqWRP s k y \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> y" (is ?thesis1)
    and eval_fm_SeqWRP [simp]:   "eval_fm e (SeqWRP s k y) \<longleftrightarrow> SeqWR \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
    and SeqWRP_sf [iff]:         "Sigma_fm (SeqWRP s k y)"  (is ?thsf)
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
      by (auto simp: SeqWR_def q_defs LstSeq_imp_Ord
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma SeqWRP_subst [simp]:
      "(SeqWRP s k y)(i::=t) = SeqWRP (subst i t s) (subst i t k) (subst i t y)"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl,t,i)" "atom sl \<sharp> (s,k,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP.simps [where l=l and sl=sl])
qed

lemma SeqWRP_cong:
  assumes "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'" and  "H \<turnstile> y EQ y'"
  shows "H \<turnstile> SeqWRP s k y IFF SeqWRP s' k' y'"
  by (rule P3_cong [OF _ assms], auto)

declare SeqWRP.simps [simp del]

subsection\<open>Predicate form of W\<close>

definition WR :: "hf \<Rightarrow> hf \<Rightarrow> bool"
  where "WR x y \<equiv> (\<exists>s. SeqWR s x y)"

nominal_function WRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,y)\<rbrakk> \<Longrightarrow>
    WRP x y = Ex s (SeqWRP (Var s) x y)"
  by (auto simp: eqvt_def WRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows WRP_fresh_iff [simp]: "a \<sharp> WRP x y \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y" (is ?thesis1)
    and eval_fm_WRP [simp]:   "eval_fm e (WRP x y) \<longleftrightarrow> WR \<lbrakk>x\<rbrakk>e \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
    and sigma_fm_WRP [simp]:  "Sigma_fm (WRP x y)"  (is ?thsf)
proof -
  obtain s::name where "atom s \<sharp> (x,y)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: WR_def)
qed

lemma WRP_subst [simp]: "(WRP x y)(i::=t) = WRP (subst i t x) (subst i t y)"
proof -
  obtain s::name where "atom s \<sharp> (x,y,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: WRP.simps [of s])
qed

lemma WRP_cong: "H \<turnstile> t EQ t' \<Longrightarrow> H \<turnstile> u EQ u' \<Longrightarrow> H \<turnstile> WRP t u IFF WRP t' u'"
  by (rule P2_cong) auto

declare WRP.simps [simp del]

lemma WR0_iff: "WR 0 y \<longleftrightarrow> y=0"
  by (simp add: WR_def SeqWR_def) (metis LstSeq_1 LstSeq_app)

lemma WR0: "WR 0 0"
  by (simp add: WR0_iff)

lemma WR_succ_iff: assumes i: "Ord i" shows "WR (succ i) z = (\<exists>y. z = q_Eats y y \<and> WR i y)"
proof
  assume "WR (succ i) z"
  then obtain s where s: "SeqWR s (succ i) z"
    by (auto simp: WR_def i)
  moreover then have "app s (succ i) = z"
    by (auto simp: SeqWR_def)
  ultimately show "\<exists>y. z = q_Eats y y \<and> WR i y" using i
    by (auto simp: WR_def SeqWR_def) (metis LstSeq_trunc hmem_succ_self)
next
  assume "\<exists>y. z = q_Eats y y \<and> WR i y"
  then obtain y where z: "z = q_Eats y y" and y: "WR i y"
    by blast
  thus "WR (succ i) z" using i
    apply (auto simp: WR_def SeqWR_def)
    apply (rule_tac x="insf s (succ i) (q_Eats y y)" in exI)
    apply (auto simp: LstSeq_imp_Seq_succ app_insf_Seq_if LstSeq_insf succ_notin_self)
    done
qed

lemma WR_succ: "Ord i \<Longrightarrow> WR (succ i) (q_Eats y y) = WR i y"
  by (metis WR_succ_iff q_Eats_iff)

lemma WR_ord_of: "WR (ord_of i) \<lbrakk>\<guillemotleft>ORD_OF i\<guillemotright>\<rbrakk>e"
  by (induct i) (auto simp: WR0_iff WR_succ_iff quot_Succ q_defs)

text\<open>Lemma 6.1\<close>
lemma WR_quot_Var: "WR \<lbrakk>\<guillemotleft>Var x\<guillemotright>\<rbrakk>e \<lbrakk>\<guillemotleft>\<guillemotleft>Var x\<guillemotright>\<guillemotright>\<rbrakk>e"
  by (auto simp: quot_Var quot_Succ)
     (metis One_nat_def Ord_ord_of WR_ord_of WR_succ htuple.simps q_Eats_def)

lemma ground_WRP [simp]: "ground_fm (WRP x y) \<longleftrightarrow> ground x \<and> ground y"
  by (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh)

lemma prove_WRP:  "{} \<turnstile> WRP \<guillemotleft>Var x\<guillemotright> \<guillemotleft>\<guillemotleft>Var x\<guillemotright>\<guillemotright>"
  by (auto simp: WR_quot_Var ground_aux_def supp_conv_fresh intro: Sigma_fm_imp_thm)

subsection\<open>Proving that these relations are functions\<close>

lemma SeqWRP_Zero_E:
  assumes "insert (y EQ Zero) H \<turnstile> A"  "H \<turnstile> k EQ Zero"
  shows "insert (SeqWRP s k y) H \<turnstile> A"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule cut_same [where A = "LstSeqP s Zero y"])
    apply (blast intro: thin1 assms  LstSeqP_cong [OF Refl _ Refl, THEN Iff_MP_same])
    apply (rule cut_same [where A = "y EQ Zero"])
    apply (blast intro: LstSeqP_EQ)
    apply (metis rotate2 assms(1) thin1)
    done
qed

lemma SeqWRP_SUCC_lemma:
  assumes y': "atom y' \<sharp> (s,k,y)"
  shows "{SeqWRP s (SUCC k) y} \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
proof -
  obtain l::name and sl::name
    where atoms: "atom l \<sharp> (s,k,y,y',sl)" "atom sl \<sharp> (s,k,y,y')"
    by (metis obtain_fresh)
  thus ?thesis using y'
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], auto)
    apply (rule Ex_I [where x = "Var sl"], auto)
    apply (blast intro: LstSeqP_SUCC) \<comment> \<open>showing @{term"SeqWRP s k (Var sl)"}\<close>
    apply (blast intro: ContraProve LstSeqP_EQ)
    done
qed

lemma SeqWRP_SUCC_E:
  assumes y': "atom y' \<sharp> (s,k,y)" and k': "H \<turnstile> k' EQ (SUCC k)"
  shows "insert (SeqWRP s k' y) H  \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
  using SeqWRP_cong [OF Refl k' Refl] cut1 [OF SeqWRP_SUCC_lemma [of y' s k y]]
  by (metis Assume Iff_MP_left Iff_sym y')

lemma SeqWRP_unique: "{OrdP x, SeqWRP s x y, SeqWRP s' x y'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and sl::name and sl'::name and l::name and pi::name
    where  i: "atom i \<sharp> (s,s',y,y')" and j: "atom j \<sharp> (s,s',i,x,y,y')" and j': "atom j' \<sharp> (s,s',i,j,x,y,y')"
      and atoms: "atom k \<sharp> (s,s',i,j,j')" "atom sl \<sharp> (s,s',i,j,j',k)" "atom sl' \<sharp> (s,s',i,j,j',k,sl)"
                 "atom pi \<sharp> (s,s',i,j,j',k,sl,sl')"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> All j (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))"
    apply (rule OrdIndH [where j=k])
    using i j j' atoms apply auto
    apply (rule rotate4)
    apply (rule OrdP_cases_E [where k=pi], simp_all)
    \<comment> \<open>Zero case\<close>
    apply (rule SeqWRP_Zero_E [THEN rotate3])
    prefer 2 apply blast
    apply (rule SeqWRP_Zero_E [THEN rotate4])
    prefer 2 apply blast
    apply (blast intro: ContraProve [THEN rotate4] Sym Trans)
    \<comment> \<open>SUCC case\<close>
    apply (rule Ex_I [where x = "Var pi"], auto)
    apply (metis ContraProve EQ_imp_SUBS2 Mem_SUCC_I2 Refl Subset_D)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl' s' "Var pi", THEN rotate4], auto)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl s "Var pi", THEN rotate7], auto)
    apply (rule All_E [where x = "Var sl", THEN rotate5], simp)
    apply (rule All_E [where x = "Var sl'"], simp)
    apply (rule Imp_E, blast)+
    apply (rule cut_same [OF Q_Succ_cong [OF Assume]])
    apply (blast intro: Trans [OF Hyp Sym] HPair_cong)
    done
  hence "{OrdP (Var i)} \<turnstile> (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))(j::=y)"
    by (metis All_D)
  hence "{OrdP (Var i)} \<turnstile> (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ y))(j'::=y')"
    using j j'
    by simp (drule All_D [where x=y'], simp)
  hence "{} \<turnstile> OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y))"
    using j j'
    by simp (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y)))(i::=x)"
    by (metis Subst emptyE)
  thus ?thesis using i
    by simp (metis anti_deduction insert_commute)
qed

theorem WRP_unique: "{OrdP x, WRP x y, WRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name
    where "atom s \<sharp> (x,y,y')"  "atom s' \<sharp> (x,y,y',s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP_unique [THEN rotate3] WRP.simps [of s _ y]  WRP.simps [of s' _ y'])
qed

subsection\<open>The equivalent function\<close>

definition W :: "hf \<Rightarrow> tm"
  where "W \<equiv> hmemrec (\<lambda>f z. if z=0 then Zero else Q_Eats (f (pred z)) (f (pred z)))"

lemma W0 [simp]: "W 0 = Zero"
  by (rule trans [OF def_hmemrec [OF W_def]]) auto

lemma W_succ [simp]: "Ord i \<Longrightarrow> W (succ i) = Q_Eats (W i) (W i)"
  by (rule trans [OF def_hmemrec [OF W_def]]) (auto simp: ecut_apply SUCC_def W_def)

lemma W_ord_of [simp]: "W (ord_of i) = \<guillemotleft>ORD_OF i\<guillemotright>"
  by (induct i, auto simp: SUCC_def quot_simps)

lemma WR_iff_eq_W: "Ord x \<Longrightarrow> WR x y \<longleftrightarrow> y = \<lbrakk>W x\<rbrakk>e"
proof (induct x arbitrary: y rule: Ord_induct2)
  case 0 thus ?case
    by (metis W0 WR0_iff eval_tm.simps(1))
next
  case (succ k) thus ?case
    by (auto simp: WR_succ_iff q_Eats_def)
qed

section\<open>The Function HF and Lemma 6.2\<close>

definition SeqHR :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "SeqHR x x' s k \<equiv>
       BuildSeq2 (\<lambda>y y'. Ord y \<and> WR y y')
                 (\<lambda>u u' v v' w w'. u = \<langle>v,w\<rangle> \<and> u' = q_HPair v' w') s k x x'"

subsection \<open>Defining the syntax: quantified body\<close>

nominal_function SeqHRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn');
          atom sl' \<sharp> (s,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn');
          atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn');
          atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn');
          atom sn' \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqHRP x x' s k =
      LstSeqP s k (HPair x x') AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                ((OrdP (Var sl) AND WRP (Var sl) (Var sl')) OR
                 Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       Var sl EQ HPair (Var sm) (Var sn) AND
                       Var sl' EQ Q_HPair (Var sm') (Var sn')))))))))))"
by (auto simp: eqvt_def SeqHRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SeqHRP_fresh_iff [simp]:
      "a \<sharp> SeqHRP x x' s k \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
   and eval_fm_SeqHRP [simp]:
      "eval_fm e (SeqHRP x x' s k) \<longleftrightarrow> SeqHR \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e"  (is ?thesis2)
  and SeqHRP_sf [iff]:  "Sigma_fm (SeqHRP x x' s k)"  (is ?thsf)
  and SeqHRP_imp_OrdP: "{ SeqHRP x y s k } \<turnstile> OrdP k"  (is ?thord)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (s,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
         "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thord
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by (fastforce simp: LstSeq_imp_Ord SeqHR_def
             BuildSeq2_def BuildSeq_def Builds_def
             HBall_def q_HPair_def q_Eats_def
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"]
             cong: conj_cong)
qed

lemma SeqHRP_subst [simp]:
      "(SeqHRP x x' s k)(i::=t) = SeqHRP (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (s,k,t,i,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (s,t,i,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (s,t,i,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (s,t,i,n,sm,sm',sn,sn')" "atom n \<sharp> (s,t,i,sm,sm',sn,sn')"
          "atom sm \<sharp> (s,t,i,sm',sn,sn')" "atom sm' \<sharp> (s,t,i,sn,sn')"
          "atom sn \<sharp> (s,t,i,sn')" "atom sn' \<sharp> (s,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqHRP_cong:
  assumes "H \<turnstile> x EQ x'" and "H \<turnstile> y EQ y'" "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'"
  shows "H \<turnstile> SeqHRP x y s k IFF SeqHRP x' y' s' k'"
  by (rule P4_cong [OF _ assms], auto)

subsection \<open>Defining the syntax: main predicate\<close>

definition HR :: "hf \<Rightarrow> hf \<Rightarrow> bool"
  where "HR x x' \<equiv> \<exists>s k. SeqHR x x' s k"

nominal_function HRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,x',k); atom k \<sharp> (x,x')\<rbrakk> \<Longrightarrow>
         HRP x x' = Ex s (Ex k (SeqHRP x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def HRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows HRP_fresh_iff [simp]: "a \<sharp> HRP x x' \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x'"  (is ?thesis1)
   and eval_fm_HRP [simp]:   "eval_fm e (HRP x x') \<longleftrightarrow> HR \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e"  (is ?thesis2)
   and HRP_sf [iff]:         "Sigma_fm (HRP x x')"  (is ?thsf)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (x,x',k)"  "atom k \<sharp> (x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: HR_def q_defs)
qed

lemma HRP_subst [simp]: "(HRP x x')(i::=t) = HRP (subst i t x) (subst i t x')"
proof -
  obtain s::name and k::name where "atom s \<sharp> (x,x',t,i,k)"  "atom k \<sharp> (x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: HRP.simps [of s _ _ k])
qed

subsection\<open>Proving that these relations are functions\<close>

lemma SeqHRP_lemma:
  assumes "atom m \<sharp> (x,x',s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (x,x',s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (x,x',s,k,sm',sn,sn')" "atom sm' \<sharp> (x,x',s,k,sn,sn')"
          "atom sn \<sharp> (x,x',s,k,sn')" "atom sn' \<sharp> (x,x',s,k)"
    shows "{ SeqHRP x x' s k }
         \<turnstile> (OrdP x AND WRP x x') OR
             Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqHRP (Var sm) (Var sm') s (Var m) AND
                       SeqHRP (Var sn) (Var sn') s (Var n) AND
                       x EQ HPair (Var sm) (Var sn) AND
                       x' EQ Q_HPair (Var sm') (Var sn')))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where atoms:
          "atom l \<sharp> (x,x',s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (x,x',s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (x,x',s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using atoms assms
    apply (simp add: SeqHRP.simps [of l s k sl sl' m n sm sm' sn sn'])
    apply (rule Conj_E)
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], simp_all)
    apply (rule rotate2)
    apply (rule Ex_E Conj_E)+
    apply (rule cut_same [where A = "HPair x x' EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume LstSeqP_EQ rotate4, simp_all, clarify)
    apply (rule Disj_E [THEN rotate4])
    apply (rule Disj_I1)
    apply (metis Assume AssumeH(3) Sym thin1  Iff_MP_same [OF Conj_cong [OF OrdP_cong WRP_cong] Assume])
    \<comment> \<open>auto could be used but is VERY SLOW\<close>
    apply (rule Disj_I2)
    apply (rule Ex_E Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp add: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
    apply (rule Conj_I, blast)+
    \<comment> \<open>first SeqHRP subgoal\<close>
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>next SeqHRP subgoal\<close>
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (auto intro!: SUCC_Subset_Ord LstSeqP_OrdP)
    \<comment> \<open>finally, the equality pair\<close>
    apply (blast intro: Trans)+
    done
qed

lemma SeqHRP_unique: "{SeqHRP x y s u, SeqHRP x y' s' u'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',y,y')"   "atom j \<sharp> (s,s',i,x,y,y')"  "atom j' \<sharp> (s,s',i,j,x,y,y')"
                  "atom k \<sharp> (s,s',x,y,y',u',i,j,j')" "atom k' \<sharp> (s,s',x,y,y',k,i,j,j')" "atom l \<sharp> (s,s',i,j,j',k,k')"
                  "atom m \<sharp> (s,s',i,j,j',k,k',l)"   "atom n \<sharp> (s,s',i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{OrdP (Var k)}
       \<turnstile> All i (All j (All j' (All k' (SeqHRP (Var i) (Var j) s (Var k) IMP (SeqHRP (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m2 "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    \<comment> \<open>case 1, both are ordinals\<close>
    apply (blast intro: cut3 [OF WRP_unique])
    \<comment> \<open>case 2, @{term "OrdP (Var i)"} but also a pair\<close>
    apply (rule Conj_EH Ex_EH)+
    apply simp_all
    apply (rule cut_same [where A = "OrdP (HPair (Var sm) (Var sn))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    \<comment> \<open>towards second two cases\<close>
    apply (rule Ex_E Disj_EH Conj_EH)+
    \<comment> \<open>case 3, @{term "OrdP (Var i)"} but also a pair\<close>
    apply (rule cut_same [where A = "OrdP (HPair (Var sm2) (Var sn2))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    \<comment> \<open>case 4, two pairs\<close>
    apply (rule Ex_E Disj_EH Conj_EH)+
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp_all)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule cut_same [where A = "HPair (Var sm) (Var sn) EQ HPair (Var sm2) (Var sn2)"])
    apply (blast intro: Sym Trans)
    apply (rule cut_same [where A = "SeqHRP (Var sn) (Var sn2') s' (Var n2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule cut_same [where A = "SeqHRP (Var sm) (Var sm2') s' (Var m2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (blast intro: Trans [OF Hyp Sym] intro!: HPair_cong)
    done
  hence "{OrdP (Var k)}
         \<turnstile> All j (All j' (All k' (SeqHRP x (Var j) s (Var k)
               IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ Var j))))"
    apply (rule All_D [where x = x, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
         \<turnstile> All j' (All k' (SeqHRP x y s (Var k) IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ y)))"
    apply (rule All_D [where x = y, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
          \<turnstile> All k' (SeqHRP x y s (Var k) IMP (SeqHRP x y' s' (Var k') IMP y' EQ y))"
    apply (rule All_D [where x = y', THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    apply (rule All_D [where x = u', THEN cut_same])
    using atoms by auto
  hence "{SeqHRP x y s (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    by (metis SeqHRP_imp_OrdP cut1)
  hence "{} \<turnstile> ((SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)))(k::=u)"
    by (metis Subst emptyE Assume MP_same Imp_I)
  hence "{} \<turnstile> SeqHRP x y s u IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    using atoms by simp
  thus ?thesis
    by (metis anti_deduction insert_commute)
qed

theorem HRP_unique: "{HRP x y, HRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (x,y,y')" "atom s' \<sharp> (x,y,y',s)"
          "atom k \<sharp> (x,y,y',s,s')" "atom k' \<sharp> (x,y,y',s,s',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP_unique HRP.simps [of s x y k]  HRP.simps [of s' x y' k'])
qed

subsection \<open>Finally The Function HF Itself\<close>

definition HF :: "hf \<Rightarrow> tm"
  where "HF \<equiv> hmemrec (\<lambda>f z. if Ord z then W z else Q_HPair (f (hfst z)) (f (hsnd z)))"

lemma HF_Ord [simp]: "Ord i \<Longrightarrow> HF i = W i"
  by (rule trans [OF def_hmemrec [OF HF_def]]) auto

lemma HF_pair [simp]: "HF (hpair x y) = Q_HPair (HF x) (HF y)"
  by (rule trans [OF def_hmemrec [OF HF_def]]) (auto simp: ecut_apply HF_def)

lemma SeqHR_hpair: "SeqHR x1 x3 s1 k1 \<Longrightarrow> SeqHR x2 x4 s2 k2 \<Longrightarrow> \<exists>s k. SeqHR \<langle>x1,x2\<rangle> (q_HPair x3 x4) s k"
  by (auto simp: SeqHR_def intro: BuildSeq2_combine)

lemma HR_H:  "coding_hf x \<Longrightarrow> HR x \<lbrakk>HF x\<rbrakk>e"
proof (induct x rule: hmem_rel_induct)
  case (step x) show ?case
  proof (cases "Ord x")
    case True thus ?thesis
      by (auto simp: HR_def SeqHR_def Ord_not_hpair WR_iff_eq_W [where e=e] intro!: BuildSeq2_exI)
  next
    case False
    then obtain x1 x2 where x: "x = \<langle>x1,x2\<rangle>"
      by (metis Ord_ord_of coding_hf.simps step.prems)
    then have x12: "(x1, x) \<in> hmem_rel" "(x2, x) \<in> hmem_rel"
      by (auto simp: hmem_rel_iff_hmem_eclose)
    have co12: "coding_hf x1"  "coding_hf x2" using False step x
      by (metis Ord_ord_of coding_hf_hpair)+
    hence "HR x1 \<lbrakk>HF x1\<rbrakk>e"  "HR x2 \<lbrakk>HF x2\<rbrakk>e"
      by (auto simp: x12 step)
    thus ?thesis using x SeqHR_hpair
      by (auto simp: HR_def q_defs)
  qed
qed

text\<open>Lemma 6.2\<close>
lemma HF_quot_coding_tm: "coding_tm t \<Longrightarrow> HF \<lbrakk>t\<rbrakk>e = \<guillemotleft>t\<guillemotright>"
  by (induct t rule: coding_tm.induct) (auto, simp add: HPair_def quot_Eats)

lemma HR_quot_fm: fixes A::fm shows "HR \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<lbrakk>\<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright>\<rbrakk>e"
  by (metis HR_H HF_quot_coding_tm coding_tm_hf quot_fm_coding)

lemma prove_HRP: fixes A::fm shows "{} \<turnstile> HRP \<guillemotleft>A\<guillemotright> \<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright>"
  by (auto simp: supp_conv_fresh Sigma_fm_imp_thm ground_aux_def ground_fm_aux_def HR_quot_fm)

section\<open>The Function K and Lemma 6.3\<close>

nominal_function KRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "atom y \<sharp> (v,x,x') \<Longrightarrow>
         KRP v x x' = Ex y (HRP x (Var y) AND SubstFormP v (Var y) x x')"
  by (auto simp: eqvt_def KRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma KRP_fresh_iff [simp]: "a \<sharp> KRP v x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> x \<and> a \<sharp> x'"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x')"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma KRP_subst [simp]: "(KRP v x x')(i::=t) = KRP (subst i t v) (subst i t x) (subst i t x')"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of y])
qed

declare KRP.simps [simp del]

lemma prove_SubstFormP: "{} \<turnstile> SubstFormP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright> \<guillemotleft>A\<guillemotright> \<guillemotleft>A(i::=\<guillemotleft>A\<guillemotright>)\<guillemotright>"
  by (auto simp: supp_conv_fresh Sigma_fm_imp_thm ground_aux_def SubstForm_quot)

lemma prove_KRP: "{} \<turnstile> KRP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>A\<guillemotright> \<guillemotleft>A(i::=\<guillemotleft>A\<guillemotright>)\<guillemotright>"
  by (auto simp: KRP.simps [of y]
           intro!: Ex_I [where x="\<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright>"] prove_HRP prove_SubstFormP)

lemma KRP_unique: "{KRP v x y, KRP v x y'} \<turnstile> y' EQ y"
proof -
  obtain u::name and u'::name where "atom u \<sharp> (v,x,y,y')" "atom u' \<sharp> (v,x,y,y',u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of u v x y] KRP.simps [of u' v x y']
             intro: SubstFormP_cong [THEN Iff_MP2_same]
                    SubstFormP_unique [THEN cut2] HRP_unique [THEN cut2])
qed

lemma KRP_subst_fm: "{KRP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>\<beta>\<guillemotright> (Var j)} \<turnstile> Var j EQ \<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright>"
  by (metis KRP_unique cut0 prove_KRP)

section\<open>The Diagonal Lemma and Gödel's Theorem\<close>

lemma diagonal:
  obtains \<delta> where "{} \<turnstile> \<delta> IFF \<alpha>(i::=\<guillemotleft>\<delta>\<guillemotright>)"  "supp \<delta> = supp \<alpha> - {atom i}"
proof -
  obtain k::name and j::name
    where atoms: "atom k \<sharp> (i,j,\<alpha>)" "atom j \<sharp> (i,\<alpha>)"
    by (metis obtain_fresh)
  define \<beta> where "\<beta> = Ex j (KRP \<guillemotleft>Var i\<guillemotright> (Var i) (Var j) AND \<alpha>(i ::= Var j))"
  hence 1: "{} \<turnstile> \<beta>(i ::= \<guillemotleft>\<beta>\<guillemotright>) IFF (Ex j (KRP \<guillemotleft>Var i\<guillemotright> (Var i) (Var j) AND \<alpha>(i ::= Var j)))(i ::= \<guillemotleft>\<beta>\<guillemotright>)"
    by (metis Iff_refl)
  have 2: "{} \<turnstile> (Ex j (KRP \<guillemotleft>Var i\<guillemotright> (Var i) (Var j) AND \<alpha>(i ::= Var j)))(i ::= \<guillemotleft>\<beta>\<guillemotright>) IFF
                Ex j (Var j EQ \<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright> AND \<alpha>(i::=Var j))"
    using atoms
    apply (auto intro!: Ex_cong Conj_cong KRP_subst_fm)
    apply (rule Iff_MP_same [OF Var_Eq_subst_Iff])
    apply (auto intro: prove_KRP thin0)
    done
  have 3: "{} \<turnstile> Ex j (Var j EQ \<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright> AND \<alpha>(i::=Var j)) IFF \<alpha>(i::=\<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright>)"
    using atoms
    apply auto
    apply (rule cut_same [OF Iff_MP2_same [OF Var_Eq_subst_Iff AssumeH(2)]])
    apply (auto intro: Ex_I [where x="\<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright>"])
    done
  have "supp (\<beta>(i ::= \<guillemotleft>\<beta>\<guillemotright>)) = supp \<alpha> - {atom i}" using atoms
    by (auto simp: fresh_at_base ground_fm_aux_def \<beta>_def supp_conv_fresh)
  thus ?thesis using atoms
    by (metis that 1 2 3 Iff_trans)
qed

text\<open>Gödel's first incompleteness theorem: Our theory is incomplete. NB it is provably consistent\<close>
theorem Goedel_I:
  obtains \<delta> where "{} \<turnstile> \<delta> IFF Neg (PfP \<guillemotleft>\<delta>\<guillemotright>)"  "\<not> {} \<turnstile> \<delta>"  "\<not> {} \<turnstile> Neg \<delta>"
                  "eval_fm e \<delta>"  "ground_fm \<delta>"
proof -
  fix i::name
  obtain \<delta> where        "{} \<turnstile> \<delta> IFF Neg ((PfP (Var i))(i::=\<guillemotleft>\<delta>\<guillemotright>))"
             and suppd: "supp \<delta> = supp (Neg (PfP (Var i))) - {atom i}"
    by (metis SyntaxN.Neg diagonal)
  then have diag: "{} \<turnstile> \<delta> IFF Neg (PfP \<guillemotleft>\<delta>\<guillemotright>)"
    by simp
  then have np: "\<not> {} \<turnstile> \<delta> \<and> \<not> {} \<turnstile> Neg \<delta>"
    by (metis Iff_MP_same NegNeg_D Neg_D Neg_cong consistent proved_iff_proved_PfP)
  then have "eval_fm e \<delta>" using hfthm_sound [where e=e, OF diag]
    by simp (metis Pf_quot_imp_is_proved)
  moreover have "ground_fm \<delta>" using suppd
    by (simp add: supp_conv_fresh ground_fm_aux_def subset_eq) (metis fresh_ineq_at_base)
  ultimately show ?thesis
    by (metis diag np that)
qed

end


(*<*)
theory IsarCliffLemmaApply
imports HEAP1LemmasIJW
begin
(*>*)

(*
An attempt to redo Cliff's "that lemma" as specified in IsarCliffLemma.thy, but in apply-style
proof. Also added apply-style proofs of "that lemma siblings", i.e. the remaining cases of
the original proof that gave rise to "that lemma".

The conjectures are taken from file Heap1ProofsIJW.thy:

- that_lemma: line 1189, the case when above is non-empty; below is empty.
- that_lemma_below: line 1342, below non empty, above empty.
- that_lemma_both: line 1445, both non-empty.

The cousins are from the reification proofs...

*)

lemma L1: "disjoint s1 s2 \<Longrightarrow> s3 \<subseteq> s2 \<Longrightarrow> disjoint s1 s3"
  apply (unfold disjoint_def)
  by blast

lemma L1pt5: "disjoint s2 (s1 - s2)"
  apply (unfold disjoint_def)
  by simp

lemma L2: "disjoint s1 s3 \<Longrightarrow> disjoint s2 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
  apply (unfold disjoint_def)
  by blast

lemma L3: "nat1_map f \<Longrightarrow> locs (S -\<triangleleft> f) \<subseteq> locs f"
  apply (intro subsetI)
  apply (unfold locs_def)
  apply (simp add: dom_ar_nat1_map)
  apply (elim bexE)
  apply (rule_tac x = "s" in bexI)
  apply (subst (asm) f_in_dom_ar_apply_subsume)
  apply assumption
  apply assumption
  apply (erule f_in_dom_ar_subsume)
  done

lemma L3pt5:
    "\<lbrakk> s\<in> dom f; Disjoint f; nat1_map f \<rbrakk> \<Longrightarrow> locs ({s}-\<triangleleft> f) = locs f - locs_of s (the (f s))"
  by (simp add: l_locs_of_dom_ar)

lemma L4: "nat1 n \<Longrightarrow> nat1 m \<Longrightarrow> locs_of d (n+m) = (locs_of d n) \<union> (locs_of (d+n) m)"
  apply (unfold locs_of_def)
  by auto

lemma that_lemma:
    "\<lbrakk> F1_inv f; disjoint (locs_of d s) (locs f); d+s \<in> dom f; nat1 s \<rbrakk> \<Longrightarrow>
        disjoint (locs_of d (s + (the (f (d+s)))))
                 (locs ({d+s} -\<triangleleft> f))"
  apply (unfold F1_inv_def)
  apply (elim conjE)
  apply (subst L4)
  apply assumption
  apply (simp add: nat1_map_def)
  apply (rule L2)
  apply (erule L1)
  apply (erule L3)
  apply (subst L3pt5)
  apply assumption+
  apply (rule L1pt5)
  done

lemma that_lemma_below:
    "\<lbrakk> F1_inv f; disjoint (locs_of d s) (locs f); below \<in> dom f; nat1 s;
        below + the (f below) = d \<rbrakk> \<Longrightarrow>
          disjoint (locs_of below (the (f below) + s))
                   (locs ({below} -\<triangleleft> f))"
  apply (unfold F1_inv_def)
  apply (elim conjE)
  apply (subst L4)
  apply (simp add: nat1_map_def)
  apply assumption
  apply (rule L2)
  apply (subst L3pt5)
  apply assumption
  apply assumption
  apply assumption
  apply (rule L1pt5)
  apply (erule ssubst)
  apply (erule L1)
  apply (erule L3)
  done

lemma disjoint_locs_widen1:
    "nat1_map f \<Longrightarrow> disjoint s (locs ({p} -\<triangleleft> f)) \<Longrightarrow> disjoint s (locs ({p, q} -\<triangleleft> f))"
  apply (erule L1)
  by (metis L3 dom_ar_nat1_map l_dom_ar_insert l_dom_ar_singletons_comm)

lemma disjoint_locs_widen2:
    "nat1_map f \<Longrightarrow> disjoint s (locs ({q} -\<triangleleft> f)) \<Longrightarrow> disjoint s (locs ({p, q} -\<triangleleft> f))"
  by (metis disjoint_locs_widen1 insert_commute)

lemma that_lemma_both:
    "\<lbrakk> F1_inv f; disjoint (locs_of d s) (locs f); below \<in> dom f; d+s \<in> dom f; nat1 s;
        below + the (f below) = d \<rbrakk> \<Longrightarrow>
          disjoint (locs_of below (the (f below) + s + the (f (d + s))))
                   (locs ( {below, d + s} -\<triangleleft> f))"
  apply (unfold F1_inv_def)
  apply (elim conjE)
  apply (subst L4)
  apply (simp add: nat1_map_def)
  apply (simp add: nat1_map_def)
  apply (rule L2)
  apply (subst L4)
  apply (simp add: nat1_map_def)
  apply assumption
  apply (rule L2)
  apply (rule disjoint_locs_widen1)
  apply assumption
  apply (subst L3pt5)
  apply assumption
  apply assumption
  apply assumption
  apply (rule L1pt5)
  apply (elim ssubst)
  apply (erule L1)
  apply (erule L3)
  apply (subst add.assoc[symmetric])
  apply (erule ssubst)
  apply (rule disjoint_locs_widen2)
  apply assumption
  apply (subst L3pt5)
  apply assumption
  apply assumption
  apply assumption
  apply (rule L1pt5)
  done

(*
The version below utilises a more general approach via Lemma L5 but requires a subgoal command.
The version above uses lemmas disjoint_locs_widen* that are more tailored to the current proof.
However, the version above lends as a good example of a "similar lemma is needed"
*)

lemma L5: "\<lbrakk> nat1_map f; s2 \<subseteq> s1 \<rbrakk> \<Longrightarrow> locs (s1 -\<triangleleft> f) \<subseteq> locs (s2 -\<triangleleft> f)"
  apply (unfold locs_def)
  apply (simp add: dom_ar_nat1_map)
  apply (intro subsetI)
  apply simp
  apply (elim bexE)
  apply (rule_tac x = "s" in bexI)
  apply (metis Diff_iff f_in_dom_ar_apply_subsume l_dom_dom_ar set_mp)
  by (metis l_dom_ar_not_in_dom l_dom_ar_not_in_dom2 l_in_dom_ar set_mp)

lemma that_lemma_both0:
    "\<lbrakk> F1_inv f; disjoint (locs_of d s) (locs f); below \<in> dom f; d+s \<in> dom f; nat1 s;
        below + the (f below) = d \<rbrakk> \<Longrightarrow>
          disjoint (locs_of below (the (f below) + s + the (f (d + s))))
                   (locs ( {below, d + s} -\<triangleleft> f))"
  apply (unfold F1_inv_def)
  apply (elim conjE)
  apply (subst L4)
  apply (simp add: nat1_map_def)
  apply (simp add: nat1_map_def)
  apply (rule L2)
  apply (subst L4)
  apply (simp add: nat1_map_def)
  apply assumption
  apply (rule L2)
  apply (subgoal_tac "disjoint (locs_of below (the (f below))) (locs ({below} -\<triangleleft> f))")
  apply (erule L1)
  apply (erule L5)
  apply (metis empty_subsetI insert_mono)
  apply (subst L3pt5)
  apply assumption
  apply assumption
  apply assumption
  apply (rule L1pt5)
  apply (erule ssubst)
  apply (erule L1)
  apply (erule L3)
  apply (subst add.assoc[symmetric])
  apply (erule ssubst)
  apply (subgoal_tac "disjoint (locs_of (d + s) (the (f (d + s)))) (locs ({d + s} -\<triangleleft> f))")
  apply (erule L1)
  apply (erule L5)
  apply (metis subset_insertI)
  apply (subst L3pt5)
  apply assumption
  apply assumption
  apply assumption
  apply (rule L1pt5)
  done

lemma that_lemma_bean: "F1_inv f1
                  \<Longrightarrow> d1+s1 \<in> dom f1
                  \<Longrightarrow> nat1 s1
                  (*FROM ORIGINAL file, clearly a refactoring needed! \<Longrightarrow> dispose1_above f1 d1 s1 \<noteq> Map.empty *)
                   \<Longrightarrow> locs ({d1 + s1} -\<triangleleft> f1) \<union> locs_of d1 (the (f1 (d1 + s1)) + s1) = locs f1 \<union> locs_of d1 s1"
oops

(* The new lemma! *)
lemma L6:
  "nat1_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> locs_of x (the(f x)) \<subseteq> locs f"
by (metis k_in_locs_iff subsetI)

(* My 'crafted' lemma from reify *)
lemma g2_subset: " B \<subseteq> A \<Longrightarrow> (A - B) \<union> (C \<union> B) = A \<union> C" by auto

(* declarative style *)
lemma that_lemma_bean:
assumes inv: "F1_inv f1"
  and   d1s1: "d1+s1 \<in> dom f1"
  and   nat1s1: "nat1 s1"
  shows "locs ({d1 + s1} -\<triangleleft> f1) \<union> locs_of d1 (the (f1 (d1 + s1)) + s1) = locs f1 \<union> locs_of d1 s1"
proof-
  from inv show ?thesis
  proof
    assume Disjf1: "Disjoint f1" and nat1mapf1: "nat1_map f1" and finitef1: "finite (dom f1)"
    have ar_split: "locs ({d1 + s1} -\<triangleleft> f1) = locs f1 - locs_of (d1+s1) (the (f1(d1+s1)))"
      by(subst L3pt5,rule d1s1, rule Disjf1, rule nat1mapf1,simp)
    have locs_of_plus_split: "locs_of d1 (the (f1 (d1 + s1)) + s1) = locs_of d1 s1 \<union> locs_of (d1 + s1) (the (f1 (d1 + s1)))"
    proof -
      have "locs_of d1 (the (f1 (d1 + s1)) + s1)  = locs_of d1 (s1 + (the (f1 (d1 + s1))))" by (simp add: add.commute)
      also from nat1s1 have "...= locs_of d1 s1   \<union> locs_of (d1 + s1) (the (f1 (d1 + s1)))"
        by (rule L4,metis d1s1 nat1_map_def nat1mapf1)
      finally show ?thesis .
    qed
    thm ar_split
        locs_of_plus_split
    (* I've dropped these two lines in the proof *)
    show ?thesis (* And now subsititute... Bad Isabelle style... *)
    apply (subst ar_split)
    apply (subst locs_of_plus_split)
    (* It's very easy to think this an easy proof now.
       BUT: set minus lacks nice properties for commutativity and distributivity
    *)
    apply (subst g2_subset)
    apply (rule L6, rule nat1mapf1, rule d1s1)
    apply (rule refl)
done
qed
qed

(* apply style, going from the RHS... *)
lemma that_lemma_bean_apply: "F1_inv f1
                  \<Longrightarrow> d1+s1 \<in> dom f1
                  \<Longrightarrow> nat1 s1
                  \<Longrightarrow> locs ({d1 + s1} -\<triangleleft> f1) \<union> locs_of d1 (the (f1 (d1 + s1)) + s1) = locs f1 \<union> locs_of d1 s1"
apply (subgoal_tac "locs f1 =  locs ({d1 + s1} -\<triangleleft> f1) \<union> locs_of (d1+s1) (the (f1(d1+s1)))")
defer
  apply (subst L3pt5)
  apply simp
  apply (simp add: F1_inv_def)
  apply (simp add: F1_inv_def)
  apply (simp)
  apply (subst Un_absorb2)
  apply (rule L6, simp_all add: F1_inv_def)
apply (subgoal_tac "locs_of (d1 + s1) (the (f1 (d1 + s1))) \<union> locs_of d1 s1 = locs_of d1 (the (f1 (d1 + s1)) + s1)")
defer
  apply (subst add.commute [of "(the (f1 (d1 + s1)))"])
  apply (subst L4)
    apply simp
    apply (metis nat1_map_def)
    apply (metis Un_commute)
by auto

(*<*)
end
(*>*)


(*
    Title:      System_Of_Equations_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Solving systems of equations using the Gauss Jordan algorithm over nested IArrays\<close>

theory System_Of_Equations_IArrays
imports
  System_Of_Equations
  Bases_Of_Fundamental_Subspaces_IArrays
begin

subsection\<open>Previous definitions and properties\<close>

definition greatest_not_zero :: "'a::{zero} iarray => nat"
  where "greatest_not_zero A = the (List.find (\<lambda>n. A !! n \<noteq> 0) (rev [0..<IArray.length A]))"

lemma vec_to_iarray_exists:
shows "(\<exists>b. A $ b \<noteq> 0) = IArray.exists (\<lambda>b. (vec_to_iarray A) !! b \<noteq> 0) (IArray[0..<IArray.length (vec_to_iarray A)])"
proof (unfold IArray.exists_def length_vec_to_iarray, auto simp del: IArray.sub_def)
  fix b assume Ab: "A $ b \<noteq> 0"
  show "\<exists>b\<in>{0..<CARD('a)}. vec_to_iarray A !! b \<noteq> 0"
    by (rule bexI[of _ "to_nat b"], unfold vec_to_iarray_nth', auto simp add: Ab to_nat_less_card[of b])
next
   fix b assume b: "b < CARD('a)" and Ab_vec: "vec_to_iarray A !! b \<noteq> 0"
   show "\<exists>b. A $ b \<noteq> 0" by (rule exI[of _ "from_nat b"], metis Ab_vec vec_to_iarray_nth[OF b])
qed

corollary vec_to_iarray_exists':
shows "(\<exists>b. A $ b \<noteq> 0) = IArray.exists (\<lambda>b. (vec_to_iarray A) !! b \<noteq> 0) (IArray (rev [0..<IArray.length (vec_to_iarray A)]))"
by (simp add: vec_to_iarray_exists Option.is_none_def find_None_iff)

lemma not_is_zero_iarray_eq_iff: "(\<exists>b. A $ b \<noteq> 0) = (\<not> is_zero_iarray (vec_to_iarray A))"
by (metis (full_types) is_zero_iarray_eq_iff vec_eq_iff zero_index)

lemma vec_to_iarray_greatest_not_zero:
assumes ex_b: "(\<exists>b. A $ b \<noteq> 0)"
shows "greatest_not_zero (vec_to_iarray A) = to_nat (GREATEST b. A $ b \<noteq> 0)"
proof -
let ?P="(\<lambda>n. (vec_to_iarray A) !! n \<noteq> 0)"
let ?xs="(rev [0..<IArray.length (vec_to_iarray A)])"
have "\<exists>a. (List.find ?P ?xs) = Some a"
  proof(rule ccontr, simp, unfold find_None_iff)
    assume "\<not> (\<exists>x. x \<in> set (rev [0..<length (IArray.list_of (vec_to_iarray A))]) \<and> IArray.list_of (vec_to_iarray A) ! x \<noteq> 0)"
    thus False using ex_b
    unfolding set_rev by (auto, unfold IArray.length_def[symmetric] IArray.sub_def[symmetric] length_vec_to_iarray,metis to_nat_less_card vec_to_iarray_nth')
  qed
from this obtain a where a: "(List.find ?P ?xs) = Some a" by blast
from this obtain ia where ia_less_length: "ia<length ?xs"
and P_xs_ia: "?P (?xs!ia)" and a_eq: "a = ?xs!ia" and all_zero: "(\<forall>j<ia. \<not> ?P (?xs!j))"
unfolding find_Some_iff by auto
have ia_less_card: "ia < CARD('a)" using ia_less_length by (metis diff_zero length_rev length_upt length_vec_to_iarray)
have ia_less_length': "ia < length ([0..<IArray.length (vec_to_iarray A)])" using ia_less_length unfolding length_rev .
have a_less_card: "a < CARD('a)" unfolding a_eq unfolding rev_nth[OF ia_less_length']
  using nth_upt[of 0 "(length [0..<IArray.length (vec_to_iarray A)] - Suc ia)" "(length [0..<IArray.length (vec_to_iarray A)])" ]
  by (metis diff_less length_upt length_vec_to_iarray minus_nat.diff_0 plus_nat.add_0 zero_less_Suc zero_less_card_finite)
have "(GREATEST b. A $ b \<noteq> 0) = from_nat a"
  proof (rule Greatest_equality)
    have "A $ from_nat a = (vec_to_iarray A) !! a" by (rule vec_to_iarray_nth[symmetric,OF a_less_card])
    also have "... \<noteq> 0"  using P_xs_ia unfolding a_eq[symmetric] .
    finally show "A $ from_nat a \<noteq> 0" .
    next
    fix y assume Ay: "A $ y \<noteq> 0"
    show "y \<le> from_nat a"
    proof (rule ccontr)
      assume "\<not> y \<le> from_nat a" hence y_greater_a: "y > from_nat a" by simp
      have y_greater_a': "to_nat y > a" using y_greater_a using to_nat_mono[of "from_nat a" y] using to_nat_from_nat_id by (metis a_less_card)
      have "a = ?xs ! ia" using a_eq .
      also have "... = [0..<IArray.length (vec_to_iarray A)] ! (length [0..<IArray.length (vec_to_iarray A)] - Suc ia)" by (rule rev_nth[OF ia_less_length'])
      also have "... = 0 + (length [0..<IArray.length (vec_to_iarray A)] - Suc ia)" apply (rule nth_upt) using ia_less_length' by fastforce
      also have "... = (length [0..<IArray.length (vec_to_iarray A)] - Suc ia)" by simp
      finally have "a = (length [0..<IArray.length (vec_to_iarray A)] - Suc ia)" .
      hence ia_eq: "ia = length [0..<IArray.length (vec_to_iarray A)] - (Suc a)"
        by (metis Suc_diff_Suc Suc_eq_plus1_left diff_diff_cancel less_imp_le ia_less_length length_rev)
      define ja where "ja = length [0..<IArray.length (vec_to_iarray A)] - to_nat y - 1"
      have ja_less_length: "ja < length [0..<IArray.length (vec_to_iarray A)]" unfolding ja_def
        using ia_eq ia_less_length' by (simp add: algebra_simps )
      have suc_i_le: "IArray.length (vec_to_iarray A)\<ge>Suc (to_nat y)" unfolding vec_to_iarray_def  using to_nat_less_card[of y] by auto
      have "?xs ! ja = [0..<IArray.length (vec_to_iarray A)] ! (length [0..<IArray.length (vec_to_iarray A)] - Suc ja)" unfolding rev_nth[OF ja_less_length] ..
      also have "... = 0 + (length [0..<IArray.length (vec_to_iarray A)] - Suc ja)" apply (rule nth_upt, auto simp del: IArray.length_def) unfolding ja_def
      by (metis diff_Suc_less ia_less_length' length_upt less_nat_zero_code minus_nat.diff_0 neq0_conv)
      also have "... = (length [0..<IArray.length (vec_to_iarray A)] - Suc ja)" by simp
      also have "... = to_nat y" unfolding ja_def using suc_i_le by force
      finally have xs_ja_eq_y: "?xs ! ja = to_nat y" .
      have ja_less_ia: "ja < ia" unfolding ja_def ia_eq by (auto simp del: IArray.length_def, metis Suc_leI suc_i_le diff_less_mono2 le_imp_less_Suc less_le_trans y_greater_a')
      hence eq_0: "vec_to_iarray A !! (?xs ! ja) = 0" using all_zero by simp
      hence "A $ y = 0" using vec_to_iarray_nth'[of A y] unfolding xs_ja_eq_y by simp
      thus False using Ay by contradiction
    qed
qed
thus ?thesis unfolding greatest_not_zero_def a unfolding to_nat_eq[symmetric]
  unfolding to_nat_from_nat_id[OF a_less_card] by simp
qed

subsection\<open>Consistency and inconsistency\<close>

definition "consistent_iarrays A b = (let GJ=Gauss_Jordan_iarrays_PA A;
                                           rank_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x];
                                           P_mult_b = fst(GJ) *iv b
                                           in (rank_A \<ge> (if  (\<not> is_zero_iarray P_mult_b)
                                           then (greatest_not_zero P_mult_b + 1) else 0)))"

definition "inconsistent_iarrays A b = (\<not> consistent_iarrays A b)"

lemma matrix_to_iarray_consistent[code]: "consistent A b = consistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
unfolding consistent_eq_rank_ge_code
unfolding consistent_iarrays_def Let_def
unfolding Gauss_Jordan_PA_eq
unfolding rank_Gauss_Jordan_code[symmetric, unfolded Let_def]
unfolding snd_Gauss_Jordan_iarrays_PA_eq
unfolding rank_iarrays_code[symmetric]
unfolding matrix_to_iarray_rank
unfolding matrix_to_iarray_fst_Gauss_Jordan_PA[symmetric]
unfolding vec_to_iarray_matrix_matrix_mult[symmetric]
unfolding not_is_zero_iarray_eq_iff
using vec_to_iarray_greatest_not_zero[unfolded not_is_zero_iarray_eq_iff]
by force

lemma matrix_to_iarray_inconsistent[code]: "inconsistent A b = inconsistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
unfolding inconsistent_def inconsistent_iarrays_def
unfolding matrix_to_iarray_consistent ..

definition "solve_consistent_rref_iarrays A b
  = IArray.of_fun (\<lambda>j. if (IArray.exists (\<lambda>i. A !! i !! j = 1 \<and> j=least_non_zero_position_of_vector (row_iarray i A)) (IArray[0..<nrows_iarray A]))
  then b !! (least_non_zero_position_of_vector (column_iarray j A)) else 0) (ncols_iarray A)"

lemma exists_solve_consistent_rref:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
shows "(\<exists>i. A $ i $ j = 1 \<and> j = (LEAST n. A $ i $ n \<noteq> 0))
  = (IArray.exists (\<lambda>i. (matrix_to_iarray A) !! i !! (to_nat j) = 1
  \<and> (to_nat j)=least_non_zero_position_of_vector (row_iarray i (matrix_to_iarray A))) (IArray[0..<nrows_iarray (matrix_to_iarray A)]))"
proof (rule)
assume "\<exists>i. A $ i $ j = 1 \<and> j = (LEAST n. A $ i $ n \<noteq> 0)"
from this obtain i where Aij: "A $ i $ j = 1" and j_eq: "j = (LEAST n. A $ i $ n \<noteq> 0)" by blast
show "IArray.exists (\<lambda>i. matrix_to_iarray A !! i !! to_nat j = 1 \<and> to_nat j = least_non_zero_position_of_vector (row_iarray i (matrix_to_iarray A)))
     (IArray [0..<nrows_iarray (matrix_to_iarray A)])"
     unfolding IArray.exists_def find_Some_iff
     apply (rule bexI[of _ "to_nat i"])+
     proof (auto, unfold IArray.sub_def[symmetric])
      show "to_nat i < nrows_iarray (matrix_to_iarray A)" unfolding matrix_to_iarray_nrows[symmetric] nrows_def using to_nat_less_card by fast
               have "to_nat j = to_nat (LEAST n. A $ i $ n \<noteq> 0)" unfolding j_eq by simp
         also have "... = to_nat (LEAST n. A $ i $ n \<noteq> 0 \<and> 0\<le>n)" by (metis least_mod_type)
         also have "...= least_non_zero_position_of_vector_from_index (vec_to_iarray (row i A)) (to_nat (0::'cols))"
           proof (rule vec_to_iarray_least_non_zero_position_of_vector_from_index''[symmetric, of "0::'cols" i A])
              show "\<not> vector_all_zero_from_index (to_nat (0::'cols), vec_to_iarray (row i A))"
                unfolding vector_all_zero_from_index_eq[symmetric, of "0::'cols" "row i A"] unfolding row_def vec_nth_inverse using Aij least_mod_type[of j] by fastforce
          qed
          also have "... = least_non_zero_position_of_vector (row_iarray (to_nat i) (matrix_to_iarray A))" unfolding vec_to_iarray_row least_non_zero_position_of_vector_def
          unfolding to_nat_0 ..
         finally show "to_nat j = least_non_zero_position_of_vector (row_iarray (to_nat i) (matrix_to_iarray A))" .
         show "matrix_to_iarray A !! mod_type_class.to_nat i !! mod_type_class.to_nat j = 1" unfolding matrix_to_iarray_nth using Aij .
         qed
next
assume ex_eq: "IArray.exists (\<lambda>i. matrix_to_iarray A !! i !! to_nat j = 1 \<and> to_nat j = least_non_zero_position_of_vector (row_iarray i (matrix_to_iarray A)))
     (IArray [0..<nrows_iarray (matrix_to_iarray A)])"
have "\<exists>y. List.find (\<lambda>i. matrix_to_iarray A !! i !! to_nat j = 1 \<and> to_nat j = least_non_zero_position_of_vector (row_iarray i (matrix_to_iarray A)))
         [0..<nrows_iarray (matrix_to_iarray A)] = Some y"
         proof (rule ccontr, simp del: IArray.length_def IArray.sub_def, unfold find_None_iff)
         assume" \<not> (\<exists>x. x \<in> set [0..<nrows_iarray (matrix_to_iarray A)] \<and>
            matrix_to_iarray A !! x !! mod_type_class.to_nat j = 1 \<and> mod_type_class.to_nat j = least_non_zero_position_of_vector (row_iarray x (matrix_to_iarray A)))"
            thus False using ex_eq unfolding IArray.exists_def by auto
         qed
from this obtain y where y: "List.find (\<lambda>i. matrix_to_iarray A !! i !! to_nat j = 1 \<and> to_nat j = least_non_zero_position_of_vector (row_iarray i (matrix_to_iarray A)))
         [0..<nrows_iarray (matrix_to_iarray A)] = Some y" by blast
from this obtain i where i_less_length: "i<length [0..<nrows_iarray (matrix_to_iarray A)]" and
     Aij_1: "matrix_to_iarray A !! ([0..<nrows_iarray (matrix_to_iarray A)] ! i) !! to_nat j = 1"
and j_eq: "to_nat j = least_non_zero_position_of_vector (row_iarray ([0..<nrows_iarray (matrix_to_iarray A)] ! i) (matrix_to_iarray A))" and
  y_eq: "y = [0..<nrows_iarray (matrix_to_iarray A)] ! i"
    and least: "(\<forall>ja<i. \<not> (matrix_to_iarray A !! ([0..<nrows_iarray (matrix_to_iarray A)] ! ja) !! to_nat j = 1 \<and>
                to_nat j = least_non_zero_position_of_vector (row_iarray ([0..<nrows_iarray (matrix_to_iarray A)] ! ja) (matrix_to_iarray A))))"
unfolding find_Some_iff by blast
show "\<exists>i. A $ i $ j = 1 \<and> j = (LEAST n. A $ i $ n \<noteq> 0)"
  proof (rule exI[of _ "from_nat i"], rule conjI)
    have i_rw: "[0..<nrows_iarray (matrix_to_iarray A)] ! i = i" using nth_upt[of 0 i "nrows_iarray (matrix_to_iarray A)"] using i_less_length by auto
    have i_less_card: "i < CARD ('rows)" using i_less_length unfolding nrows_iarray_def matrix_to_iarray_def by auto
    show A_ij: "A $ from_nat i $ j = 1"
      using Aij_1 unfolding i_rw using matrix_to_iarray_nth[of A "from_nat i" j] unfolding to_nat_from_nat_id[OF i_less_card] by simp
    have "to_nat j = least_non_zero_position_of_vector (row_iarray ([0..<nrows_iarray (matrix_to_iarray A)] ! i) (matrix_to_iarray A))" using j_eq .
    also have "... = least_non_zero_position_of_vector_from_index (row_iarray i (matrix_to_iarray A)) 0"
      unfolding least_non_zero_position_of_vector_def i_rw ..
    also have "... = least_non_zero_position_of_vector_from_index (vec_to_iarray (row (from_nat i) A)) (to_nat (0::'cols))" unfolding vec_to_iarray_row
    unfolding to_nat_from_nat_id[OF i_less_card] unfolding to_nat_0 ..
    also have "... = to_nat (LEAST n. A $ (from_nat i) $ n \<noteq> 0 \<and> 0 \<le> n)"
        proof (rule vec_to_iarray_least_non_zero_position_of_vector_from_index'')
           show "\<not> vector_all_zero_from_index (to_nat (0::'cols), vec_to_iarray (row (from_nat i) A))"
           unfolding vector_all_zero_from_index_eq[symmetric] using A_ij by (metis iarray_to_vec_vec_to_iarray least_mod_type vec_matrix vec_to_iarray_row' zero_neq_one)
        qed
    also have "... = to_nat (LEAST n. A $ (from_nat i) $ n \<noteq> 0)" using least_mod_type by metis
    finally show "j = (LEAST n. A $ from_nat i $ n \<noteq> 0)" unfolding to_nat_eq .
    qed
qed

lemma to_nat_the_solve_consistent_rref:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
and exists: "(\<exists>i. A $ i $ j = 1 \<and> j = (LEAST n. A $ i $ n \<noteq> 0))"
shows "to_nat (THE i. A $ i $ j = 1) = least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A))"
proof -
obtain i where Aij: "A $ i $ j = 1" and j:"j = (LEAST n. A $ i $ n \<noteq> 0)" using exists by blast
have "least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)) =
    least_non_zero_position_of_vector (vec_to_iarray (column j A))" unfolding vec_to_iarray_column ..
    also have "... = least_non_zero_position_of_vector_from_index (vec_to_iarray (column j A)) (to_nat (0::'rows))" unfolding least_non_zero_position_of_vector_def to_nat_0 ..
    also have "... = to_nat (LEAST n. A $ n $ j \<noteq> 0 \<and> 0 \<le> n)"
      proof (rule vec_to_iarray_least_non_zero_position_of_vector_from_index')
        show "\<not> vector_all_zero_from_index (to_nat (0::'rows), vec_to_iarray (column j A))"
          unfolding vector_all_zero_from_index_eq[symmetric] column_def using Aij least_mod_type[of i] by fastforce
      qed
    also have "... = to_nat (LEAST n. A $ n $ j \<noteq> 0)" using least_mod_type by metis
    finally have least_eq: "least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)) = to_nat (LEAST n. A $ n $ j \<noteq> 0)" .
    have i_eq_least: "i=(LEAST n. A $ n $ j \<noteq> 0)"
      proof (rule Least_equality[symmetric])
         show "A $ i $ j \<noteq> 0" by (metis Aij zero_neq_one)
         show "\<And>y. A $ y $ j \<noteq> 0 \<Longrightarrow> i \<le> y" by (metis (mono_tags) Aij is_zero_row_def' j order_refl rref rref_condition4 zero_neq_one)
     qed
have the_eq_least_pos: "(THE i. A $ i $ j = 1) = from_nat (least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)))"
  proof (rule the_equality)
      show " A $ from_nat (least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A))) $ j = 1"
    unfolding least_eq from_nat_to_nat_id i_eq_least[symmetric] using Aij .
    fix a assume a: "A $ a $ j = 1"
    show "a = from_nat (least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)))"
      unfolding least_eq from_nat_to_nat_id
      by (metis Aij a i_eq_least is_zero_row_def' j rref rref_condition4_explicit zero_neq_one)
qed
have "to_nat (THE i. A $ i $ j = 1) = to_nat (from_nat (least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)))::'rows)" using the_eq_least_pos by auto
also have "... = (least_non_zero_position_of_vector (column_iarray (to_nat j) (matrix_to_iarray A)))" by (rule to_nat_from_nat_id, unfold least_eq, simp add: to_nat_less_card)
also have "... = to_nat (LEAST n. A $ n $ j \<noteq> 0)" unfolding least_eq from_nat_to_nat_id ..
finally have "(THE i. A $ i $ j = 1) = (LEAST n. A $ n $ j \<noteq> 0)" unfolding to_nat_eq .
thus ?thesis unfolding least_eq from_nat_to_nat_id unfolding to_nat_eq .
qed

lemma iarray_exhaust2:
"(xs = ys) = (IArray.list_of xs = IArray.list_of ys)"
by (metis iarray.exhaust list_of.simps)

lemma vec_to_iarray_solve_consistent_rref:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
shows "vec_to_iarray (solve_consistent_rref A b) = solve_consistent_rref_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
proof(unfold iarray_exhaust2 list_eq_iff_nth_eq IArray.length_def[symmetric] IArray.sub_def[symmetric], rule conjI)
  show "IArray.length (vec_to_iarray (solve_consistent_rref A b)) = IArray.length (solve_consistent_rref_iarrays (matrix_to_iarray A) (vec_to_iarray b))"
  unfolding solve_consistent_rref_def solve_consistent_rref_iarrays_def
  unfolding ncols_iarray_def matrix_to_iarray_def by (simp add: vec_to_iarray_def)
show "\<forall>i<IArray.length (vec_to_iarray (solve_consistent_rref A b)). vec_to_iarray (solve_consistent_rref A b) !! i = solve_consistent_rref_iarrays (matrix_to_iarray A) (vec_to_iarray b) !! i"
proof (clarify)
fix i assume i: "i < IArray.length (vec_to_iarray (solve_consistent_rref A b))"
hence i_less_card: "i<CARD('cols)" unfolding vec_to_iarray_def by auto
hence i_less_ncols: "i<(ncols_iarray (matrix_to_iarray A))" unfolding ncols_eq_card_columns .
show "vec_to_iarray (solve_consistent_rref A b) !! i = solve_consistent_rref_iarrays (matrix_to_iarray A) (vec_to_iarray b) !! i"
unfolding vec_to_iarray_nth[OF i_less_card]
unfolding solve_consistent_rref_def
unfolding vec_lambda_beta
unfolding solve_consistent_rref_iarrays_def
unfolding of_fun_nth[OF i_less_ncols]
unfolding exists_solve_consistent_rref[OF rref, of "from_nat i", symmetric, unfolded to_nat_from_nat_id[OF i_less_card]]
using to_nat_the_solve_consistent_rref[OF rref, of "from_nat i", symmetric, unfolded to_nat_from_nat_id[OF i_less_card]]
using vec_to_iarray_nth' by metis
qed
qed

subsection\<open>Independence and dependence\<close>

definition "independent_and_consistent_iarrays A b =
  (let GJ = Gauss_Jordan_iarrays_PA A;
      rank_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x];
      P_mult_b = fst GJ *iv b;
      consistent_A = ((if \<not> is_zero_iarray P_mult_b then greatest_not_zero P_mult_b + 1 else 0) \<le> rank_A);
      dim_solution_set = ncols_iarray A - rank_A
      in consistent_A \<and> dim_solution_set = 0)"

definition "dependent_and_consistent_iarrays A b =
  (let GJ = Gauss_Jordan_iarrays_PA A;
      rank_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x];
      P_mult_b = fst GJ *iv b;
      consistent_A = ((if \<not> is_zero_iarray P_mult_b then greatest_not_zero P_mult_b + 1 else 0) \<le> rank_A);
      dim_solution_set = ncols_iarray A - rank_A
      in consistent_A \<and> dim_solution_set > 0)"

lemma matrix_to_iarray_independent_and_consistent[code]:
shows "independent_and_consistent A b = independent_and_consistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
unfolding independent_and_consistent_def
unfolding independent_and_consistent_iarrays_def
unfolding dim_solution_set_homogeneous_eq_dim_null_space
unfolding matrix_to_iarray_consistent
unfolding consistent_iarrays_def
unfolding dim_null_space_iarray
unfolding rank_iarrays_code
unfolding snd_Gauss_Jordan_iarrays_PA_eq[symmetric]
unfolding Let_def ..

lemma matrix_to_iarray_dependent_and_consistent[code]:
shows "dependent_and_consistent A b = dependent_and_consistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
unfolding dependent_and_consistent_def
unfolding dependent_and_consistent_iarrays_def
unfolding dim_solution_set_homogeneous_eq_dim_null_space
unfolding matrix_to_iarray_consistent
unfolding consistent_iarrays_def
unfolding dim_null_space_iarray
unfolding rank_iarrays_code
unfolding snd_Gauss_Jordan_iarrays_PA_eq[symmetric]
unfolding Let_def ..

subsection\<open>Solve a system of equations over nested IArrays\<close>

definition "solve_system_iarrays A b = (let A' = Gauss_Jordan_iarrays_PA A in (snd A', fst A' *iv b))"

lemma matrix_to_iarray_fst_solve_system: "matrix_to_iarray (fst (solve_system A b)) = fst (solve_system_iarrays (matrix_to_iarray A) (vec_to_iarray b))"
unfolding solve_system_def solve_system_iarrays_def Let_def fst_conv
by (metis matrix_to_iarray_snd_Gauss_Jordan_PA)

lemma vec_to_iarray_snd_solve_system: "vec_to_iarray (snd (solve_system A b)) = snd (solve_system_iarrays (matrix_to_iarray A) (vec_to_iarray b))"
unfolding solve_system_def solve_system_iarrays_def Let_def snd_conv
by (metis matrix_to_iarray_fst_Gauss_Jordan_PA vec_to_iarray_matrix_matrix_mult)

definition "solve_iarrays A b = (let GJ_P=Gauss_Jordan_iarrays_PA A;
                        P_mult_b = fst GJ_P *iv b;
                        rank_A = length [x\<leftarrow>IArray.list_of (snd GJ_P) . \<not> is_zero_iarray x];
                        consistent_Ab = (if \<not> is_zero_iarray P_mult_b then greatest_not_zero P_mult_b + 1 else 0) \<le> rank_A;
                        GJ_transpose = Gauss_Jordan_iarrays_PA (transpose_iarray A);
                        basis =  set (map (\<lambda>i. row_iarray i (fst GJ_transpose)) [rank_A..<ncols_iarray A])
                        in (if consistent_Ab then Some (solve_consistent_rref_iarrays (snd GJ_P) P_mult_b,basis) else None))"

definition "pair_vec_vecset A = (if Option.is_none A then None else Some (vec_to_iarray (fst (the A)), vec_to_iarray` (snd (the A))))"

lemma pair_vec_vecset_solve[code_unfold]:
shows "pair_vec_vecset (solve A b) = solve_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
unfolding pair_vec_vecset_def
proof (auto)
assume none_solve_Ab: "Option.is_none (solve A b)"
show "None = solve_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
    proof -
      define GJ_P where "GJ_P = Gauss_Jordan_iarrays_PA (matrix_to_iarray A)"
      define P_mult_b where "P_mult_b = fst GJ_P *iv vec_to_iarray b"
      define rank_A where "rank_A = length [x\<leftarrow>IArray.list_of (snd GJ_P). \<not> is_zero_iarray x]"
      have "\<not> consistent A b" using none_solve_Ab unfolding solve_def unfolding Option.is_none_def by auto
      hence "\<not> consistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)" using matrix_to_iarray_consistent by auto
      hence "\<not> (if \<not> is_zero_iarray P_mult_b then greatest_not_zero P_mult_b + 1 else 0) \<le> rank_A"
        unfolding GJ_P_def P_mult_b_def rank_A_def
        using consistent_iarrays_def unfolding Let_def by fast
      thus ?thesis unfolding solve_iarrays_def Let_def unfolding GJ_P_def P_mult_b_def rank_A_def by presburger
    qed
next
assume not_none: "\<not> Option.is_none (solve A b)"
show "Some (vec_to_iarray (fst (the (solve A b))), vec_to_iarray ` snd (the (solve A b))) = solve_iarrays (matrix_to_iarray A) (vec_to_iarray b)"
proof -
  define GJ_P where "GJ_P = Gauss_Jordan_iarrays_PA (matrix_to_iarray A)"
  define P_mult_b where "P_mult_b = fst GJ_P *iv vec_to_iarray b"
  define rank_A where "rank_A = length [x\<leftarrow>IArray.list_of (snd GJ_P) . \<not> is_zero_iarray x]"
  define GJ_transpose where "GJ_transpose = Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A))"
  define basis where "basis = set (map (\<lambda>i. row_iarray i (fst GJ_transpose)) [rank_A..<ncols_iarray (matrix_to_iarray A)])"
  define P_mult_b where "P_mult_b = fst GJ_P *iv vec_to_iarray b"
  have consistent_Ab: "consistent A b" using not_none unfolding solve_def unfolding Option.is_none_def by metis
  hence "consistent_iarrays (matrix_to_iarray A) (vec_to_iarray b)" using matrix_to_iarray_consistent by auto
  hence "(if \<not> is_zero_iarray P_mult_b then greatest_not_zero P_mult_b + 1 else 0) \<le> rank_A"
      unfolding GJ_P_def P_mult_b_def rank_A_def
      using consistent_iarrays_def unfolding Let_def by fast
  hence solve_iarrays_rw: "solve_iarrays (matrix_to_iarray A) (vec_to_iarray b) = Some (solve_consistent_rref_iarrays (snd GJ_P) P_mult_b, basis)"
  unfolding solve_iarrays_def Let_def P_mult_b_def GJ_P_def rank_A_def basis_def GJ_transpose_def by auto
  have snd_rw: "vec_to_iarray ` basis_null_space A = basis" unfolding basis_def GJ_transpose_def rank_A_def GJ_P_def
       unfolding vec_to_iarray_basis_null_space unfolding basis_null_space_iarrays_def Let_def
       unfolding snd_Gauss_Jordan_iarrays_PA_eq
       unfolding rank_iarrays_code[symmetric]
       unfolding matrix_to_iarray_transpose[symmetric]
       unfolding matrix_to_iarray_rank[symmetric]
       unfolding rank_transpose[symmetric, of A] ..
  have fst_rw: "vec_to_iarray (solve_consistent_rref (fst (solve_system A b)) (snd (solve_system A b))) = solve_consistent_rref_iarrays (snd GJ_P) P_mult_b"
    using vec_to_iarray_solve_consistent_rref[OF rref_Gauss_Jordan, of A "fst (Gauss_Jordan_PA A) *v b"]
    unfolding solve_system_def Let_def fst_conv
    unfolding Gauss_Jordan_PA_eq snd_conv
    unfolding GJ_P_def P_mult_b_def
    unfolding vec_to_iarray_matrix_matrix_mult
    unfolding matrix_to_iarray_fst_Gauss_Jordan_PA[symmetric]
    unfolding matrix_to_iarray_snd_Gauss_Jordan_PA[symmetric]
    unfolding Gauss_Jordan_PA_eq .
  show ?thesis unfolding solve_iarrays_rw
    unfolding solve_def if_P[OF consistent_Ab] option.sel fst_conv snd_conv
    unfolding fst_rw snd_rw ..
qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_escape_NoSpecial
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Token = A | B | C | D | ESC | P | Q | R

fun isSpecial :: "Token => bool" where
  "isSpecial x =
   (case x of
      ESC => True
      | P => True
      | Q => True
      | R => True
      | other => False)"

fun ok :: "Token => bool" where
  "ok x =
   ((~ (isSpecial x)) |
      (case x of
        ESC => True
        | other => False))"

fun formula :: "Token list => bool" where
  "formula (nil2) = True"
| "formula (cons2 y xs) = ((ok y) & (formula xs))"

fun code :: "Token => Token" where
  "code x =
   (case x of
      ESC => ESC
      | P => A
      | Q => B
      | R => C
      | other => x)"

fun escape :: "Token list => Token list" where
  "escape (nil2) = nil2"
| "escape (cons2 y xs) =
     (if isSpecial y then cons2 ESC (cons2 (code y) (escape xs)) else
        cons2 y (escape xs))"

theorem property0 :
  "formula (escape xs)"
  oops

end


section \<open>Preference Vectors\<close>

theory Vectors
  imports Preference_Relation Profile
begin

subsection \<open>Definition\<close>

type_synonym 'a pair_candid_points = "'a \<times> nat"
type_synonym 'a Pair_Vector = "('a pair_candid_points) set"
type_synonym 'a Pair_Vectors = "('a Pair_Vector) list"

type_synonym  Range_vector = "nat list"
type_synonym  Range_vector_list = "( Range_vector) list"

(*Jeder Kandidat kommt genau einmal vor*)
(*fun in_vector :: "'a Pair_Vector \<Rightarrow> 'a \<Rightarrow> bool" where
"in_vector v x = (\<exists>(a, _) \<in> v. x = a)"

lemma testing_vector:
  assumes "finite v"
  shows " (a, b) \<in> v \<Longrightarrow> card v > 0" using assms card_0_eq by auto

fun in_vector2 :: "'a Pair_Vector \<Rightarrow> 'a \<Rightarrow> bool" where
"in_vector2 v x = (card{\<forall>(a, b) \<in> v. x = a} = 1)"

lemma testing_vec:
  assumes "finite A" and "finite v"
  shows "\<forall>x\<in>A. x \<in> v \<Longrightarrow> card A \<le> card v" using assms
  by (meson card_mono subsetI)

lemma testing_vec2:
  assumes "finite A" and "finite v"
  shows "\<forall>x\<in>A. (x, y) \<in> v \<Longrightarrow> card A \<le> card v" using assms
  by (metis (no_types, hide_lams) imageI old.prod.exhaust prod.inject subset_iff surj_card_le)
*)

(*
definition vector_pair :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> bool" where
  "vector_pair A vs \<equiv>
(\<forall>i::nat. i < length vs \<longrightarrow> (card (vs!i) = card A) \<and> (\<forall>x\<in>A. in_vector (vs!i) x))"*)

(*definition total_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
  where "total_on A r \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<noteq> y \<longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r)"*)
definition range_vector :: "'a set \<Rightarrow> 'a Profile \<Rightarrow>  Range_vector_list \<Rightarrow> bool" where
"range_vector A p rv \<equiv> length rv = length p \<and> (\<forall>i::nat. i < length rv \<longrightarrow> (length(rv!i) = card A))"

fun all_alternatives_in_A :: "'a set \<Rightarrow> 'a Pair_Vector \<Rightarrow> bool" where
"all_alternatives_in_A A v = (\<forall>(a, _) \<in> v. a \<in> A)"

fun every_alt_just_once :: "'a Pair_Vector \<Rightarrow> bool" where
"every_alt_just_once v = (\<forall>(a, n) \<in> v. \<forall>(b, m) \<in> (v - {(a, n)}). a \<noteq> b)"

definition vector_pair :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> bool" where
  "vector_pair A vs \<equiv>
(\<forall>i::nat. i < length vs \<longrightarrow> all_alternatives_in_A A (vs!i) \<and> every_alt_just_once (vs!i))"

abbreviation finite_pair_vectors :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> bool" where
  "finite_pair_vectors A vs \<equiv> finite A \<and> vector_pair A vs"

fun limit_pairs :: "'a set \<Rightarrow> 'a Pair_Vector \<Rightarrow> 'a Pair_Vector" where
  "limit_pairs A v = {(a, b) \<in> v. a \<in> A}"

fun limit_pair_vectors :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a Pair_Vectors" where
"limit_pair_vectors A vs =  map (limit_pairs A) vs"
(*
fun limit_pairs_test :: "'a set \<Rightarrow> 'a Pair_Vector \<Rightarrow> 'a Pair_Vector" where
  "limit_pairs_test A v = {(a, b) \<in> v. a \<in> A}"

fun limit_pair_vectors :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a Pair_Vectors" where
"limit_pair_vectors A vs =  map (limit_pairs A) vs"*)

lemma limit_presv_range_vec:
  assumes
    assm0: "all_alternatives_in_A S v" and
    assm1: "every_alt_just_once v" and
    assm2:  "A \<subseteq> S"
  shows "all_alternatives_in_A A (limit_pairs A v) \<and>
         every_alt_just_once (limit_pairs A v)"
proof-
  have " (\<forall>(a, n) \<in> v. \<forall>(b, m) \<in> (v - {(a, n)}). a \<noteq> b) \<Longrightarrow>
 (\<forall>(a, n) \<in> (limit_pairs A v). \<forall>(b, m) \<in> ((limit_pairs A v) - {(a, n)}). a \<noteq> b)"
    by fastforce
  then have 0:"every_alt_just_once (limit_pairs A v)" using assms by simp
  have "(\<forall>(a, _) \<in> v. a \<in> S) \<Longrightarrow>  (\<forall>(a, _) \<in> (limit_pairs A v). a \<in> A)"
    by auto
  then have 1:"all_alternatives_in_A A (limit_pairs A v)" using assms by simp
  show ?thesis using 0 1 by simp
qed

lemma limit_pair_vectors_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S" and
    vectors: "finite_pair_vectors S vs"
  shows "finite_pair_vectors A (limit_pair_vectors A vs)"
proof(auto)
  show "finite A"  using profile subset finite_subset by blast
  show "vector_pair A (map (limit_pairs A) vs)"
using length_map nth_map limit_presv_range_vec
           subset vector_pair_def
  by (metis (mono_tags, lifting) vectors)

qed

lemma limit_pair_vectors_presv_size:
  assumes f_prof: "finite_profile S p" and
          subset:  "A \<subseteq> S" and
          f_vec: "finite_pair_vectors A vs"
  shows "length vs = length (map (limit_pairs A) vs)"
  by simp

(*
abbreviation finite_range_vector :: "'a set  \<Rightarrow> 'a Profile \<Rightarrow>  Range_vector_list \<Rightarrow> bool" where
"finite_range_vector A p rv \<equiv> finite A \<and> range_vector A p rv"

fun limit_kick :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a set" where
  "limit_kick A r = {a. \<not>a \<in> A \<and> (a, a) \<in> r}"

fun rank_kicked_set :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow> nat set" where
"rank_kicked_set A r = {rank r x | x. x \<in> (limit_kick A r) }"

fun kicked_set_to_list :: "nat set \<Rightarrow> nat \<Rightarrow> nat list" where
"kicked_set_to_list s 0 = []" |
"kicked_set_to_list s n = (Max s) # (if ((card s) = 0) then [] else kicked_set_to_list (s - {Max s}) (n-1))"

fun remove_from_range :: "nat list \<Rightarrow> nat \<Rightarrow> nat list" where
"remove_from_range rv 0 = tl rv" |
"remove_from_range rv n = (hd rv) # (remove_from_range (tl rv) (n-1))"

fun limit_range_vector :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
"limit_range_vector [] rv = rv" |
"limit_range_vector ranks rv = limit_range_vector (tl ranks) (remove_from_range rv ((hd ranks)-1))"

fun limit_range_vectors :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> Range_vector_list \<Rightarrow> Range_vector_list" where
"limit_range_vectors A p [] = []" |
"limit_range_vectors A p rs = (limit_range_vector (kicked_set_to_list (rank_kicked_set A (hd p))
(card (rank_kicked_set A (hd p))))
(hd rs)) # limit_range_vectors A (tl p) (tl rs)"

lemma length_limit_range: "length (limit_range_vectors A p rs) = length rs"
proof(induct rs)
  case Nil
  then show ?case by simp
next
  case (Cons a rs)
  then show ?case proof-
    have 0:"length (a # rs) = length rs +1" by simp
    have "length (limit_range_vectors A p (a # rs)) = length (limit_range_vectors A p rs) + 1" sorry
    then show ?thesis
      using 0 Cons.hyps by linarith
  qed
qed

lemma limit_range_vectors_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S" and
    vectors: "finite_range_vector S p rv"
  shows "finite_range_vector A (limit_profile A p) (limit_range_vectors A p rv)"
proof(auto)
  show "finite A" using finite_subset subset vectors by auto
  show "range_vector A (map (limit A) p) (limit_range_vectors A p rv)"
    unfolding range_vector_def
  proof-
    have a:"length rv = length p" using vectors range_vector_def by auto
    have b:"length (map (limit A) p) = length p" by simp
    have 0:"length (limit_range_vectors A p rv) = length (map (limit A) p)"
      by (simp add: b a length_limit_range)

    have 1: "(\<forall>i<length (limit_range_vectors A p rv).
        length (limit_range_vectors A p rv ! i) = card A)" sorry
    show "length (limit_range_vectors A p rv) = length (map (limit A) p) \<and>
      (\<forall>i<length (limit_range_vectors A p rv).
      length (limit_range_vectors A p rv ! i) = card A)"
      using 0 1 by simp
qed
qed
(**)

abbreviation finite_pair_vectors :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> bool" where
  "finite_pair_vectors A vs \<equiv> finite A \<and> vector_pair A vs"

fun limit_pairs :: "'a set \<Rightarrow> 'a Pair_Vector \<Rightarrow> 'a Pair_Vector" where
  "limit_pairs A v = {(a, b) \<in> v. a \<in> A}"
(*
definition lifted :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "lifted A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall>i::nat.
        (i < length p \<and> \<not>Preference_Relation.lifted A (p!i) (q!i) a) \<longrightarrow>
          (p!i) = (q!i)) \<and>
      (\<exists>i::nat. i < length p \<and> Preference_Relation.lifted A (p!i) (q!i) a)"*)

fun limit_pair_vectors :: "'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a Pair_Vectors" where
"limit_pair_vectors A vs =  map (limit_pairs A) vs"

lemma limit_pair_vectors_trans:
  assumes
    "B \<subseteq> A" and
    "C \<subseteq> B" and
    "finite_pair_vectors A vs"
  shows "limit_pair_vectors C vs = limit_pair_vectors C (limit_pair_vectors B vs)"
  using assms by auto

lemma limit_presv_card1:
  assumes
    assm1: "(\<forall>x\<in>S. in_vector v x)" and
    assm2:  "A \<subseteq> S"
    shows "(\<forall>x\<in>A. in_vector (limit_pairs A v) x)"
proof-
  have "(\<forall>x\<in>A. in_vector v x)"
    using assm1 assm2
    by blast
  hence "\<forall>x\<in>A. in_vector (limit_pairs A v) x"
    by auto
  thus "\<forall>x\<in>A. in_vector (limit_pairs A v) x"
    by simp
qed

lemma limit_presv_card2:
  assumes
    assm0: "(card v = card S)" and
    assm1: "(\<forall>x\<in>S. in_vector v x)" and
    assm2:  "A \<subseteq> S"
    shows "(card (limit_pairs A v) = card A)"
proof -
  fix x :: "'a"
  have x_in_A: "\<exists> m::nat. (x,m) \<in> (limit_pairs A v) \<Longrightarrow> x \<in> A"
    using limit_presv_card1
    by simp
  have "x \<in> A \<Longrightarrow> \<exists> m::nat. (x,m) \<in> v"
    using assm1 assm2
    by fastforce
  hence x_in_limit_pairs: "x \<in> A \<Longrightarrow> \<exists> m::nat. (x,m) \<in> (limit_pairs A v)"
    by simp
  have "{y \<in> A. \<exists> m::nat. (y,m) \<in> (limit_pairs A v)} = A"
    using x_in_A x_in_limit_pairs
    sorry
  hence "card {y \<in> A. \<exists> m::nat. (y,m) \<in> (limit_pairs A v)} = card A"
    by presburger
  thus "card (limit_pairs A v) = card A"
    sorry
qed

lemma limit_presv_card:
  assumes
    assm0: "(card v = card S)" and
    assm1: "(\<forall>x\<in>S. in_vector v x)" and
    assm2:  "A \<subseteq> S"
  shows "(\<forall>x\<in>A. in_vector (limit_pairs A v) x) \<and>
         (card (limit_pairs A v) = card A)"
  using limit_presv_card1 limit_presv_card2
        assm0 assm1 assm2
  by metis

(*hier evtl. Beweis nötig, dass card(vs!i) = A*)
lemma limit_pair_vectors_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S" and
    vectors: "finite_pair_vectors S vs"
  shows "finite_pair_vectors A (limit_pair_vectors A vs)"
proof(auto)
  show "finite A" using profile subset finite_subset by blast
  show "vector_pair A (map (limit_pairs A) vs)"
    using length_map nth_map limit_presv_card vector_pair_def subset profile vectors
    by (smt (verit, del_insts))
qed

lemma limit_pair_vectors_presv_size:
  assumes f_prof: "finite_profile S p" and
          subset:  "A \<subseteq> S" and
          f_vec: "finite_pair_vectors A vs"
  shows "length vs = length (map (limit_pairs A) vs)"
  by simp
*)

(*************)

end