subsection\<open>Logical and structural substitution\<close>

theory Substitution
  imports DeBruijn
begin

primrec
  subst_trm :: "[trm, trm, nat] \<Rightarrow> trm"  ("_[_'/_]\<^sup>T" [300, 0, 0] 300) and
  subst_cmd ::  "[cmd, trm, nat] \<Rightarrow> cmd" ("_[_'/_]\<^sup>C" [300, 0, 0] 300)
where
    subst_LVar: "(`i)[s/k]\<^sup>T =
          (if k < i then `(i-1) else if k = i then s else (`i))"
    | subst_Lbd: "(\<lambda> T : t)[s/k]\<^sup>T = \<lambda> T : (t[(liftL_trm s 0) / k+1]\<^sup>T)"
    | subst_App: "(t \<degree> u)[s/k]\<^sup>T = t[s/k]\<^sup>T \<degree> u[s/k]\<^sup>T"
    | subst_Mu: "(\<mu> T : c)[s/k]\<^sup>T  = \<mu> T : (c[(liftM_trm s 0) / k]\<^sup>C)"
    | subst_MVar: "(<i> t)[s/k]\<^sup>C = <i> (t[s/k]\<^sup>T)"

text\<open>Substituting a term for the hole in a context.\<close>

primrec ctxt_subst :: "ctxt \<Rightarrow> trm \<Rightarrow> trm" where
  "ctxt_subst \<diamond> s = s" |
  "ctxt_subst (E \<^sup>\<bullet> t) s = (ctxt_subst E s)\<degree> t"

lemma ctxt_app_subst:
  shows "ctxt_subst E (ctxt_subst F t) = ctxt_subst (E . F) t"
  by (induction E, auto)

text\<open>The structural substitution is based on Geuvers and al.~\<^cite>\<open>"DBLP:journals/apal/GeuversKM13"\<close>.\<close>

primrec
  struct_subst_trm :: "[trm, nat, nat, ctxt] \<Rightarrow> trm"  ("_[_=_ _]\<^sup>T" [300, 0, 0, 0] 300) and
  struct_subst_cmd ::  "[cmd, nat, nat, ctxt] \<Rightarrow> cmd" ("_[_=_ _]\<^sup>C" [300, 0, 0, 0] 300)
where
  struct_LVar: "(`i)[j=k E]\<^sup>T = (`i)" |
  struct_Lbd: "(\<lambda> T : t)[j=k E]\<^sup>T = (\<lambda> T : (t[j=k (liftL_ctxt E 0)]\<^sup>T))" |
  struct_App: "(t\<degree>s)[j=k E]\<^sup>T = (t[j=k E]\<^sup>T)\<degree>(s[j=k E]\<^sup>T)" |
  struct_Mu: "(\<mu> T : c)[j=k E]\<^sup>T = \<mu> T : (c[(j+1)=(k+1) (liftM_ctxt E 0)]\<^sup>C)" |
  struct_MVar: "(<i> t)[j=k E]\<^sup>C =
      (if i=j then (<k> (ctxt_subst E (t[j=k E]\<^sup>T)))
       else (if j<i \<and> i\<le>k then (<i-1> (t[j=k E]\<^sup>T))
             else (if k\<le>i \<and> i<j then (<i+1> (t[j=k E]\<^sup>T))
                   else (<i> (t[j=k E]\<^sup>T)))))"

text\<open>Lifting of lambda and mu variables commute with each other\<close>

lemma liftLM_comm:
  "liftL_trm (liftM_trm t n) m = liftM_trm (liftL_trm t m) n"
  "liftL_cmd (liftM_cmd c n) m = liftM_cmd (liftL_cmd c m) n"
  by(induct t and c arbitrary: n m and n m) auto

lemma liftLM_comm_ctxt:
  "liftL_ctxt (liftM_ctxt E n) m = liftM_ctxt (liftL_ctxt E m) n"
  by(induct E arbitrary: n m, auto simp add: liftLM_comm)

text\<open>Lifting of $\mu$-variables (almost) commutes.\<close>

lemma liftMM_comm:
  "n\<ge>m \<Longrightarrow> liftM_trm (liftM_trm t n) m = liftM_trm (liftM_trm t m) (Suc n)"
  "n\<ge>m \<Longrightarrow> liftM_cmd (liftM_cmd c n) m = liftM_cmd (liftM_cmd c m) (Suc n)"
  by(induct t and c arbitrary: n m and n m) auto

lemma liftMM_comm_ctxt:
  "liftM_ctxt (liftM_ctxt E n) 0 = liftM_ctxt (liftM_ctxt E 0) (n+1)"
  by(induct E arbitrary: n, auto simp add: liftMM_comm)

text\<open>If a $\mu$ variable $i$ doesn't occur in a term or a context,
then these remain the same after structural substitution of variable $i$.\<close>

lemma liftM_struct_subst:
  "liftM_trm t i[i=i F]\<^sup>T = liftM_trm t i"
  "liftM_cmd c i[i=i F]\<^sup>C = liftM_cmd c i"
  by(induct t and c arbitrary: i F and i F) auto

lemma liftM_ctxt_struct_subst:
  "(ctxt_subst (liftM_ctxt E i) t)[i=i F]\<^sup>T = ctxt_subst (liftM_ctxt E i) (t[i=i F]\<^sup>T)"
  by(induct E arbitrary: i t F; force simp add: liftM_struct_subst)

end


(*  Title:      HOL/Datatype_Examples/Simproc_Tests.thy
    Author:     Manuel Eberl, TU München
*)

section \<open>Tests of datatype-specific simprocs\<close>

theory Datatype_Simproc_Tests
imports Main
begin

(* datatype without parameters *)

datatype foo = X | Y foo foo

lemma "x \<noteq> Y x y" "x \<noteq> Y y x" "Y x y \<noteq> x" "Y y x \<noteq> x"
  by simp_all

(* datatype with parameters *)

datatype 'a mytree = A 'a | B "'a mytree" "'a mytree"

lemma "B l r \<noteq> l" and "B l r \<noteq> r" and "l \<noteq> B l r" and "r \<noteq> B l r"
  by simp_all

notepad
begin
  fix a b c d e f :: "nat mytree"
  define t where [simp]: "t = B (B (B a b) (B c d)) (B e f)"
  have "\<forall>x\<in>{a,b,c,d,e,f}. t \<noteq> x"
    by simp
  have "\<forall>x\<in>{a,b,c,d,e,f}. x \<noteq> t"
    by simp
end

(* mutual recursion *)

datatype 'a myty1 = A1 'a | B1 "'a myty1" "'a myty2"
     and 'a myty2 = A2 'a | B2 "'a myty2" "'a myty1"

lemma "B1 a (B2 b c) \<noteq> a" and "B1 a (B2 b c) \<noteq> c"
  by simp_all

lemma "B2 a (B1 b c) \<noteq> a" and "B2 a (B1 b c) \<noteq> c"
  by simp_all

end


chapter\<open>Pseudo-Coding: Section 7 Material\<close>

theory Pseudo_Coding
imports II_Prelims
begin

section\<open>General Lemmas\<close>

lemma Collect_disj_Un: "{f i |i. P i \<or> Q i} = {f i |i. P i} \<union> {f i |i. Q i}"
by auto

abbreviation Q_Subset :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Subset t u \<equiv> (Q_All (Q_Imp (Q_Mem (Q_Ind Zero) t) (Q_Mem (Q_Ind Zero) u)))"

lemma NEQ_quot_tm: "i\<noteq>j \<Longrightarrow> {} \<turnstile> \<guillemotleft>Var i\<guillemotright> NEQ \<guillemotleft>Var j\<guillemotright>"
  by (auto intro: Sigma_fm_imp_thm [OF OrdNotEqP_sf]
           simp: ground_fm_aux_def supp_conv_fresh quot_tm_def)

lemma EQ_quot_tm_Fls: "i\<noteq>j \<Longrightarrow> insert (\<guillemotleft>Var i\<guillemotright> EQ \<guillemotleft>Var j\<guillemotright>) H \<turnstile> Fls"
  by (metis (full_types) NEQ_quot_tm Assume OrdNotEqP_E cut2 thin0)

lemma perm_commute: "a \<sharp> p \<Longrightarrow> a' \<sharp> p \<Longrightarrow> (a \<rightleftharpoons> a') + p = p + (a \<rightleftharpoons> a')"
  by (rule plus_perm_eq) (simp add: supp_swap fresh_def)

lemma perm_self_inverseI: "\<lbrakk>-p = q; a \<sharp> p; a' \<sharp> p\<rbrakk> \<Longrightarrow> - ((a \<rightleftharpoons> a') + p) = (a \<rightleftharpoons> a') + q"
  by (simp_all add: perm_commute fresh_plus_perm minus_add)

lemma fresh_image:
  fixes f :: "'a \<Rightarrow> 'b::fs"  shows "finite A \<Longrightarrow> i \<sharp> f ` A \<longleftrightarrow> (\<forall>x\<in>A. i \<sharp> f x)"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_in_atom_image [simp]: "atom j \<in> atom ` V \<longleftrightarrow> j \<in> V"
  by auto

lemma fresh_star_empty [simp]: "{} \<sharp>* bs"
  by (simp add: fresh_star_def)

declare fresh_star_insert [simp]

lemma fresh_star_finite_insert:
  fixes S :: "('a::fs) set"  shows "finite S \<Longrightarrow> a \<sharp>* insert x S \<longleftrightarrow> a \<sharp>* x \<and> a \<sharp>* S"
  by (auto simp: fresh_star_def fresh_finite_insert)

lemma fresh_finite_Diff_single [simp]:
  fixes V :: "name set"   shows "finite V \<Longrightarrow> a \<sharp> (V - {j}) \<longleftrightarrow> (a \<sharp> j \<longrightarrow> a \<sharp> V)"
apply (auto simp: fresh_finite_insert)
apply (metis finite_Diff fresh_finite_insert insert_Diff_single)
apply (metis Diff_iff finite_Diff fresh_atom fresh_atom_at_base fresh_finite_set_at_base insertI1)
apply (metis Diff_idemp Diff_insert_absorb finite_Diff fresh_finite_insert insert_Diff_single insert_absorb)
done

lemma fresh_image_atom [simp]: "finite A \<Longrightarrow> i \<sharp> atom ` A \<longleftrightarrow> i \<sharp> A"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_fresh_star_atom_set_conv: "\<lbrakk>atom i \<sharp> bs; finite bs\<rbrakk> \<Longrightarrow> bs \<sharp>* i"
by (metis fresh_finite_atom_set fresh_ineq_at_base fresh_star_def)

lemma notin_V:
  assumes p: "atom i \<sharp> p" and V: "finite V" "atom ` (p \<bullet> V) \<sharp>* V"
  shows "i \<notin> V" "i \<notin> p \<bullet> V"
  using V
  apply (auto simp: fresh_def fresh_star_def supp_finite_set_at_base)
  apply (metis p mem_permute_iff fresh_at_base_permI)+
  done

section\<open>Simultaneous Substitution\<close>

definition ssubst :: "tm \<Rightarrow> name set \<Rightarrow> (name \<Rightarrow> tm) \<Rightarrow> tm"
  where "ssubst t V F = Finite_Set.fold (\<lambda>i. subst i (F i)) t V"

definition make_F :: "name set \<Rightarrow> perm \<Rightarrow> name \<Rightarrow> tm"
  where "make_F Vs p \<equiv> \<lambda>i. if i \<in> Vs then Var (p \<bullet> i) else Var i"

lemma ssubst_empty [simp]: "ssubst t {} F = t"
  by (simp add: ssubst_def)

text\<open>Renaming a finite set of variables. Based on the theorem \<open>at_set_avoiding\<close>\<close>
locale quote_perm =
  fixes p :: perm and Vs :: "name set" and F :: "name \<Rightarrow> tm"
  assumes p: "atom ` (p \<bullet> Vs) \<sharp>* Vs"
      and pinv: "-p = p"
      and Vs:  "finite Vs"
  defines "F \<equiv> make_F Vs p"
begin

lemma F_unfold: "F i = (if i \<in> Vs then Var (p \<bullet> i) else Var i)"
  by (simp add: F_def make_F_def)

lemma finite_V [simp]: "V \<subseteq> Vs \<Longrightarrow> finite V"
  by (metis Vs finite_subset)

lemma perm_exits_Vs: "i \<in> Vs \<Longrightarrow> (p \<bullet> i) \<notin> Vs"
  by (metis Vs fresh_finite_set_at_base imageI fresh_star_def mem_permute_iff p)

lemma atom_fresh_perm: "\<lbrakk>x \<in> Vs; y \<in> Vs\<rbrakk> \<Longrightarrow> atom x \<sharp> p \<bullet> y"
  by (metis imageI Vs p fresh_finite_set_at_base fresh_star_def mem_permute_iff fresh_at_base(2))

lemma fresh_pj: "\<lbrakk>a \<sharp> p; j \<in> Vs\<rbrakk> \<Longrightarrow> a \<sharp> p \<bullet> j"
  by (metis atom_fresh_perm fresh_at_base(2) fresh_perm fresh_permute_left pinv)

lemma fresh_Vs: "a \<sharp> p \<Longrightarrow> a \<sharp> Vs"
  by (metis Vs fresh_def fresh_perm fresh_permute_iff fresh_star_def p permute_finite supp_finite_set_at_base)

lemma fresh_pVs: "a \<sharp> p \<Longrightarrow> a \<sharp> p \<bullet> Vs"
  by (metis fresh_Vs fresh_perm fresh_permute_left pinv)

lemma assumes "V \<subseteq> Vs" "a \<sharp> p"
      shows fresh_pV [simp]: "a \<sharp> p \<bullet> V" and fresh_V [simp]: "a \<sharp> V"
  using fresh_pVs fresh_Vs assms
  apply (auto simp: fresh_def)
  apply (metis (full_types) Vs finite_V permute_finite subsetD subset_Un_eq supp_of_finite_union union_eqvt)
  by (metis Vs finite_V subsetD subset_Un_eq supp_of_finite_union)

lemma qp_insert:
  fixes i::name and i'::name
  assumes "atom i \<sharp> p" "atom i' \<sharp> (i,p)"
    shows  "quote_perm ((atom i \<rightleftharpoons> atom i') + p) (insert i Vs)"
using p pinv Vs assms
  by (auto simp: quote_perm_def fresh_at_base_permI atom_fresh_star_atom_set_conv swap_fresh_fresh
                 fresh_star_finite_insert fresh_finite_insert perm_self_inverseI)

lemma subst_F_left_commute: "subst x (F x) (subst y (F y) t) = subst y (F y) (subst x (F x) t)"
  by (metis subst_tm_commute2 F_unfold subst_tm_id F_unfold atom_fresh_perm tm.fresh(2))

lemma
  assumes "finite V" "i \<notin> V"
  shows ssubst_insert:  "ssubst t (insert i V) F = subst i (F i) (ssubst t V F)"  (is ?thesis1)
    and ssubst_insert2: "ssubst t (insert i V) F = ssubst (subst i (F i) t) V F"  (is ?thesis2)
proof -
  interpret comp_fun_commute "(\<lambda>i. subst i (F i))"
  proof qed (simp add: subst_F_left_commute fun_eq_iff)
  show ?thesis1 using assms Vs
    by (simp add: ssubst_def)
  show ?thesis2 using assms Vs
    by (simp add: ssubst_def fold_insert2 del: fold_insert)
qed

lemma ssubst_insert_if:
  "finite V \<Longrightarrow>
     ssubst t (insert i V) F = (if i \<in> V then ssubst t V F
                                         else subst i (F i) (ssubst t V F))"
  by (simp add: ssubst_insert insert_absorb)

lemma ssubst_single [simp]: "ssubst t {i} F = subst i (F i) t"
  by (simp add: ssubst_insert)

lemma ssubst_Var_if [simp]:
  assumes "finite V"
    shows "ssubst (Var i) V F = (if i \<in> V then F i else Var i)"
using assms
  apply (induction V, auto)
  apply (metis ssubst_insert subst.simps(2))
  apply (metis ssubst_insert2 subst.simps(2))+
  done

lemma ssubst_Zero [simp]: "finite V \<Longrightarrow> ssubst Zero V F = Zero"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_Eats [simp]: "finite V \<Longrightarrow> ssubst (Eats t u) V F = Eats (ssubst t V F) (ssubst u V F)"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_SUCC [simp]: "finite V \<Longrightarrow> ssubst (SUCC t) V F = SUCC (ssubst t V F)"
  by (metis SUCC_def ssubst_Eats)

lemma ssubst_ORD_OF [simp]: "finite V \<Longrightarrow> ssubst (ORD_OF n) V F = ORD_OF n"
  by (induction n) auto

lemma ssubst_HPair [simp]:
  "finite V \<Longrightarrow> ssubst (HPair t u) V F = HPair (ssubst t V F) (ssubst u V F)"
  by (simp add: HPair_def)

lemma ssubst_HTuple [simp]: "finite V \<Longrightarrow> ssubst (HTuple n) V F = (HTuple n)"
  by (induction n) (auto simp: HTuple.simps)

lemma ssubst_Subset:
  assumes "finite V" shows "ssubst \<lfloor>t SUBS u\<rfloor>V V F = Q_Subset (ssubst \<lfloor>t\<rfloor>V V F) (ssubst \<lfloor>u\<rfloor>V V F)"
proof -
  obtain i::name where "atom i \<sharp> (t,u)"
    by (rule obtain_fresh)
  thus ?thesis using assms
    by (auto simp: Subset.simps [of i] vquot_fm_def vquot_tm_def trans_tm_forget)
qed

lemma fresh_ssubst:
  assumes "finite V" "a \<sharp> p \<bullet> V" "a \<sharp> t"
    shows "a \<sharp> ssubst t V F"
using assms
  by (induct V)
     (auto simp: ssubst_insert_if fresh_finite_insert F_unfold intro: fresh_ineq_at_base)

lemma fresh_ssubst':
  assumes "finite V" "atom i \<sharp> t" "atom (p \<bullet> i) \<sharp> t"
    shows "atom i \<sharp> ssubst t V F"
using assms
  by (induct t rule: tm.induct) (auto simp: F_unfold fresh_permute_left pinv)

lemma ssubst_vquot_Ex:
  "\<lbrakk>finite V; atom i \<sharp> p \<bullet> V\<rbrakk>
   \<Longrightarrow> ssubst \<lfloor>Ex i A\<rfloor>(insert i V) (insert i V) F = ssubst \<lfloor>Ex i A\<rfloor>V V F"
   by (simp add: ssubst_insert_if insert_absorb vquot_fm_insert fresh_ssubst)

lemma ground_ssubst_eq: "\<lbrakk>finite V; supp t = {}\<rbrakk> \<Longrightarrow> ssubst t V F = t"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert fresh_def)

lemma ssubst_quot_fm [simp]:
  fixes A::fm shows "finite V \<Longrightarrow> ssubst \<guillemotleft>A\<guillemotright> V F = \<guillemotleft>A\<guillemotright>"
  by (simp add: ground_ssubst_eq supp_conv_fresh)

lemma atom_in_p_Vs: "\<lbrakk>i \<in> p \<bullet> V; V \<subseteq> Vs\<rbrakk> \<Longrightarrow> i \<in> p \<bullet> Vs"
  by (metis (full_types) True_eqvt subsetD subset_eqvt)

section\<open>The Main Theorems of Section 7\<close>

lemma SubstTermP_vquot_dbtm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbtm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstTermP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst (vquot_dbtm V dbtm) V F)
                (subst w (F w) (ssubst (vquot_dbtm (insert w V) dbtm) V F))"
using s
proof (induct dbtm rule: dbtm.induct)
  case DBZero thus ?case using V w
    by (auto intro: SubstTermP_Zero [THEN cut1] ConstP_imp_TermP [THEN cut1])
next
  case (DBInd n) thus ?case using V
    apply auto
    apply (rule thin [of "{ConstP (F w)}"])
    apply (rule SubstTermP_Ind [THEN cut3])
    apply (auto simp: IndP_Q_Ind OrdP_ORD_OF ConstP_imp_TermP)
    done
next
  case (DBVar i) show ?case
  proof (cases "i \<in> V'")
    case True hence "i \<notin> Vs" using assms
      by (metis p Vs atom_in_atom_image atom_in_p_Vs fresh_finite_set_at_base fresh_star_def)
    thus ?thesis using DBVar True V
      by auto
  next
    case False thus ?thesis using DBVar V w
      apply (auto simp: quot_Var [symmetric])
        apply (blast intro: thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                            SubstTermP_Var_same [THEN cut2])
       apply (subst forget_subst_tm, metis F_unfold atom_fresh_perm tm.fresh(2))
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                           SubstTermP_Const [THEN cut2])
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP EQ_quot_tm_Fls
                           SubstTermP_Var_diff [THEN cut4])
      done
  qed
next
  case (DBEats tm1 tm2) thus ?case using V
    by (auto simp: SubstTermP_Eats [THEN cut2])
qed

lemma SubstFormP_vquot_dbfm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbfm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst (vquot_dbfm V dbfm) V F)
                (subst w (F w) (ssubst (vquot_dbfm (insert w V) dbfm) V F))"
using w s
proof (induct dbfm rule: dbfm.induct)
  case (DBMem t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Mem [THEN cut2])
next
  case (DBEq t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Eq [THEN cut2])
next
  case (DBDisj A B) thus ?case using V
    by (auto intro: SubstFormP_Disj [THEN cut2])
next
  case (DBNeg A) thus ?case using V
    by (auto intro: SubstFormP_Neg [THEN cut1])
next
  case (DBEx A) thus ?case using V
    by (auto intro: SubstFormP_Ex [THEN cut1])
qed

text\<open>Lemmas 7.5 and 7.6\<close>
lemma ssubst_SubstFormP:
  fixes A::fm
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp A \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst \<lfloor>A\<rfloor>V V F)
                (ssubst \<lfloor>A\<rfloor>(insert w V) (insert w V) F)"
proof -
  have "w \<notin> V" using assms
    by auto
  thus ?thesis using assms
    by (simp add: vquot_fm_def supp_conv_fresh ssubst_insert_if SubstFormP_vquot_dbfm)
qed

text\<open>Theorem 7.3\<close>
theorem PfP_implies_PfP_ssubst:
  fixes \<beta>::fm
  assumes \<beta>: "{} \<turnstile> PfP \<guillemotleft>\<beta>\<guillemotright>"
      and V: "V \<subseteq> Vs"
      and s: "supp \<beta> \<subseteq> atom ` Vs"
    shows    "{ConstP (F i) | i. i \<in> V} \<turnstile> PfP (ssubst \<lfloor>\<beta>\<rfloor>V V F)"
proof -
  show ?thesis using finite_V [OF V] V
  proof induction
    case empty thus ?case
      by (auto simp: \<beta>)
  next
    case (insert i V)
    thus ?case using assms
      by (auto simp: Collect_disj_Un fresh_finite_set_at_base
               intro: PfP_implies_SubstForm_PfP thin1 ssubst_SubstFormP)
  qed
qed

end

end


(* Title:     HOL/MiniML/MiniML.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

header "MiniML with type inference rules"

theory MiniML
imports Generalize
begin

-- "expressions"
datatype
  expr = Var nat | Abs expr | App expr expr | LET expr expr

-- "type inference rules"
inductive
  has_type :: "[ctxt, expr, typ] => bool"
                  ("((_) |-/ (_) :: (_))" [60,0,60] 60)
where
  VarI: "[| n < length A; t <| A!n |] ==> A |- Var n :: t"
| AbsI: "[| (mk_scheme t1)#A |- e :: t2 |] ==> A |- Abs e :: t1 -> t2"
| AppI: "[| A |- e1 :: t2 -> t1; A |- e2 :: t2 |]
         ==> A |- App e1 e2 :: t1"
| LETI: "[| A |- e1 :: t1; (gen A t1)#A |- e2 :: t |] ==> A |- LET e1 e2 :: t"

declare has_type.intros [simp]
declare Un_upper1 [simp] Un_upper2 [simp]
declare is_bound_typ_instance_closed_subst [simp]

lemma s'_t_equals_s_t:
  "!!t::typ. $(%n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) t = $S t"
apply (rule typ_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

declare s'_t_equals_s_t [simp]

lemma s'_a_equals_s_a:
  "!!A::type_scheme list. $(%n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) A = $S A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

declare s'_a_equals_s_a [simp]

lemma replace_s_by_s':
 "$(%n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) A |-
     e :: $(%n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) t
  ==> $S A |- e :: $S t"
apply (rule_tac P = "%A. A |- e :: $S t" in ssubst)
apply (rule s'_a_equals_s_a [symmetric])
apply (rule_tac P = "%t. $ (%n. if n : free_tv A Un free_tv (?t2 S) then S n else TVar n) A |- e :: t" in ssubst)
apply (rule s'_t_equals_s_t [symmetric])
apply simp
done

lemma alpha_A':
  "!!A::type_scheme list. $ (%x. TVar (if x : free_tv A then x else n + x)) A = $ id_subst A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: id_subst_def)
done

lemma alpha_A:
  "!!A::type_scheme list. $ (%x. TVar (if x : free_tv A then x else n + x)) A = A"
apply (rule alpha_A' [THEN ssubst])
apply simp
done

lemma S_o_alpha_typ:
  "$ (S o alpha) (t::typ) = $ S ($ (%x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_typ':
  "$ (%u. (S o alpha) u) (t::typ) = $ S ($ (%x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_type_scheme:
  "$ (S o alpha) (sch::type_scheme) = $ S ($ (%x. TVar (alpha x)) sch)"
apply (induct_tac "sch")
apply (simp_all)
done

lemma S_o_alpha_type_scheme_list:
  "$ (S o alpha) (A::type_scheme list) = $ S ($ (%x. TVar (alpha x)) A)"
apply (induct_tac "A")
apply (simp_all)
apply (rule S_o_alpha_type_scheme [unfolded o_def])
done

lemma S'_A_eq_S'_alpha_A: "!!A::type_scheme list.
      $ (%n. if n : free_tv A Un free_tv t then S n else TVar n) A =
      $ ((%x. if x : free_tv A Un free_tv t then S x else TVar x) o
         (%x. if x : free_tv A then x else n + x)) A"
apply (subst S_o_alpha_type_scheme_list)
apply (subst alpha_A)
apply (rule refl)
done

lemma dom_S':
 "dom (%n. if n : free_tv A Un free_tv t then S n else TVar n) <=
  free_tv A Un free_tv t"
apply (unfold free_tv_subst dom_def)
apply (simp (no_asm))
apply fast
done

lemma cod_S':
  "!!(A::type_scheme list) (t::typ).
   cod (%n. if n : free_tv A Un free_tv t then S n else TVar n) <=
   free_tv ($ S A) Un free_tv ($ S t)"
apply (unfold free_tv_subst cod_def subset_eq)
apply (rule ballI)
apply (erule UN_E)
apply (drule dom_S' [THEN subsetD])
apply simp
apply (fast dest: free_tv_of_substitutions_extend_to_scheme_lists intro: free_tv_of_substitutions_extend_to_types [THEN subsetD])
done

lemma free_tv_S':
 "!!(A::type_scheme list) (t::typ).
  free_tv (%n. if n : free_tv A Un free_tv t then S n else TVar n) <=
  free_tv A Un free_tv ($ S A) Un free_tv t Un free_tv ($ S t)"
apply (unfold free_tv_subst)
apply (fast dest: dom_S' [THEN subsetD] cod_S' [THEN subsetD])
done

lemma free_tv_alpha: "!!t1::typ.
      (free_tv ($ (%x. TVar (if x : free_tv A then x else n + x)) t1) - free_tv A) <=
          {x. ? y. x = n + y}"
apply (induct_tac "t1")
apply (simp (no_asm))
apply fast
apply (simp (no_asm))
apply fast
done

lemma new_tv_Int_free_tv_empty_type: "!!t::typ. new_tv n t ==> {x. ? y. x = n + y} Int free_tv t = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme: "!!sch::type_scheme. new_tv n sch ==> {x. ? y. x = n + y} Int free_tv sch = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme_list: "!A::type_scheme list. new_tv n A --> {x. ? y. x = n + y} Int free_tv A = {}"
apply (rule allI)
apply (induct_tac "A")
apply (simp (no_asm))
apply (simp (no_asm))
apply (fast dest: new_tv_Int_free_tv_empty_scheme)
done

lemma gen_t_le_gen_alpha_t [rule_format (no_asm)]:
   "new_tv n A --> gen A t <= gen A ($ (%x. TVar (if x : free_tv A then x else n + x)) t)"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply (intro strip)
apply (erule exE)
apply (hypsubst)
apply (rule_tac x = " (%x. S (if n <= x then x - n else x))" in exI)
apply (induct_tac t)
apply (simp (no_asm))
apply (rename_tac nat)
apply (case_tac "nat : free_tv A")
apply (simp (no_asm_simp))
apply (subgoal_tac "n <= n + nat")
apply (drule new_tv_le)
apply assumption
apply (drule new_tv_not_free_tv)
apply (drule new_tv_not_free_tv)
apply (simp (no_asm_simp) add: diff_add_inverse)
apply (simp (no_asm))
apply (simp (no_asm_simp))
done

declare has_type.intros [intro!]

lemma has_type_le_env [rule_format (no_asm)]: "A |- e::t ==> !B. A <= B -->  B |- e::t"
apply (erule has_type.induct)
   apply (simp (no_asm) add: le_env_def)
   apply (fastforce elim: bound_typ_instance_trans)
  apply simp
 apply fast
apply (slow elim: le_env_free_tv [THEN free_tv_subset_gen_le])
done

-- "@{text has_type} is closed w.r.t. substitution"
lemma has_type_cl_sub: "A |- e :: t ==> !S. $S A |- e :: $S t"
apply (erule has_type.induct)
(* case VarI *)
   apply (rule allI)
   apply (rule has_type.VarI)
    apply (simp add: app_subst_list)
   apply (simp (no_asm_simp) add: app_subst_list)
  (* case AbsI *)
  apply (rule allI)
  apply (simp (no_asm))
  apply (rule has_type.AbsI)
  apply simp
 (* case AppI *)
 apply (rule allI)
 apply (rule has_type.AppI)
  apply simp
  apply (erule spec)
 apply (erule spec)
(* case LetI *)
apply (rule allI)
apply (rule replace_s_by_s')
apply (cut_tac A = "$ S A" and A' = "A" and t = "t" and t' = "$ S t" in ex_fresh_variable)
apply (erule exE)
apply (erule conjE)+
apply (rule_tac ?t1.0 = "$ ((%x. if x : free_tv A Un free_tv t then S x else TVar x) o (%x. if x : free_tv A then x else n + x)) t1" in has_type.LETI)
 apply (drule_tac x = " (%x. if x : free_tv A Un free_tv t then S x else TVar x) o (%x. if x : free_tv A then x else n + x) " in spec)
 apply (subst S'_A_eq_S'_alpha_A)
 apply assumption
apply (subst S_o_alpha_typ)
apply (subst gen_subst_commutes)
 apply (rule subset_antisym)
  apply (rule subsetI)
  apply (erule IntE)
  apply (drule free_tv_S' [THEN subsetD])
  apply (drule free_tv_alpha [THEN subsetD])
  apply (simp del: full_SetCompr_eq)
  apply (erule exE)
  apply (hypsubst)
  apply (subgoal_tac "new_tv (n + y) ($ S A) ")
   apply (subgoal_tac "new_tv (n + y) ($ S t) ")
    apply (subgoal_tac "new_tv (n + y) A")
     apply (subgoal_tac "new_tv (n + y) t")
      apply (drule new_tv_not_free_tv)+
      apply fast
     apply (rule new_tv_le) prefer 2 apply assumption apply simp
    apply (rule new_tv_le) prefer 2 apply assumption apply simp
   apply (rule new_tv_le) prefer 2 apply assumption apply simp
  apply (rule new_tv_le) prefer 2 apply assumption apply simp
 apply fast
apply (rule has_type_le_env)
 apply (drule spec)
 apply (drule spec)
 apply assumption
apply (rule app_subst_Cons [THEN subst])
apply (rule S_compatible_le_scheme_lists)
apply (simp (no_asm_simp))
done

end


theory Kruskal
imports Kruskal_Misc  MinWeightBasis "HOL-Library.Uprod"
begin

abbreviation "\<alpha>'' == (\<lambda>(a,_,b). (a,b))"
abbreviation "\<alpha>' == (\<lambda>(a,_,b). Upair a b)"

definition "lst_graph_P' w l S \<equiv> distinct (map \<alpha>' l) \<and> (\<lambda>(a,_,b). Upair a b) ` set l = S
                            \<and> (\<forall>(a,wv,b)\<in>set l.  w (Upair a b) = wv)"

definition "lst_graph_rel' w \<equiv> {(l,S). lst_graph_P' w l S }"

locale Kruskal_intermediate_defs =
  fixes  E :: "('a uprod) set"
   and forest :: "('a uprod) set \<Rightarrow> bool"
   and connected :: "('a uprod) set \<Rightarrow> ('a*'a) set"
   and path :: "('a uprod) set \<Rightarrow> 'a \<Rightarrow> ('a uprod) list \<Rightarrow> 'a \<Rightarrow> bool"
   and weight :: "'a uprod \<Rightarrow> 'b::{linorder, ordered_comm_monoid_add}"
begin

  definition "V = \<Union>( set_uprod ` E)"

  lemma finiteE_finiteV: "finite E \<Longrightarrow> finite V"
    by(auto simp: V_def)

end

locale Kruskal_intermediate = Kruskal_intermediate_defs   E forest connected path weight for
     E :: "('a uprod) set"
   and forest :: "('a uprod) set \<Rightarrow> bool"
   and connected :: "('a uprod) set \<Rightarrow> ('a*'a) set"
   and path :: "('a uprod) set \<Rightarrow> 'a \<Rightarrow> ('a uprod) list \<Rightarrow> 'a \<Rightarrow> bool"
   and weight :: "'a uprod \<Rightarrow> 'b::{linorder, ordered_comm_monoid_add}" +
 assumes Eproper: "\<And>e. e\<in>E \<Longrightarrow> proper_uprod e"
   and finiteE[simp]: "finite E"
   and forest_subE: "forest E' \<Longrightarrow> E' \<subseteq> E"
   and forest_empty: "forest {}"
   and forest_mono: "forest X \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> forest Y"
   and connected_Epath: "(u,v) \<in> connected E'  \<longleftrightarrow> (\<exists>p. path E' u p v \<and> u \<in> V \<and> v \<in> V)"
   and connected_same: "(u,v) \<in> connected {} \<longleftrightarrow> u=v \<and> v\<in>V"
   and findaugmenting_aux: "path E1 u p v \<Longrightarrow> \<not>(\<exists>p. path E2 u p v)
           \<Longrightarrow> \<exists>a b. (a,b) \<notin> connected E2 \<and> Upair a b \<notin> E2 \<and> Upair a b \<in> E1"
   and augment_forest: "forest F \<Longrightarrow> Upair u v \<in> E-F
           \<Longrightarrow> forest (insert (Upair u v) F) \<longleftrightarrow> (u,v) \<notin> connected F"
   and equiv: "F \<subseteq> E \<Longrightarrow> equiv V (connected F)"
   and connected_in: "connected F \<subseteq> V \<times> V"
   and insert_reachable: "x\<noteq>y \<Longrightarrow> x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> F \<subseteq> E
           \<Longrightarrow> connected (insert (Upair x y) F) = per_union (connected F) x y"
begin

lemma E_inV: "\<And>e. e\<in>E \<Longrightarrow> set_uprod e \<subseteq> V"
  using V_def by auto

lemma finiteV[simp]: "finite V"
  by(auto intro: finiteE_finiteV)

definition "CC E' x = (connected E')``{x}"

lemma sameCC_reachable: "E' \<subseteq> E \<Longrightarrow> u\<in>V \<Longrightarrow> v\<in>V \<Longrightarrow> CC E' u = CC E' v \<longleftrightarrow> (u,v) \<in> connected E'"
  unfolding CC_def using  equiv_class_eq_iff[OF equiv ] by auto

definition "CCs E' = quotient V (connected E')"

lemma "quotient V Id = {{v}|v. v\<in>V}" unfolding quotient_def by auto

lemma CCs_empty: "CCs {} = {{v}|v. v\<in>V}"
  unfolding CCs_def unfolding quotient_def using connected_same by auto

lemma CCs_empty_card: "card (CCs {}) = card V"
proof -
  have i: "{{v}|v. v\<in>V} = (\<lambda>v. {v})`V"
    by blast
  have "card (CCs {}) = card {{v}|v. v\<in>V}"
    using CCs_empty  by auto
  also have "\<dots> = card ((\<lambda>v. {v})`V)" by(simp only: i)
  also have "\<dots> = card V"
    apply(rule card_image)
    unfolding inj_on_def by auto
  finally show ?thesis .
qed

lemma CCs_imageCC: "CCs F = (CC F) ` V"
  unfolding CCs_def CC_def quotient_def
  by blast

lemma union_eqclass_decreases_components:
  assumes "CC F x \<noteq> CC F y" "(Upair x y) \<notin> F" "x\<in>V" "y\<in>V" "F \<subseteq> E"
  shows "Suc (card (CCs (insert (Upair x y) F))) = card (CCs F)"
proof -
  from assms(1) have xny: "x\<noteq>y" by blast
  show ?thesis unfolding CCs_def
    apply(simp only: insert_reachable[OF xny assms(3-5)])
    apply(rule unify2EquivClasses_alt)
         apply(fact assms(1)[unfolded CC_def])
        apply fact+
      apply (fact connected_in)
     apply(rule equiv) apply fact
    by (fact finiteV)
qed

lemma forest_CCs: assumes "forest E'" shows "card (CCs E') + card E' = card V"
proof -
  from assms have "finite E'" using forest_subE
    using finiteE finite_subset by blast
  from this assms show ?thesis
  proof(induct E')
    case (insert x F)
    then have xE: "x\<in>E" using forest_subE by auto
    from this obtain a b where xab: "x = Upair a b"  using uprod_exhaust by blast
    then have xab': "a\<noteq>b" using  Eproper[OF xE]  by auto
    from insert(4) forest_mono have fF: "forest F" by auto
    with insert(3) have eq: "card (CCs F) + card F = card V" by auto

    from insert(4) forest_subE have k: "F \<subseteq> E" by auto
    from xab xab' have abV: "a\<in>V" "b\<in>V" using E_inV xE by fastforce+
    from insert(2) xab have "Upair a b \<notin> F" by auto

    have "(a,b) \<notin> connected F" apply(subst augment_forest[symmetric])
        apply fact
      using xE xab apply simp
      using xab insert by auto
    with k abV sameCC_reachable have "CC F a \<noteq> CC F b" by auto
    have "Suc (card (CCs (insert (Upair a b) F))) = card (CCs F)"
      apply(rule union_eqclass_decreases_components)
      by fact+
    then show ?case using xab insert(1,2) eq   by auto
  qed (simp add: CCs_empty_card)
qed

lemma pigeonhole_CCs:
  assumes finiteV: "finite V" and cardlt: "card (CCs E1) < card (CCs E2)"
  shows "(\<exists>u v. u\<in>V \<and> v\<in>V \<and> CC E1 u = CC E1 v \<and> CC E2 u \<noteq> CC E2 v)"
proof (rule ccontr, clarsimp)
  assume "\<forall>u. u \<in> V \<longrightarrow> (\<forall>v. CC E1 u = CC E1 v \<longrightarrow> v \<in> V \<longrightarrow> CC E2 u = CC E2 v)"
  then have "\<And>u v. u\<in>V \<Longrightarrow> v\<in>V \<Longrightarrow> CC E1 u = CC E1 v \<Longrightarrow> CC E2 u = CC E2 v" by blast

  with coarser[OF finiteV] have "card ((CC E1) ` V) \<ge> card ((CC E2) ` V)" by blast

  with CCs_imageCC cardlt show "False" by auto
qed

theorem assumes f1: "forest E1"
  and f2: "forest E2"
  and c: "card E1 > card E2"
shows augment: "\<exists>e\<in>E1-E2. forest (insert e E2)"
proof -
  \<comment> \<open>as E1 and E2 are both forests, and E1 has more edges than E2, E2 has more connected
        components than E1\<close>
  from forest_CCs[OF f1] forest_CCs[OF f2] c have "card (CCs E1) < card (CCs E2)" by linarith

\<comment> \<open>by an pigeonhole argument, we can obtain two vertices u and v that are in the same components of E1,
        but in different components of E2\<close>
  then obtain u v where sameCCinE1: "CC E1 u = CC E1 v" and
    diffCCinE2: "CC E2 u \<noteq> CC E2 v" and k: "u \<in> V" "v \<in> V"
    using pigeonhole_CCs[OF finiteV] by blast

  from diffCCinE2 have unv: "u \<noteq> v" by auto

\<comment> \<open>this means that there is a path from u to v in E1 ...\<close>
  from f1 forest_subE have e1: "E1 \<subseteq> E" by auto
  with connected_Epath sameCC_reachable k sameCCinE1 obtain p
    where pathinE1: "path E1 u p v"
    by auto
      \<comment> \<open>... but none in E2\<close>
  from f2 forest_subE have "E2 \<subseteq> E" by auto
  with connected_Epath sameCC_reachable k diffCCinE2
  have nopathinE2: "\<not>(\<exists>p. path E2 u p v)"
    by auto

\<comment> \<open>hence, we can find vertices a and b that are not connected in E2,
          but are connected by an edge in E1\<close>
  obtain a b where pe: "(a,b) \<notin> connected E2" and abE2: "Upair a b \<notin> E2"
    and abE1: "Upair a b \<in> E1"
    using findaugmenting_aux[OF pathinE1 nopathinE2] by auto

  with forest_subE[OF f1] have "Upair a b \<in> E" by auto
  from abE1 abE2 have abdif: "Upair a b \<in> E1 - E2" by auto
  with e1 have "Upair a b \<in> E - E2" by auto

\<comment> \<open>we can savely add this edge {a,b} to E2 and obtain a bigger forest\<close>
  have "forest (insert (Upair a b) E2)" apply(subst augment_forest)
    by fact+
  then show "\<exists>e\<in>E1-E2. forest (insert e E2)" using abdif
    by blast
qed

sublocale minWeightBasis E forest weight
proof
  have "forest {}" using forest_empty by auto
  then show "\<exists>X. forest X" by blast
qed (auto simp: forest_subE forest_mono augment)

end

locale Kruskal_intermediate_time = Kruskal_intermediate +
 fixes
       empty_forest_time  empty_uf_time indep_test_time insert_time insert_uf_time :: nat
    and getEdges_time sort_time :: nat
begin

sublocale minWeightBasis_time E forest weight      "getEdges_time + sort_time"
     "empty_forest_time + empty_uf_time" indep_test_time "insert_time+insert_uf_time"
  apply unfold_locales .

end

end


(* Title:      Matrices over Bounded Linear Orders
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Matrices over Bounded Linear Orders\<close>

text \<open>
In this theory we characterise relation-algebraic properties of matrices over bounded linear orders (for example, extended real numbers) in terms of the entries in the matrices.
We consider, in particular, the following properties: univalent, injective, total, surjective, mapping, bijective, vector, covector, point, arc, reflexive, coreflexive, irreflexive, symmetric, antisymmetric, asymmetric.
We also consider the effect of composition with the matrix of greatest elements and with coreflexives (tests).
\<close>

theory Linear_Order_Matrices

imports Matrix_Relation_Algebras

begin

class non_trivial_linorder_stone_relation_algebra_expansion = linorder_stone_relation_algebra_expansion + non_trivial
begin

subclass non_trivial_bounded_order ..

end

text \<open>
Before we look at matrices, we generalise selectivity to finite suprema.
\<close>

lemma linorder_finite_sup_selective:
  fixes f :: "'a::finite \<Rightarrow> 'b::linorder_stone_algebra_expansion"
  shows "\<exists>i . (\<Squnion>\<^sub>k f k) = f i"
  apply (induct rule: comp_inf.one_sup_induct)
  apply blast
  using sup_selective by fastforce

lemma linorder_top_finite_sup:
  fixes f :: "'a::finite \<Rightarrow> 'b::linorder_stone_algebra_expansion"
  assumes "\<forall>k . f k \<noteq> top"
    shows "(\<Squnion>\<^sub>k f k) \<noteq> top"
  by (metis assms linorder_finite_sup_selective)

text \<open>
The following results show the effect of composition with the \<open>top\<close> matrix from the left and from the right.
\<close>

lemma comp_top_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "(f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k f (i,k))"
  apply (unfold times_matrix_def top_matrix_def)
  by (metis (no_types, lifting) case_prod_conv comp_right_one one_def sup_monoid.sum.cong)

lemma top_comp_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "(mtop \<odot> f) (i,j) = (\<Squnion>\<^sub>k f (k,j))"
  apply (unfold times_matrix_def top_matrix_def)
  by (metis (no_types, lifting) case_prod_conv comp_left_one one_def sup_monoid.sum.cong)

text \<open>
We characterise univalent matrices: in each row, at most one entry may be different from \<open>bot\<close>.
\<close>

lemma univalent_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_stone_relation_algebra.univalent f"
      and "f (i,j) \<noteq> bot"
      and "f (i,k) \<noteq> bot"
    shows "j = k"
proof -
  have "(f\<^sup>t \<odot> f) (j,k) = (\<Squnion>\<^sub>l (f\<^sup>t) (j,l) * f (l,k))"
    by (simp add: times_matrix_def)
  also have "... = (\<Squnion>\<^sub>l (f (l,j))\<^sup>T * f (l,k))"
    by (simp add: conv_matrix_def)
  also have "... = (\<Squnion>\<^sub>l f (l,j) * f (l,k))"
    by simp
  also have "... \<ge> f (i,j) * f (i,k)"
    using comp_inf.ub_sum by fastforce
  finally have "(f\<^sup>t \<odot> f) (j,k) \<noteq> bot"
    using assms(2,3) bot.extremum_uniqueI times_dense by fastforce
  hence "mone (j,k) \<noteq> (bot::'b)"
    by (metis assms(1) bot.extremum_uniqueI less_eq_matrix_def)
  thus ?thesis
    by (metis (mono_tags, lifting) case_prod_conv one_matrix_def)
qed

lemma univalent_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i j k . f (i,j) \<noteq> bot \<and> f (i,k) \<noteq> bot \<longrightarrow> j = k"
    shows "matrix_stone_relation_algebra.univalent f"
proof -
  show "f\<^sup>t \<odot> f \<preceq> mone"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix j k
    show "(f\<^sup>t \<odot> f) (j,k) \<le> mone (j,k)"
    proof (cases "j = k")
      assume "j = k"
      thus ?thesis
        by (simp add: one_matrix_def)
    next
      assume "j \<noteq> k"
      hence "(\<Squnion>\<^sub>i f (i,j) * f (i,k)) = bot"
        by (metis (no_types, lifting) assms semiring.mult_not_zero sup_monoid.sum.neutral)
      thus ?thesis
        by (simp add: times_matrix_def conv_matrix_def)
    qed
  qed
qed

lemma univalent_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.univalent f \<longleftrightarrow> (\<forall>i j k . f (i,j) \<noteq> bot \<and> f (i,k) \<noteq> bot \<longrightarrow> j = k)"
  using univalent_linorder_matrix_1 univalent_linorder_matrix_2 by auto

text \<open>
Injective matrices can then be characterised by applying converse: in each column, at most one entry may be different from \<open>bot\<close>.
\<close>

lemma injective_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.injective f \<longleftrightarrow> (\<forall>i j k . f (j,i) \<noteq> bot \<and> f (k,i) \<noteq> bot \<longrightarrow> j = k)"
  by (unfold matrix_stone_relation_algebra.injective_conv_univalent univalent_linorder_matrix) (simp add: conv_matrix_def)

text \<open>
Next come total matrices: each row has a \<open>top\<close> entry.
\<close>

lemma total_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_stone_relation_algebra.total_var f"
    shows "\<exists>j . f (i,j) = top"
proof -
  have "mone (i,i) \<le> (f \<odot> f\<^sup>t) (i,i)"
    using assms less_eq_matrix_def by blast
  hence "top = (f \<odot> f\<^sup>t) (i,i)"
    by (simp add: one_matrix_def top.extremum_unique)
  also have "... = (\<Squnion>\<^sub>j f (i,j) * (f\<^sup>t) (j,i))"
    by (simp add: times_matrix_def)
  also have "... = (\<Squnion>\<^sub>j f (i,j) * f (i,j))"
    by (simp add: conv_matrix_def)
  also have "... = (\<Squnion>\<^sub>j f (i,j))"
    by simp
  finally show ?thesis
    by (metis linorder_top_finite_sup)
qed

lemma total_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i . \<exists>j . f (i,j) = top"
    shows "matrix_stone_relation_algebra.total_var f"
proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
  fix j k
  show "mone (j,k) \<le> (f \<odot> f\<^sup>t) (j,k)"
  proof (cases "j = k")
    assume "j = k"
    hence "(\<Squnion>\<^sub>i f (j,i) * (f\<^sup>t) (i,k)) = (\<Squnion>\<^sub>i f (j,i))"
      by (simp add: conv_matrix_def)
    also have "... = top"
      by (metis (no_types) assms comp_inf.ub_sum sup.absorb2 sup_top_left)
    finally show ?thesis
      by (simp add: times_matrix_def)
  next
    assume "j \<noteq> k"
    thus ?thesis
      by (simp add: one_matrix_def)
  qed
qed

lemma total_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.total f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) = top)"
  using total_linorder_matrix_1 total_linorder_matrix_2 matrix_stone_relation_algebra.total_var by auto

text \<open>
Surjective matrices are again characterised by applying converse: each column has a \<open>top\<close> entry.
\<close>

lemma surjective_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.surjective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) = top)"
  by (unfold matrix_stone_relation_algebra.surjective_conv_total total_linorder_matrix) (simp add: conv_matrix_def)

text \<open>
A mapping therefore means that each row has exactly one \<open>top\<close> entry and all others are \<open>bot\<close>.
\<close>

lemma mapping_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.mapping f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
  by (unfold total_linorder_matrix univalent_linorder_matrix) (metis (mono_tags, hide_lams) comp_inf.mult_1_right comp_inf.mult_right_zero)

lemma mapping_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.mapping f \<longleftrightarrow> (\<forall>i . \<exists>!j . f (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
  apply (unfold mapping_linorder_matrix)
  using bot_not_top by auto

text \<open>
Conversely, bijective means that each column has exactly one \<open>top\<close> entry and all others are \<open>bot\<close>.
\<close>

lemma bijective_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.bijective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  by (unfold matrix_stone_relation_algebra.bijective_conv_mapping mapping_linorder_matrix) (simp add: conv_matrix_def)

lemma bijective_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.bijective f \<longleftrightarrow> (\<forall>j . \<exists>!i . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  by (unfold matrix_stone_relation_algebra.bijective_conv_mapping mapping_linorder_matrix_unique) (simp add: conv_matrix_def)

text \<open>
We derive algebraic characterisations of matrices in which each row has an entry that is different from \<open>bot\<close>.
\<close>

lemma pp_total_linorder_matrix_1:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  assumes "\<ominus>(f \<odot> mtop) = mbot"
    shows "\<exists>j . f (i,j) \<noteq> bot"
proof -
  have "\<not>(\<exists>j . f (i,j) \<noteq> bot) \<Longrightarrow> \<ominus>(f \<odot> mtop) \<noteq> mbot"
  proof -
    assume "\<not>(\<exists>j . f (i,j) \<noteq> bot)"
    hence "top = -(f \<odot> mtop) (i,i)"
      by (simp add: comp_top_linorder_matrix linorder_finite_sup_selective)
    also have "... = (\<ominus>(f \<odot> mtop)) (i,i)"
      by (simp add: uminus_matrix_def)
    finally show "\<ominus>(f \<odot> mtop) \<noteq> mbot"
      by (metis bot_matrix_def bot_not_top)
  qed
  thus ?thesis
    using assms by blast
qed

lemma pp_total_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i . \<exists>j . f (i,j) \<noteq> bot"
    shows "\<ominus>(f \<odot> mtop) = mbot"
proof (rule ext, rule prod_cases)
  fix i j
  have "(\<ominus>(f \<odot> mtop)) (i,j) = -(\<Squnion>\<^sub>k f (i,k))"
    by (simp add: comp_top_linorder_matrix uminus_matrix_def)
  also have "... = bot"
    by (metis antisym assms bot.extremum comp_inf.ub_sum uminus_def)
  finally show "(\<ominus>(f \<odot> mtop)) (i,j) = mbot (i,j)"
    by (simp add: bot_matrix_def)
qed

lemma pp_total_linorder_matrix_3:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "\<ominus>(f \<odot> mtop) = mbot \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot)"
  using pp_total_linorder_matrix_1 pp_total_linorder_matrix_2 by auto

lemma pp_total_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.total (\<ominus>\<ominus>f) \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot)"
  using matrix_stone_relation_algebra.pp_total pp_total_linorder_matrix_1 pp_total_linorder_matrix_2 by auto

lemma pp_mapping_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_mapping f \<longleftrightarrow> (\<forall>i . \<exists>j . f (i,j) \<noteq> bot \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
  by (metis (mono_tags, hide_lams) pp_total_linorder_matrix univalent_linorder_matrix_1 univalent_linorder_matrix_2)

lemma pp_mapping_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_mapping f \<longleftrightarrow> (\<forall>i . \<exists>!j . f (i,j) \<noteq> bot \<and> (\<forall>k . j \<noteq> k \<longrightarrow> f (i,k) = bot))"
  apply (rule iffI)
  using pp_mapping_linorder_matrix apply blast
  by (metis pp_total_linorder_matrix univalent_linorder_matrix)

text \<open>
Next follow matrices in which each column has an entry that is different from \<open>bot\<close>.
\<close>

lemma pp_surjective_linorder_matrix_1:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "\<ominus>(mtop \<odot> f) = mbot \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
proof -
  have "\<ominus>(mtop \<odot> f) = mbot \<longleftrightarrow> (\<ominus>(mtop \<odot> f))\<^sup>t = mbot\<^sup>t"
    by (metis matrix_stone_relation_algebra.conv_involutive)
  also have "... \<longleftrightarrow> \<ominus>(f\<^sup>t \<odot> mtop) = mbot"
    by (simp add: matrix_stone_relation_algebra.conv_complement matrix_stone_relation_algebra.conv_dist_comp)
  also have "... \<longleftrightarrow> (\<forall>i . \<exists>j . (f\<^sup>t) (i,j) \<noteq> bot)"
    using pp_total_linorder_matrix_3 by auto
  also have "... \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
    by (simp add: conv_matrix_def)
  finally show ?thesis
    .
qed

lemma pp_surjective_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.surjective (\<ominus>\<ominus>f) \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot)"
  using matrix_stone_relation_algebra.pp_surjective pp_surjective_linorder_matrix_1 by auto

lemma pp_bijective_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_bijective f \<longleftrightarrow> (\<forall>j . \<exists>i . f (i,j) \<noteq> bot \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  by (unfold matrix_stone_relation_algebra.pp_bijective_conv_mapping pp_mapping_linorder_matrix) (simp add: conv_matrix_def)

lemma pp_bijective_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_bijective f \<longleftrightarrow> (\<forall>j . \<exists>!i . f (i,j) \<noteq> bot \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  by (unfold matrix_stone_relation_algebra.pp_bijective_conv_mapping pp_mapping_linorder_matrix_unique) (simp add: conv_matrix_def)

text \<open>
The regular matrices are those which contain only \<open>bot\<close> or \<open>top\<close> entries.
\<close>

lemma regular_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_p_algebra.regular f \<longleftrightarrow> (\<forall>e . f e = bot \<or> f e = top)"
proof -
  have "matrix_p_algebra.regular f \<longleftrightarrow> (\<ominus>\<ominus>f = f)"
    by auto
  also have "... \<longleftrightarrow> (\<forall>e . --f e = f e)"
    by (metis uminus_matrix_def ext)
  also have "... \<longleftrightarrow> (\<forall>e . f e = bot \<or> f e = top)"
    by force
  finally show ?thesis
    .
qed

text \<open>
Vectors are precisely the row-constant matrices.
\<close>

lemma vector_linorder_matrix_0:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_bounded_idempotent_semiring.vector f"
    shows "f (i,j) = (\<Squnion>\<^sub>k f (i,k))"
  by (metis assms comp_top_linorder_matrix)

lemma vector_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_bounded_idempotent_semiring.vector f"
    shows "f (i,j) = f (i,k)"
  by (metis assms vector_linorder_matrix_0)

lemma vector_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i j k . f (i,j) = f (i,k)"
    shows "matrix_bounded_idempotent_semiring.vector f"
proof (rule ext, rule prod_cases)
  fix i j
  have "(f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>k f (i,k))"
    by (simp add: comp_top_linorder_matrix)
  also have "... = f (i,j)"
    by (metis assms linorder_finite_sup_selective)
  finally show "(f \<odot> mtop) (i,j) = f (i,j)"
    .
qed

lemma vector_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.vector f \<longleftrightarrow> (\<forall>i j k . f (i,j) = f (i,k))"
  using vector_linorder_matrix_1 vector_linorder_matrix_2 by auto

text \<open>
Hence covectors are precisely the column-constant matrices.
\<close>

lemma covector_linorder_matrix_0:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_bounded_idempotent_semiring.covector f"
    shows "f (i,j) = (\<Squnion>\<^sub>k f (k,j))"
  by (metis assms top_comp_linorder_matrix)

lemma covector_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_bounded_idempotent_semiring.covector f \<longleftrightarrow> (\<forall>i j k . f (i,j) = f (k,j))"
  by (unfold matrix_stone_relation_algebra.covector_conv_vector vector_linorder_matrix) (metis (no_types, lifting) case_prod_conv conv_matrix_def conv_def)

text \<open>
A point is a matrix that has exactly one row, which is constant \<open>top\<close>, and all other rows are constant \<open>bot\<close>.
\<close>

lemma point_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.point f \<longleftrightarrow> (\<exists>i . \<forall>j . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  apply (unfold vector_linorder_matrix bijective_linorder_matrix)
  apply (rule iffI)
  apply metis
  by metis

lemma point_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.point f \<longleftrightarrow> (\<exists>!i . \<forall>j . f (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  apply (unfold vector_linorder_matrix bijective_linorder_matrix)
  apply (rule iffI)
  apply (metis bot_not_top)
  by metis

lemma pp_point_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_point f \<longleftrightarrow> (\<exists>i . \<forall>j . f (i,j) \<noteq> bot \<and> (\<forall>k . f (i,j) = f (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  apply (unfold vector_linorder_matrix pp_bijective_linorder_matrix)
  apply (rule iffI)
  apply metis
  by metis

lemma pp_point_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_point f \<longleftrightarrow> (\<exists>!i . \<forall>j . f (i,j) \<noteq> bot \<and> (\<forall>k . f (i,j) = f (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> f (k,j) = bot))"
  apply (unfold vector_linorder_matrix pp_bijective_linorder_matrix)
  apply (rule iffI)
  apply metis
  by metis

text \<open>
An arc is a matrix that has exactly one \<open>top\<close> entry and all other entries are \<open>bot\<close>.
\<close>

lemma arc_linorder_matrix_1:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_stone_relation_algebra.arc f"
    shows "\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
proof -
  have "matrix_stone_relation_algebra.point (f \<odot> mtop)"
    by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
  from this obtain i where 1: "\<forall>j . (f \<odot> mtop) (i,j) = top \<and> (\<forall>k . i \<noteq> k \<longrightarrow> (f \<odot> mtop) (k,j) = bot)"
    using point_linorder_matrix by blast
  have "matrix_stone_relation_algebra.point (f\<^sup>t \<odot> mtop)"
    by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
  from this obtain j where "\<forall>i . (f\<^sup>t \<odot> mtop) (j,i) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (f\<^sup>t \<odot> mtop) (k,i) = bot)"
    using point_linorder_matrix by blast
  hence 2: "\<forall>i . (mtop \<odot> f) (i,j) = top \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (mtop \<odot> f) (i,k) = bot)"
    by (metis (no_types) old.prod.case conv_matrix_def conv_def matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
  have 3: "\<forall>i k . j \<noteq> k \<longrightarrow> f (i,k) = bot"
  proof (intro allI, rule impI)
    fix i k
    assume "j \<noteq> k"
    hence "(\<Squnion>\<^sub>l f (l,k)) = bot"
      using 2 by (simp add: top_comp_linorder_matrix)
    thus "f (i,k) = bot"
      by (metis bot.extremum_uniqueI comp_inf.ub_sum)
  qed
  have "(\<Squnion>\<^sub>k f (i,k)) = top"
    using 1 by (simp add: comp_top_linorder_matrix)
  hence 4: "f (i,j) = top"
    using 3 by (metis bot_not_top linorder_finite_sup_selective)
  have "\<forall>k l . k \<noteq> i \<or> l \<noteq> j \<longrightarrow> f (k,l) = bot"
  proof (intro allI, unfold imp_disjL, rule conjI)
    fix k l
    show "k \<noteq> i \<longrightarrow> f (k,l) = bot"
    proof
      assume "k \<noteq> i"
      hence "(\<Squnion>\<^sub>m f (k,m)) = bot"
        using 1 by (simp add: comp_top_linorder_matrix)
      thus "f (k,l) = bot"
        by (metis bot.extremum_uniqueI comp_inf.ub_sum)
    qed
    show "l \<noteq> j \<longrightarrow> f (k,l) = bot"
      using 3 by simp
  qed
  thus ?thesis using 4
    by (metis old.prod.exhaust)
qed

lemma pp_arc_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
    shows "matrix_stone_relation_algebra.pp_arc f"
proof (unfold matrix_stone_relation_algebra.pp_arc_expanded, intro conjI)
  show "f \<odot> mtop \<odot> f\<^sup>t \<preceq> mone"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    show "(f \<odot> mtop \<odot> f\<^sup>t) (i,j) \<le> mone (i,j)"
    proof (cases "i = j")
      assume "i = j"
      thus ?thesis
        by (simp add: one_matrix_def)
    next
      assume "i \<noteq> j"
      hence 1: "\<forall>k l . f (i,k) * f (j,l) = bot"
        by (metis assms Pair_inject semiring.mult_not_zero)
      have "(f \<odot> mtop \<odot> f\<^sup>t) (i,j) = (\<Squnion>\<^sub>l (f \<odot> mtop) (i,l) * (f\<^sup>t) (l,j))"
        by (simp add: times_matrix_def)
      also have "... = (\<Squnion>\<^sub>l (f \<odot> mtop) (i,l) * f (j,l))"
        by (simp add: conv_matrix_def)
      also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k)) * f (j,l))"
        by (simp add: comp_top_linorder_matrix)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * f (j,l))"
        by (metis comp_right_dist_sum)
      also have "... = bot"
        using 1 linorder_finite_sup_selective by simp
      finally show ?thesis
        by simp
    qed
  qed
next
  show "f\<^sup>t \<odot> mtop \<odot> f \<preceq> mone"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    show "(f\<^sup>t \<odot> mtop \<odot> f) (i,j) \<le> mone (i,j)"
    proof (cases "i = j")
      assume "i = j"
      thus ?thesis
        by (simp add: one_matrix_def)
    next
      assume "i \<noteq> j"
      hence 2: "\<forall>k l . f (k,i) * f (l,j) = bot"
        by (metis assms Pair_inject semiring.mult_not_zero)
      have "(f\<^sup>t \<odot> mtop \<odot> f) (i,j) = (\<Squnion>\<^sub>l (f\<^sup>t \<odot> mtop) (i,l) * f (l,j))"
        by (simp add: times_matrix_def)
      also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k (f\<^sup>t) (i,k)) * f (l,j))"
        by (simp add: comp_top_linorder_matrix)
      also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (k,i)) * f (l,j))"
        by (simp add: conv_matrix_def)
      also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,i) * f (l,j))"
        by (metis comp_right_dist_sum)
      also have "... = bot"
        using 2 linorder_finite_sup_selective by simp
      finally show ?thesis
        by simp
    qed
  qed
next
  show "mtop \<odot> \<ominus>\<ominus>f \<odot> mtop = mtop"
  proof (rule ext, rule prod_cases)
    fix i j
    from assms obtain k l where "f (k,l) \<noteq> bot"
      using prod.collapse by auto
    hence "top = --f (k,l)"
      by simp
    also have "... \<le> (\<Squnion>\<^sub>k --f (k,l))"
      using comp_inf.ub_sum by metis
    also have "... \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
      using comp_inf.ub_sum by simp
    finally have 3: "top \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
      by simp
    have "(mtop \<odot> \<ominus>\<ominus>f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k top * --f (k,l)) * top)"
      by (simp add: times_matrix_def top_matrix_def uminus_matrix_def)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k --f (k,l))"
      by (metis (no_types, lifting) sup_monoid.sum.cong comp_inf.mult_1_left times_inf comp_inf.mult_1_right)
    also have "... = top"
      using 3 top.extremum_unique by blast
    finally show "(mtop \<odot> \<ominus>\<ominus>f \<odot> mtop) (i,j) = mtop (i,j)"
      by (simp add: top_matrix_def)
  qed
qed

lemma arc_linorder_matrix_2:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  assumes "\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
    shows "matrix_stone_relation_algebra.arc f"
proof (unfold matrix_stone_relation_algebra.arc_expanded, intro conjI)
  show "f \<odot> mtop \<odot> f\<^sup>t \<preceq> mone"
    by (metis (no_types, lifting) assms bot_not_top matrix_stone_relation_algebra.pp_arc_expanded pp_arc_linorder_matrix_2)
next
  show "f\<^sup>t \<odot> mtop \<odot> f \<preceq> mone"
    by (metis (no_types, lifting) assms bot_not_top matrix_stone_relation_algebra.pp_arc_expanded pp_arc_linorder_matrix_2)
next
  show "mtop \<odot> f \<odot> mtop = mtop"
  proof (rule ext, rule prod_cases)
    fix i j
    from assms obtain k l where "f (k,l) = top"
      using prod.collapse by auto
    hence "(\<Squnion>\<^sub>k f (k,l)) = top"
      by (metis (mono_tags) comp_inf.ub_sum top_unique)
    hence 3: "top \<le> (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,l))"
      by (metis (no_types) comp_inf.ub_sum)
    have "(mtop \<odot> f \<odot> mtop) (i,j) = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k top * f (k,l)) * top)"
      by (simp add: times_matrix_def top_matrix_def)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (k,l))"
      by (metis (no_types, lifting) sup_monoid.sum.cong comp_inf.mult_1_left times_inf comp_inf.mult_1_right)
    also have "... = top"
      using 3 top.extremum_unique by blast
    finally show "(mtop \<odot> f \<odot> mtop) (i,j) = mtop (i,j)"
      by (simp add: top_matrix_def)
  qed
qed

lemma arc_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.arc f \<longleftrightarrow> (\<exists>e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
  using arc_linorder_matrix_1 arc_linorder_matrix_2 by blast

lemma arc_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.arc f \<longleftrightarrow> (\<exists>!e . f e = top \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
  apply (rule iffI)
  apply (metis (no_types, hide_lams) arc_linorder_matrix bot_not_top)
  using arc_linorder_matrix by blast

lemma pp_arc_linorder_matrix_1:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_stone_relation_algebra.pp_arc f"
    shows "\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot)"
proof -
  have "matrix_stone_relation_algebra.pp_point (f \<odot> mtop)"
    by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
  from this obtain i where 1: "\<forall>j . (f \<odot> mtop) (i,j) \<noteq> bot \<and> (\<forall>k . (f \<odot> mtop) (i,j) = (f \<odot> mtop) (i,k)) \<and> (\<forall>k . i \<noteq> k \<longrightarrow> (f \<odot> mtop) (k,j) = bot)"
    by (metis pp_point_linorder_matrix)
  have "matrix_stone_relation_algebra.pp_point (f\<^sup>t \<odot> mtop)"
    by (simp add: assms matrix_bounded_idempotent_semiring.vector_mult_closed)
  from this obtain j where "\<forall>i . (f\<^sup>t \<odot> mtop) (j,i) \<noteq> bot \<and> (\<forall>k . (f\<^sup>t \<odot> mtop) (j,i) = (f\<^sup>t \<odot> mtop) (j,k)) \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (f\<^sup>t \<odot> mtop) (k,i) = bot)"
    by (metis pp_point_linorder_matrix)
  hence 2: "\<forall>i . (mtop \<odot> f) (i,j) \<noteq> bot \<and> (\<forall>k . (mtop \<odot> f) (i,j) = (mtop \<odot> f) (k,j)) \<and> (\<forall>k . j \<noteq> k \<longrightarrow> (mtop \<odot> f) (i,k) = bot)"
    by (metis (no_types) old.prod.case conv_matrix_def conv_def matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.conv_top)
  have 3: "\<forall>i k . j \<noteq> k \<longrightarrow> f (i,k) = bot"
  proof (intro allI, rule impI)
    fix i k
    assume "j \<noteq> k"
    hence "(\<Squnion>\<^sub>l f (l,k)) = bot"
      using 2 by (simp add: top_comp_linorder_matrix)
    thus "f (i,k) = bot"
      by (metis bot.extremum_uniqueI comp_inf.ub_sum)
  qed
  have "(\<Squnion>\<^sub>k f (i,k)) \<noteq> bot"
    using 1 by (simp add: comp_top_linorder_matrix)
  hence 4: "f (i,j) \<noteq> bot"
    using 3 by (metis linorder_finite_sup_selective)
  have "\<forall>k l . k \<noteq> i \<or> l \<noteq> j \<longrightarrow> f (k,l) = bot"
  proof (intro allI, unfold imp_disjL, rule conjI)
    fix k l
    show "k \<noteq> i \<longrightarrow> f (k,l) = bot"
    proof
      assume "k \<noteq> i"
      hence "(\<Squnion>\<^sub>m f (k,m)) = bot"
        using 1 by (simp add: comp_top_linorder_matrix)
      thus "f (k,l) = bot"
        by (metis bot.extremum_uniqueI comp_inf.ub_sum)
    qed
    show "l \<noteq> j \<longrightarrow> f (k,l) = bot"
      using 3 by simp
  qed
  thus ?thesis using 4
    by (metis old.prod.exhaust)
qed

lemma pp_arc_linorder_matrix:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_arc f \<longleftrightarrow> (\<exists>e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
  using pp_arc_linorder_matrix_1 pp_arc_linorder_matrix_2 by blast

lemma pp_arc_linorder_matrix_unique:
  fixes f :: "('a::finite,'b::non_trivial_linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.pp_arc f \<longleftrightarrow> (\<exists>!e . f e \<noteq> bot \<and> (\<forall>d . e \<noteq> d \<longrightarrow> f d = bot))"
  apply (rule iffI)
  apply (metis (no_types, hide_lams) pp_arc_linorder_matrix)
  using pp_arc_linorder_matrix by blast

text \<open>
Reflexive matrices are those with a constant \<open>top\<close> diagonal.
\<close>

lemma reflexive_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_idempotent_semiring.reflexive f"
    shows "f (i,i) = top"
proof -
  have "(top::'b) = mone (i,i)"
    by (simp add: one_matrix_def)
  also have "... \<le> f (i,i)"
    using assms less_eq_matrix_def by blast
  finally show ?thesis
    by (simp add: top.extremum_unique)
qed

lemma reflexive_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i . f (i,i) = top"
    shows "matrix_idempotent_semiring.reflexive f"
proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
  fix i j
  show "mone (i,j) \<le> f (i,j)"
  proof (cases "i = j")
    assume "i = j"
    thus ?thesis
      by (simp add: assms)
  next
    assume "i \<noteq> j"
    hence "(bot::'b) = mone (i,j)"
      by (simp add: one_matrix_def)
    thus ?thesis
      by simp
  qed
qed

lemma reflexive_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_idempotent_semiring.reflexive f \<longleftrightarrow> (\<forall>i . f (i,i) = top)"
  using reflexive_linorder_matrix_1 reflexive_linorder_matrix_2 by auto

text \<open>
Coreflexive matrices are those in which all non-diagonal entries are \<open>bot\<close>.
\<close>

lemma coreflexive_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_idempotent_semiring.coreflexive f"
      and "i \<noteq> j"
    shows "f (i,j) = bot"
proof -
  have "f (i,j) \<le> mone (i,j)"
    using assms less_eq_matrix_def by blast
  also have "... = bot"
    by (simp add: assms one_matrix_def)
  finally show ?thesis
    by (simp add: bot.extremum_unique)
qed

lemma coreflexive_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot"
    shows "matrix_idempotent_semiring.coreflexive f"
proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
  fix i j
  show "f (i,j) \<le> mone (i,j)"
  proof (cases "i = j")
    assume "i = j"
    hence "(top::'b) = mone (i,j)"
      by (simp add: one_matrix_def)
    thus ?thesis
      by simp
  next
    assume "i \<noteq> j"
    thus ?thesis
      by (simp add: assms)
  qed
qed

lemma coreflexive_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_idempotent_semiring.coreflexive f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot)"
  using coreflexive_linorder_matrix_1 coreflexive_linorder_matrix_2 by auto

text \<open>
Irreflexive matrices are those with a constant \<open>bot\<close> diagonal.
\<close>

lemma irreflexive_linorder_matrix_1:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_stone_relation_algebra.irreflexive f"
    shows "f (i,i) = bot"
proof -
  have "(top::'b) = mone (i,i)"
    by (simp add: one_matrix_def)
  hence "(bot::'b) = (\<ominus>mone) (i,i)"
    by (simp add: uminus_matrix_def)
  hence "f (i,i) \<le> bot"
    by (metis assms less_eq_matrix_def)
  thus ?thesis
    by (simp add: bot.extremum_unique)
qed

lemma irreflexive_linorder_matrix_2:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "\<forall>i . f (i,i) = bot"
    shows "matrix_stone_relation_algebra.irreflexive f"
proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
  fix i j
  show "f (i,j) \<le> (\<ominus>mone) (i,j)"
  proof (cases "i = j")
    assume "i = j"
    thus ?thesis
      by (simp add: assms)
  next
    assume "i \<noteq> j"
    hence "(bot::'b) = mone (i,j)"
      by (simp add: one_matrix_def)
    hence "(top::'b) = (\<ominus>mone) (i,j)"
      by (simp add: uminus_matrix_def)
    thus ?thesis
      by simp
  qed
qed

lemma irreflexive_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.irreflexive f \<longleftrightarrow> (\<forall>i . f (i,i) = bot)"
  using irreflexive_linorder_matrix_1 irreflexive_linorder_matrix_2 by auto

text \<open>
As usual, symmetric matrices are those which do not change under transposition.
\<close>

lemma symmetric_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.symmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) = f (j,i))"
  by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta conv_matrix_def conv_def)

text \<open>
Antisymmetric matrices are characterised as follows: each entry not on the diagonal or its mirror entry across the diagonal must be \<open>bot\<close>.
\<close>

lemma antisymmetric_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.antisymmetric f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) = bot \<or> f (j,i) = bot)"
proof -
  have "matrix_stone_relation_algebra.antisymmetric f \<longleftrightarrow> (\<forall>i j . i \<noteq> j \<longrightarrow> f (i,j) \<sqinter> f (j,i) \<le> bot)"
    by (simp add: conv_matrix_def inf_matrix_def less_eq_matrix_def one_matrix_def)
  thus ?thesis
    by (metis (no_types, hide_lams) inf.absorb_iff1 inf.cobounded1 inf_bot_right inf_dense)
qed

text \<open>
For asymmetric matrices the diagonal is included: each entry or its mirror entry across the diagonal must be \<open>bot\<close>.
\<close>

lemma asymmetric_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_stone_relation_algebra.asymmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) = bot \<or> f (j,i) = bot)"
proof -
  have "matrix_stone_relation_algebra.asymmetric f \<longleftrightarrow> (\<forall>i j . f (i,j) \<sqinter> f (j,i) \<le> bot)"
    apply (unfold conv_matrix_def inf_matrix_def conv_def id_def bot_matrix_def)
    by (metis (mono_tags, lifting) bot.extremum bot.extremum_uniqueI case_prod_conv old.prod.exhaust)
  thus ?thesis
    by (metis (no_types, hide_lams) inf.absorb_iff1 inf.cobounded1 inf_bot_right inf_dense)
qed

text \<open>
In a transitive matrix, the weight of one of the edges on an indirect route must be below the weight of the direct edge.
\<close>

lemma transitive_linorder_matrix:
  fixes f :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  shows "matrix_idempotent_semiring.transitive f \<longleftrightarrow> (\<forall>i j k . f (i,k) \<le> f (i,j) \<or> f (k,j) \<le> f (i,j))"
proof -
  have "matrix_idempotent_semiring.transitive f \<longleftrightarrow> (\<forall>i j . (\<Squnion>\<^sub>k f (i,k) * f (k,j)) \<le> f (i,j))"
    by (simp add: times_matrix_def less_eq_matrix_def)
  also have "... \<longleftrightarrow> (\<forall>i j k . f (i,k) * f (k,j) \<le> f (i,j))"
    by (simp add: lub_sum_iff)
  also have "... \<longleftrightarrow> (\<forall>i j k . f (i,k) \<le> f (i,j) \<or> f (k,j) \<le> f (i,j))"
    using inf_less_eq by fastforce
  finally show ?thesis
    .
qed

text \<open>
We finally show the effect of composing with a coreflexive (test) from the left and from the right.
This amounts to a restriction of each row or column to the entry on the diagonal of the coreflexive.
In this case, restrictions are formed by meets.
\<close>

lemma coreflexive_comp_linorder_matrix:
  fixes f g :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_idempotent_semiring.coreflexive f"
    shows "(f \<odot> g) (i,j) = f (i,i) \<sqinter> g (i,j)"
proof -
  have 1: "\<forall>k . i \<noteq> k \<longrightarrow> f (i,k) = bot"
    using assms coreflexive_linorder_matrix by auto
  have "(\<Squnion>\<^sub>k f (i,k)) = f (i,i) \<squnion> (\<Squnion>\<^bsub>k\<in>UNIV-{i}\<^esub> f (i,k))"
    by (metis (no_types) UNIV_def brouwer.inf_bot_right finite_UNIV insert_def sup_monoid.sum.insert_remove)
  hence 2: "(\<Squnion>\<^sub>k f (i,k)) = f (i,i)"
    using 1 by (metis (no_types) linorder_finite_sup_selective sup_not_bot)
  have "(f \<odot> g) (i,j) = (f \<odot> mtop \<otimes> g) (i,j)"
    by (metis assms matrix_stone_relation_algebra.coreflexive_comp_top_inf)
  also have "... = (\<Squnion>\<^sub>k f (i,k)) \<sqinter> g (i,j)"
    by (metis inf_matrix_def comp_top_linorder_matrix)
  finally show ?thesis
    using 2 by simp
qed

lemma comp_coreflexive_linorder_matrix:
  fixes f g :: "('a::finite,'b::linorder_stone_relation_algebra_expansion) square"
  assumes "matrix_idempotent_semiring.coreflexive g"
    shows "(f \<odot> g) (i,j) = f (i,j) \<sqinter> g (j,j)"
proof -
  have "(f \<odot> g) (i,j) = ((f \<odot> g)\<^sup>t) (j,i)"
    by (simp add: conv_matrix_def)
  also have "... = (g \<odot> f\<^sup>t) (j,i)"
    by (simp add: assms matrix_stone_relation_algebra.conv_dist_comp matrix_stone_relation_algebra.coreflexive_symmetric)
  also have "... = g (j,j) \<sqinter> (f\<^sup>t) (j,i)"
    by (simp add: assms coreflexive_comp_linorder_matrix)
  also have "... = f (i,j) \<sqinter> g (j,j)"
    by (metis (no_types, lifting) conv_def old.prod.case conv_matrix_def inf_commute)
  finally show ?thesis
    .
qed

end


theory Lens_Record_Example
  imports Optics
begin

text \<open>The alphabet command supports syntax illustrated in the following comments.\<close>

alphabet mylens =
  x :: nat
  y :: string

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses
thm quotients
thm compositions

lemma mylens_composition:
  "x +\<^sub>L y +\<^sub>L more\<^sub>L \<approx>\<^sub>L 1\<^sub>L" (is "?P \<approx>\<^sub>L ?Q")
proof -
  have "?Q \<approx>\<^sub>L base\<^sub>L +\<^sub>L more\<^sub>L"
    by (simp add: lens_equiv_sym)
  also have "... \<approx>\<^sub>L (x +\<^sub>L y) +\<^sub>L more\<^sub>L"
    by (simp add: lens_plus_eq_left)
  also have "... \<approx>\<^sub>L x +\<^sub>L y +\<^sub>L more\<^sub>L"
    by (simp add: lens_plus_assoc)
  finally show ?thesis
    using lens_equiv_sym by auto
qed

lemma mylens_bij_lens:
  "bij_lens (x +\<^sub>L y +\<^sub>L more\<^sub>L)"
  using bij_lens_equiv_id mylens_composition by auto

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

thm lens_defs

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses

end


(*  Title:      HOL/TLA/Intensional.thy
    Author:     Stephan Merz
    Copyright:  1998 University of Munich
*)

section \<open>A framework for "intensional" (possible-world based) logics
  on top of HOL, with lifting of constants and functions\<close>

theory Intensional
imports MainRLT
begin

class world

(** abstract syntax **)

type_synonym ('w,'a) expr = "'w \<Rightarrow> 'a"   (* intention: 'w::world, 'a::type *)
type_synonym 'w form = "('w, bool) expr"

definition Valid :: "('w::world) form \<Rightarrow> bool"
  where "Valid A \<equiv> \<forall>w. A w"

definition const :: "'a \<Rightarrow> ('w::world, 'a) expr"
  where unl_con: "const c w \<equiv> c"

definition lift :: "['a \<Rightarrow> 'b, ('w::world, 'a) expr] \<Rightarrow> ('w,'b) expr"
  where unl_lift: "lift f x w \<equiv> f (x w)"

definition lift2 :: "['a \<Rightarrow> 'b \<Rightarrow> 'c, ('w::world,'a) expr, ('w,'b) expr] \<Rightarrow> ('w,'c) expr"
  where unl_lift2: "lift2 f x y w \<equiv> f (x w) (y w)"

definition lift3 :: "['a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr] \<Rightarrow> ('w,'d) expr"
  where unl_lift3: "lift3 f x y z w \<equiv> f (x w) (y w) (z w)"

(* "Rigid" quantification (logic level) *)
definition RAll :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rall " 10)
  where unl_Rall: "(Rall x. A x) w \<equiv> \<forall>x. A x w"
definition REx :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex " 10)
  where unl_Rex: "(Rex x. A x) w \<equiv> \<exists>x. A x w"
definition REx1 :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex! " 10)
  where unl_Rex1: "(Rex! x. A x) w \<equiv> \<exists>!x. A x w"

(** concrete syntax **)

nonterminal lift and liftargs

syntax
  ""            :: "id \<Rightarrow> lift"                          ("_")
  ""            :: "longid \<Rightarrow> lift"                      ("_")
  ""            :: "var \<Rightarrow> lift"                         ("_")
  "_applC"      :: "[lift, cargs] \<Rightarrow> lift"               ("(1_/ _)" [1000, 1000] 999)
  ""            :: "lift \<Rightarrow> lift"                        ("'(_')")
  "_lambda"     :: "[idts, 'a] \<Rightarrow> lift"                  ("(3\<lambda>_./ _)" [0, 3] 3)
  "_constrain"  :: "[lift, type] \<Rightarrow> lift"                ("(_::_)" [4, 0] 3)
  ""            :: "lift \<Rightarrow> liftargs"                    ("_")
  "_liftargs"   :: "[lift, liftargs] \<Rightarrow> liftargs"        ("_,/ _")
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(\<turnstile> _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ \<Turnstile> _)" [100,10] 10)

  (* Syntax for lifted expressions outside the scope of \<turnstile> or |= *)
  "_LIFT"       :: "lift \<Rightarrow> 'a"                          ("LIFT _")

  (* generic syntax for lifted constants and functions *)
  "_const"      :: "'a \<Rightarrow> lift"                          ("(#_)" [1000] 999)
  "_lift"       :: "['a, lift] \<Rightarrow> lift"                  ("(_<_>)" [1000] 999)
  "_lift2"      :: "['a, lift, lift] \<Rightarrow> lift"            ("(_<_,/ _>)" [1000] 999)
  "_lift3"      :: "['a, lift, lift, lift] \<Rightarrow> lift"      ("(_<_,/ _,/ _>)" [1000] 999)

  (* concrete syntax for common infix functions: reuse same symbol *)
  "_liftEqu"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ =/ _)" [50,51] 50)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ \<noteq>/ _)" [50,51] 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("(\<not> _)" [40] 40)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ \<and>/ _)" [36,35] 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                ("(_ \<or>/ _)" [31,30] 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ \<longrightarrow>/ _)" [26,25] 25)
  "_liftIf"     :: "[lift, lift, lift] \<Rightarrow> lift"          ("(if (_)/ then (_)/ else (_))" 10)
  "_liftPlus"   :: "[lift, lift] \<Rightarrow> lift"                ("(_ +/ _)" [66,65] 65)
  "_liftMinus"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ -/ _)" [66,65] 65)
  "_liftTimes"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ */ _)" [71,70] 70)
  "_liftDiv"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ div _)" [71,70] 70)
  "_liftMod"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ mod _)" [71,70] 70)
  "_liftLess"   :: "[lift, lift] \<Rightarrow> lift"                ("(_/ < _)"  [50, 51] 50)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<le> _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<in> _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<notin> _)" [50, 51] 50)
  "_liftFinset" :: "liftargs \<Rightarrow> lift"                    ("{(_)}")
  (** TODO: syntax for lifted collection / comprehension **)
  "_liftPair"   :: "[lift,liftargs] \<Rightarrow> lift"                   ("(1'(_,/ _'))")
  (* infix syntax for list operations *)
  "_liftCons" :: "[lift, lift] \<Rightarrow> lift"                  ("(_ #/ _)" [65,66] 65)
  "_liftApp"  :: "[lift, lift] \<Rightarrow> lift"                  ("(_ @/ _)" [65,66] 65)
  "_liftList" :: "liftargs \<Rightarrow> lift"                      ("[(_)]")

  (* Rigid quantification (syntax level) *)
  "_RAll" :: "[idts, lift] \<Rightarrow> lift"                      ("(3\<forall>_./ _)" [0, 10] 10)
  "_REx"  :: "[idts, lift] \<Rightarrow> lift"                      ("(3\<exists>_./ _)" [0, 10] 10)
  "_REx1" :: "[idts, lift] \<Rightarrow> lift"                      ("(3\<exists>!_./ _)" [0, 10] 10)

translations
  "_const"        == "CONST const"
  "_lift"         == "CONST lift"
  "_lift2"        == "CONST lift2"
  "_lift3"        == "CONST lift3"
  "_Valid"        == "CONST Valid"
  "_RAll x A"     == "Rall x. A"
  "_REx x  A"     == "Rex x. A"
  "_REx1 x  A"    == "Rex! x. A"

  "w \<Turnstile> A"        => "A w"
  "LIFT A"        => "A::_\<Rightarrow>_"

  "_liftEqu"      == "_lift2 (=)"
  "_liftNeq u v"  == "_liftNot (_liftEqu u v)"
  "_liftNot"      == "_lift (CONST Not)"
  "_liftAnd"      == "_lift2 (\<and>)"
  "_liftOr"       == "_lift2 (\<or>)"
  "_liftImp"      == "_lift2 (\<longrightarrow>)"
  "_liftIf"       == "_lift3 (CONST If)"
  "_liftPlus"     == "_lift2 (+)"
  "_liftMinus"    == "_lift2 (-)"
  "_liftTimes"    == "_lift2 ((*))"
  "_liftDiv"      == "_lift2 (div)"
  "_liftMod"      == "_lift2 (mod)"
  "_liftLess"     == "_lift2 (<)"
  "_liftLeq"      == "_lift2 (\<le>)"
  "_liftMem"      == "_lift2 (\<in>)"
  "_liftNotMem x xs"   == "_liftNot (_liftMem x xs)"
  "_liftFinset (_liftargs x xs)"  == "_lift2 (CONST insert) x (_liftFinset xs)"
  "_liftFinset x" == "_lift2 (CONST insert) x (_const {})"
  "_liftPair x (_liftargs y z)"       == "_liftPair x (_liftPair y z)"
  "_liftPair"     == "_lift2 (CONST Pair)"
  "_liftCons"     == "CONST lift2 (CONST Cons)"
  "_liftApp"      == "CONST lift2 (@)"
  "_liftList (_liftargs x xs)"  == "_liftCons x (_liftList xs)"
  "_liftList x"   == "_liftCons x (_const [])"

  "w \<Turnstile> \<not>A"       <= "_liftNot A w"
  "w \<Turnstile> A \<and> B"    <= "_liftAnd A B w"
  "w \<Turnstile> A \<or> B"    <= "_liftOr A B w"
  "w \<Turnstile> A \<longrightarrow> B"  <= "_liftImp A B w"
  "w \<Turnstile> u = v"    <= "_liftEqu u v w"
  "w \<Turnstile> \<forall>x. A"   <= "_RAll x A w"
  "w \<Turnstile> \<exists>x. A"   <= "_REx x A w"
  "w \<Turnstile> \<exists>!x. A"  <= "_REx1 x A w"

subsection \<open>Lemmas and tactics for "intensional" logics.\<close>

lemmas intensional_rews [simp] =
  unl_con unl_lift unl_lift2 unl_lift3 unl_Rall unl_Rex unl_Rex1

lemma inteq_reflection: "\<turnstile> x=y  \<Longrightarrow>  (x==y)"
  apply (unfold Valid_def unl_lift2)
  apply (rule eq_reflection)
  apply (rule ext)
  apply (erule spec)
  done

lemma intI [intro!]: "(\<And>w. w \<Turnstile> A) \<Longrightarrow> \<turnstile> A"
  apply (unfold Valid_def)
  apply (rule allI)
  apply (erule meta_spec)
  done

lemma intD [dest]: "\<turnstile> A \<Longrightarrow> w \<Turnstile> A"
  apply (unfold Valid_def)
  apply (erule spec)
  done

(** Lift usual HOL simplifications to "intensional" level. **)

lemma int_simps:
  "\<turnstile> (x=x) = #True"
  "\<turnstile> (\<not>#True) = #False"  "\<turnstile> (\<not>#False) = #True"  "\<turnstile> (\<not>\<not> P) = P"
  "\<turnstile> ((\<not>P) = P) = #False"  "\<turnstile> (P = (\<not>P)) = #False"
  "\<turnstile> (P \<noteq> Q) = (P = (\<not>Q))"
  "\<turnstile> (#True=P) = P"  "\<turnstile> (P=#True) = P"
  "\<turnstile> (#True \<longrightarrow> P) = P"  "\<turnstile> (#False \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #True) = #True"  "\<turnstile> (P \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #False) = (\<not>P)"  "\<turnstile> (P \<longrightarrow> \<not>P) = (\<not>P)"
  "\<turnstile> (P \<and> #True) = P"  "\<turnstile> (#True \<and> P) = P"
  "\<turnstile> (P \<and> #False) = #False"  "\<turnstile> (#False \<and> P) = #False"
  "\<turnstile> (P \<and> P) = P"  "\<turnstile> (P \<and> \<not>P) = #False"  "\<turnstile> (\<not>P \<and> P) = #False"
  "\<turnstile> (P \<or> #True) = #True"  "\<turnstile> (#True \<or> P) = #True"
  "\<turnstile> (P \<or> #False) = P"  "\<turnstile> (#False \<or> P) = P"
  "\<turnstile> (P \<or> P) = P"  "\<turnstile> (P \<or> \<not>P) = #True"  "\<turnstile> (\<not>P \<or> P) = #True"
  "\<turnstile> (\<forall>x. P) = P"  "\<turnstile> (\<exists>x. P) = P"
  "\<turnstile> (\<not>Q \<longrightarrow> \<not>P) = (P \<longrightarrow> Q)"
  "\<turnstile> (P\<or>Q \<longrightarrow> R) = ((P\<longrightarrow>R)\<and>(Q\<longrightarrow>R))"
  apply (unfold Valid_def intensional_rews)
  apply blast+
  done

declare int_simps [THEN inteq_reflection, simp]

lemma TrueW [simp]: "\<turnstile> #True"
  by (simp add: Valid_def unl_con)

(* ======== Functions to "unlift" intensional implications into HOL rules ====== *)

ML \<open>
(* Basic unlifting introduces a parameter "w" and applies basic rewrites, e.g.
   \<turnstile> F = G    becomes   F w = G w
   \<turnstile> F \<longrightarrow> G  becomes   F w \<longrightarrow> G w
*)

fun int_unlift ctxt th =
  rewrite_rule ctxt @{thms intensional_rews} (th RS @{thm intD} handle THM _ => th);

(* Turn  \<turnstile> F = G  into meta-level rewrite rule  F == G *)
fun int_rewrite ctxt th =
  zero_var_indexes (rewrite_rule ctxt @{thms intensional_rews} (th RS @{thm inteq_reflection}))

(* flattening turns "\<longrightarrow>" into "\<Longrightarrow>" and eliminates conjunctions in the
   antecedent. For example,

         P & Q \<longrightarrow> (R | S \<longrightarrow> T)    becomes   \<lbrakk> P; Q; R | S \<rbrakk> \<Longrightarrow> T

   Flattening can be useful with "intensional" lemmas (after unlifting).
   Naive resolution with mp and conjI may run away because of higher-order
   unification, therefore the code is a little awkward.
*)
fun flatten t =
  let
    (* analogous to RS, but using matching instead of resolution *)
    fun matchres tha i thb =
      case Seq.chop 2 (Thm.biresolution NONE true [(false,tha)] i thb) of
          ([th],_) => th
        | ([],_)   => raise THM("matchres: no match", i, [tha,thb])
        |      _   => raise THM("matchres: multiple unifiers", i, [tha,thb])

    (* match tha with some premise of thb *)
    fun matchsome tha thb =
      let fun hmatch 0 = raise THM("matchsome: no match", 0, [tha,thb])
            | hmatch n = matchres tha n thb handle THM _ => hmatch (n-1)
      in hmatch (Thm.nprems_of thb) end

    fun hflatten t =
      case Thm.concl_of t of
        Const _ $ (Const (\<^const_name>\<open>HOL.implies\<close>, _) $ _ $ _) => hflatten (t RS mp)
      | _ => (hflatten (matchsome conjI t)) handle THM _ => zero_var_indexes t
  in
    hflatten t
  end

fun int_use ctxt th =
    case Thm.concl_of th of
      Const _ $ (Const (\<^const_name>\<open>Valid\<close>, _) $ _) =>
              (flatten (int_unlift ctxt th) handle THM _ => th)
    | _ => th
\<close>

attribute_setup int_unlift =
  \<open>Scan.succeed (Thm.rule_attribute [] (int_unlift o Context.proof_of))\<close>
attribute_setup int_rewrite =
  \<open>Scan.succeed (Thm.rule_attribute [] (int_rewrite o Context.proof_of))\<close>
attribute_setup flatten =
  \<open>Scan.succeed (Thm.rule_attribute [] (K flatten))\<close>
attribute_setup int_use =
  \<open>Scan.succeed (Thm.rule_attribute [] (int_use o Context.proof_of))\<close>

lemma Not_Rall: "\<turnstile> (\<not>(\<forall>x. F x)) = (\<exists>x. \<not>F x)"
  by (simp add: Valid_def)

lemma Not_Rex: "\<turnstile> (\<not> (\<exists>x. F x)) = (\<forall>x. \<not> F x)"
  by (simp add: Valid_def)

end