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

section "Dual Order"

theory Dual_Order
  imports Main
begin

subsection\<open>Interpretation of dual wellorder based on wellorder\<close>

lemma wf_wellorderI2:
  assumes wf: "wf {(x::'a::ord, y). y < x}"
  assumes lin: "class.linorder (\<lambda>(x::'a) y::'a. y \<le> x) (\<lambda>(x::'a) y::'a. y < x)"
  shows "class.wellorder (\<lambda>(x::'a) y::'a. y \<le> x) (\<lambda>(x::'a) y::'a. y < x)"
  using lin unfolding class.wellorder_def apply (rule conjI)
  apply (rule class.wellorder_axioms.intro) by (blast intro: wf_induct_rule [OF wf])

lemma (in preorder) tranclp_less': "(>)\<^sup>+\<^sup>+ = (>)"
  by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

interpretation dual_wellorder: wellorder "(\<ge>)::('a::{linorder, finite}=>'a=>bool)" "(>)"
proof (rule wf_wellorderI2)
  show "wf {(x :: 'a, y). y < x}"
    by(auto simp add: trancl_def tranclp_less' intro!: finite_acyclic_wf acyclicI)
  show "class.linorder (\<lambda>(x::'a) y::'a. y \<le> x) (\<lambda>(x::'a) y::'a. y < x)"
    unfolding class.linorder_def unfolding class.linorder_axioms_def unfolding class.order_def
    unfolding class.preorder_def unfolding class.order_axioms_def by auto
qed

subsection\<open>Properties of the Greatest operator\<close>

lemma dual_wellorder_Least_eq_Greatest[simp]: "dual_wellorder.Least = Greatest"
  by (auto simp add: Greatest_def dual_wellorder.Least_def)

lemmas GreatestI = dual_wellorder.LeastI[unfolded dual_wellorder_Least_eq_Greatest]
lemmas GreatestI2_ex = dual_wellorder.LeastI2_ex[unfolded dual_wellorder_Least_eq_Greatest]
lemmas GreatestI2_wellorder = dual_wellorder.LeastI2_wellorder[unfolded dual_wellorder_Least_eq_Greatest]
lemmas GreatestI_ex = dual_wellorder.LeastI_ex[unfolded dual_wellorder_Least_eq_Greatest]
lemmas not_greater_Greatest = dual_wellorder.not_less_Least[unfolded dual_wellorder_Least_eq_Greatest]
lemmas GreatestI2 = dual_wellorder.LeastI2[unfolded dual_wellorder_Least_eq_Greatest]
lemmas Greatest_ge = dual_wellorder.Least_le[unfolded dual_wellorder_Least_eq_Greatest]

end


theory relativization
  imports properties
begin

(**When working with closure operators the notion of relativization plays
an analogous role to that of a subspace.*)

(**We can relativize a closure operator wrt. a subset S of its carrier (implicitly given as 'a-type domain)*)
definition relativization::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> 'w \<sigma> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("_\<downharpoonleft>\<^sub>_")
  where "\<C>\<downharpoonleft>\<^sub>S \<equiv> \<lambda>A. S \<^bold>\<and> \<C> A"

(**Kuratowski conditions (like additivity, normality, idempotence, etc)
 can be relativized wrt. to a given subset S of the space.*)

definition ADDI_rel::"'w \<sigma> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ADDI\<downharpoonleft>\<^sub>_")
  where "ADDI\<downharpoonleft>\<^sub>S \<phi> \<equiv> \<forall>A B. S \<^bold>\<and> \<phi>(A \<^bold>\<or> B) \<approx> (S \<^bold>\<and> \<phi> A) \<^bold>\<or> (S \<^bold>\<and> \<phi> B)"
definition EXPN_rel::"'w \<sigma> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("EXPN\<downharpoonleft>\<^sub>_")
  where "EXPN\<downharpoonleft>\<^sub>S \<phi>  \<equiv> \<forall>A. S \<^bold>\<and> A \<preceq> S \<^bold>\<and> \<phi> A"
definition NORM_rel::"'w \<sigma> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("NORM\<downharpoonleft>\<^sub>_")
  where "NORM\<downharpoonleft>\<^sub>S \<phi>  \<equiv> S \<^bold>\<and> (\<phi> \<^bold>\<bottom>) \<approx> S \<^bold>\<and> \<^bold>\<bottom>"
definition IDEM_rel::"'w \<sigma> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("IDEM\<downharpoonleft>\<^sub>_")
  where "IDEM\<downharpoonleft>\<^sub>S \<phi>  \<equiv> \<forall>A. S \<^bold>\<and> (\<phi> A) \<approx> S \<^bold>\<and> \<phi>(S \<^bold>\<and> \<phi> A)"

abbreviation Cl_1_rel ("Cl'_1\<downharpoonleft>\<^sub>_") where "Cl_1\<downharpoonleft>\<^sub>S \<phi> \<equiv> (ADDI\<downharpoonleft>\<^sub>S) \<phi>"
abbreviation Cl_2_rel ("Cl'_2\<downharpoonleft>\<^sub>_") where "Cl_2\<downharpoonleft>\<^sub>S \<phi> \<equiv> (EXPN\<downharpoonleft>\<^sub>S) \<phi>"
abbreviation Cl_3_rel ("Cl'_3\<downharpoonleft>\<^sub>_") where "Cl_3\<downharpoonleft>\<^sub>S \<phi> \<equiv> (NORM\<downharpoonleft>\<^sub>S) \<phi>"
abbreviation Cl_4_rel ("Cl'_4\<downharpoonleft>\<^sub>_") where "Cl_4\<downharpoonleft>\<^sub>S \<phi> \<equiv> (IDEM\<downharpoonleft>\<^sub>S) \<phi>"

(**We show that relativized closure operators satisfy the relativized Kuratowski conditions*)
lemma "Cl_1 \<C> \<longrightarrow> Cl_1\<downharpoonleft>\<^sub>S \<C>\<downharpoonleft>\<^sub>S" by (simp add: ADDI_def ADDI_rel_def BA_distr1 relativization_def setequ_equ)
lemma "Cl_2 \<C> \<longrightarrow> Cl_2\<downharpoonleft>\<^sub>S \<C>\<downharpoonleft>\<^sub>S" by (metis (mono_tags, lifting) EXPN_def EXPN_rel_def L12 L2 L4 relativization_def)
lemma "Cl_3 \<C> \<longrightarrow> Cl_3\<downharpoonleft>\<^sub>S \<C>\<downharpoonleft>\<^sub>S" by (metis L14 L5 NORM_def NORM_rel_def relativization_def setequ_equ)
lemma "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4 \<C> \<longrightarrow> Cl_4\<downharpoonleft>\<^sub>S \<C>\<downharpoonleft>\<^sub>S" unfolding MONO_def EXPN_def IDEM_rel_def IDEM_def by (smt (verit, best) L10 L12 L3 L4 L5 antisymmetric_def reflexive_def relativization_def setequ_equ subset_antisymmetric subset_reflexive)

(**We need to be careful when defining the dual interior operator for relativised closures,*)
abbreviation Int_cl_rel ("\<I>\<downharpoonleft>\<^sub>_[_]") where "\<I>\<downharpoonleft>\<^sub>S[\<C>] \<equiv> \<lambda>X. S \<^bold>\<leftharpoonup> \<C>(S \<^bold>\<leftharpoonup> X)"
(*and also when defining the notions of closed/open sets.*)
abbreviation closedset_rel ("Cl\<downharpoonleft>\<^sub>_[_]") where "Cl\<downharpoonleft>\<^sub>S[\<C>] \<equiv> Cl[\<C>\<downharpoonleft>\<^sub>S]"
abbreviation openset_rel ("Op\<downharpoonleft>\<^sub>_[_]") where "Op\<downharpoonleft>\<^sub>S[\<C>] \<equiv> fp \<I>\<downharpoonleft>\<^sub>S[\<C>]"

(**A necessary and sufficient condition for a set to be closed relative to S
is that it is to be the intersection of S and of a closed set.*) (*exercise: verify for opens*)
lemma aux1: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> \<forall>A. (\<exists>E. Cl[\<C>] E \<and> A \<approx> S \<^bold>\<and> E) \<longrightarrow> Cl\<downharpoonleft>\<^sub>S[\<C>] A" unfolding fixpoint_pred_def relativization_def by (metis EXPN_def L12 L3 L4 L5 L8 MONO_def setequ_def setequ_equ)
lemma aux2: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl\<downharpoonleft>\<^sub>S[\<C>] A \<longrightarrow> (\<exists>E. Cl[\<C>] E \<and> A \<approx> S \<^bold>\<and> E)" unfolding fixpoint_pred_def relativization_def by (metis IDEM_def setequ_equ)
lemma "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl\<downharpoonleft>\<^sub>S[\<C>] A \<longleftrightarrow> (\<exists>E. Cl[\<C>] E \<and> A \<approx> S \<^bold>\<and> E)"
  using aux1 aux2 by blast

(*In particular, if S is closed, then the property of being closed relative to S
 implies the same property in the absolute sense.*)  (*exercise: verify for opens*)
lemma "MONO \<C> \<Longrightarrow> Cl[\<C>] S \<longrightarrow> Cl\<downharpoonleft>\<^sub>S[\<C>] \<sqsubseteq> Cl[\<C>]" by (metis (full_types) L10 L4 MONO_def fixpoint_pred_def relativization_def setequ_equ)

(*Being relatively closed is transitive: if A is closed in B and B is closed in C
 then A is closed in C (same for open)*) (*exercise: verify for opens*)
lemma "MONO \<C> \<Longrightarrow> \<forall>A B C. Cl\<downharpoonleft>\<^sub>B[\<C>] A \<and> Cl\<downharpoonleft>\<^sub>C[\<C>] B \<longrightarrow> Cl\<downharpoonleft>\<^sub>C[\<C>] A"
  unfolding relativization_def by (smt (z3) L10 MONO_def fixpoint_pred_def meet_def setequ_char setequ_equ)

(**Above we have seen that the Kuratowski axioms can be relativized wrt. an arbitrary subset S of the space.
Consequently the same applies to the theorems which follow from these axioms; they remain valid if
one considers an arbitrary subspace S and the closure is relativized wrt. S as shown above. Exercise: prove some. *)

(**Many topological properties are preserved when relativizing (dense, nowhere-dense, etc). Exercise: prove some*)

end


theory Solers
imports Main
begin

(* Solèr's theorem *)
(* Baby steps in an attempt to just state it in Isabelle *)

theorem (in division_ring) solers:
  shows "1 + 1 = 2"
proof -
  show ?thesis by(auto)
qed

(* From https://www.inf.ed.ac.uk/teaching/courses/ar/tutorials/1/tut1.pdf *)
(* Or from https://www.inf.ed.ac.uk/teaching/courses/ar//isabelle/Prop.thy *)

(* 1 - suspect by(auto) isn't quite in the spirit of the assignment *)

theorem
  shows "(P --> (Q --> R)) --> ((P --> Q) --> (P --> R))"
  by(auto)

(* 1 - slightly more manual style *)

theorem "(P --> (Q --> R)) --> ((P --> Q) --> (P --> R))"
apply (auto)
done

(* 1 - more manual style and I suspect in the spirit of the question *)
(* although some of it was trial and error... *)

theorem "(P --> (Q --> R)) --> ((P --> Q) --> (P --> R))"
apply (rule impI)
apply (rule impI)
apply (rule impI)
apply (erule impE)
apply (assumption)
apply (erule impE)
apply (assumption)
apply (erule impE)
apply (assumption)
apply (assumption)
done

(* 2 *)

theorem "\<not> \<not> P --> P"
apply (rule impI)
apply (rule ccontr)
apply (erule notE)
apply (assumption)
done

(* Attempts to build up to do the above exercises *)

theorem "\<not> P \<or> P"
apply (rule excluded_middle)
done

theorem "\<not> (A \<and> B) \<or> (A \<and> B)"
apply (rule excluded_middle)
done

theorem "P --> P"
apply (rule impI)
apply (assumption)
done

theorem "A --> (B --> A)"
apply (rule impI)
apply (rule impI)
apply (assumption)
done

theorem "\<lbrakk> P;Q \<rbrakk> \<Longrightarrow> P \<and> (Q \<and> P)"
apply (rule conjI)
apply (assumption)
apply (rule conjI)
apply (assumption)
apply (assumption)
done

theorem "\<lbrakk> A \<or> B \<rbrakk> \<Longrightarrow> B \<or> A"
apply (rule disjE)
apply (assumption) (* Still not completely sure how this works *)
apply (rule disjI2)
apply (assumption)
apply (rule disjI1)
apply (assumption)
done

(* Converting the proof from https://www.inf.ed.ac.uk/teaching/courses/ar//slides03.pdf *)
theorem "((S \<or> R) \<and> \<not> S) \<longrightarrow> R"
apply (rule impI)
apply (rule disjE)
apply (rule conjunct1)
apply (assumption)
apply (rule notE)
apply (rule conjunct2)
apply (assumption)
apply (assumption)
apply (assumption)
done

theorem "\<lbrakk> A;B;C;D;E;F \<rbrakk> \<Longrightarrow> A"
apply (assumption)
done

(* Attempt at converting the proof at https://www.youtube.com/watch?v=lLJORsLwN3k in very low level way *)
theorem "A \<and> (B \<and> C) \<Longrightarrow> (A \<and> B) \<and> C"
apply (rule conjI)
apply (rule conjI)
apply (rule conjunct1)
apply (assumption)
apply (rule conjunct1)
apply (rule conjunct2)
apply (assumption)
apply (rule conjunct2)
apply (rule conjunct2)
apply (assumption)
done

theorem "\<lbrakk> A;\<not> A \<rbrakk> \<Longrightarrow> R"
apply (erule notE)
apply (assumption)
done

(* Random bits and bobs *)

theorem
  shows "1 + 1 = 2"
proof -
  show ?thesis by(auto)
qed

theorem
  assumes "A \<and> B"
  shows "B \<and> A"
proof -
  from `A \<and> B` have "B" ..
  moreover
  from `A \<and> B` have "A" ..
  ultimately show "B \<and> A" ..
qed

theorem
  assumes Pf: "\<exists> x. P(f x)"
  shows "\<exists> y. P(y)"
proof -
  from Pf obtain x where "P(f x)" ..
  thus "\<exists> y. P y" ..
qed

theorem
  shows "\<not> A \<or> A"
proof (cases "A")
  case True thus ?thesis ..
next
  case False thus ?thesis ..
qed

end


theory Rewrite_Examples
imports Main "~~/src/HOL/Library/Rewrite"
begin

section \<open>The rewrite Proof Method by Example\<close>

(* This file is intended to give an overview over
   the features of the pattern-based rewrite proof method.

   See also https://www21.in.tum.de/~noschinl/Pattern-2014/
*)
lemma
  fixes a::int and b::int and c::int
  assumes "P (b + a)"
  shows "P (a + b)"
by (rewrite at "a + b" add.commute)
   (rule assms)

(* Selecting a specific subterm in a large, ambiguous term. *)
lemma
  fixes a b c :: int
  assumes "f (a - a + (a - a)) + f (   0    + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f _ + f \<hole> = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite at "f (_ + \<hole>) + f _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (  0   + (a - a)) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (\<hole> + _) + _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (_ + \<hole>) + _ = _" diff_self) fact

lemma
  fixes x y :: nat
  shows"x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" add.commute) assumption

(* We can also rewrite in the assumptions.  *)
lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in "x + y > c" at asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" at asm  add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "x+1" in "{x::int. \<hole> }" add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "any_identifier_will_work+1" in "{any_identifier_will_work::int. \<hole> }" add.commute)
   fact

lemma
  assumes "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. s * t + y - 3)}"
  shows   "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. y + s * t - 3)}"
  by (rewrite at "b + d * e" in "\<lambda>(a, b, c). _ = Q (\<lambda>d e. \<hole>)" add.commute) fact

(* This is not limited to the first assumption *)
lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

(* Rewriting "at asm" selects each full assumption, not any parts *)
lemma
  assumes "(PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP S \<Longrightarrow> PROP R)"
  shows "PROP S \<Longrightarrow> (PROP P \<Longrightarrow> PROP Q) \<Longrightarrow> PROP R"
  apply (rewrite at asm assms)
  apply assumption
  done

(* Rewriting with conditional rewriting rules works just as well. *)
lemma test_theorem:
  fixes x :: nat
  shows "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"
  by (rule Orderings.order_antisym)

(* Premises of the conditional rule yield new subgoals. The
   assumptions of the goal are propagated into these subgoals
*)
lemma
  fixes f :: "nat \<Rightarrow> nat"
  shows "f x \<le> 0 \<Longrightarrow> f x \<ge> 0 \<Longrightarrow> f x = 0"
  apply (rewrite at "f x" to "0" test_theorem)
  apply assumption
  apply assumption
  apply (rule refl)
  done

(* This holds also for rewriting in assumptions. The order of assumptions is preserved *)
lemma
  assumes rewr: "PROP P \<Longrightarrow> PROP Q \<Longrightarrow> PROP R \<equiv> PROP R'"
  assumes A1: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP P"
  assumes A2: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP Q"
  assumes C: "PROP S \<Longrightarrow> PROP R' \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  shows "PROP S \<Longrightarrow> PROP R \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  apply (rewrite at asm rewr)
  apply (fact A1)
  apply (fact A2)
  apply (fact C)
  done

(*
   Instantiation.

   Since all rewriting is now done via conversions,
   instantiation becomes fairly easy to do.
*)

(* We first introduce a function f and an extended
   version of f that is annotated with an invariant. *)
fun f :: "nat \<Rightarrow> nat" where "f n = n"
definition "f_inv (I :: nat \<Rightarrow> bool) n \<equiv> f n"

lemma annotate_f: "f = f_inv I"
  by (simp add: f_inv_def fun_eq_iff)

(* We have a lemma with a bound variable n, and
   want to add an invariant to f. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>_. True) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite to "f_inv (\<lambda>_. True)" annotate_f) fact

(* We can also add an invariant that contains the variable n bound in the outer context.
   For this, we need to bind this variable to an identifier. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>n. \<hole>" to "f_inv (\<lambda>x. n < x + 1)" annotate_f) fact

(* Any identifier will work *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>abc. \<hole>" to "f_inv (\<lambda>x. abc < x + 1)" annotate_f) fact

(* The "for" keyword. *)
lemma
  assumes "P (2 + 1)"
  shows "\<And>x y. P (1 + 2 :: nat)"
by (rewrite in "P (1 + 2)" at for (x) add.commute) fact

lemma
  assumes "\<And>x y. P (y + x)"
  shows "\<And>x y. P (x + y :: nat)"
by (rewrite in "P (x + _)" at for (x y) add.commute) fact

lemma
  assumes "\<And>x y z. y + x + z = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "x + y" in "x + y + z" in for (x y z) add.commute) fact

lemma
  assumes "\<And>x y z. z + (x + y) = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "(_ + y) + z" in for (y z) add.commute) fact

lemma
  assumes "\<And>x y z. x + y + z = y + z + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "\<hole> + _" at "_ = \<hole>" in for () add.commute) fact

lemma
  assumes eq: "\<And>x. P x \<Longrightarrow> g x = x"
  assumes f1: "\<And>x. Q x \<Longrightarrow> P x"
  assumes f2: "\<And>x. Q x \<Longrightarrow> x"
  shows "\<And>x. Q x \<Longrightarrow> g x"
  apply (rewrite at "g x" in for (x) eq)
  apply (fact f1)
  apply (fact f2)
  done

(* The for keyword can be used anywhere in the pattern where there is an \<And>-Quantifier. *)
lemma
  assumes "(\<And>(x::int). x < 1 + x)"
  and     "(x::int) + 1 > x"
  shows   "(\<And>(x::int). x + 1 > x) \<Longrightarrow> (x::int) + 1 > x"
by (rewrite at "x + 1" in for (x) at asm add.commute)
   (rule assms)

(* The rewrite method also has an ML interface *)
lemma
  assumes "\<And>a b. P ((a + 1) * (1 + b)) "
  shows "\<And>a b :: nat. P ((a + 1) * (b + 1))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" @{context}
      (* Note that the pattern order is reversed *)
      val pat = [
        Rewrite.For [(x, SOME @{typ nat})],
        Rewrite.In,
        Rewrite.Term (@{const plus(nat)} $ Free (x, @{typ nat}) $ @{term "1 :: nat"}, [])]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

lemma
  assumes "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. a + b))"
  shows "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" @{context}
      val pat = [
        Rewrite.Concl,
        Rewrite.In,
        Rewrite.Term (Free ("Q", (@{typ "int"} --> TVar (("'b",0), [])) --> @{typ bool})
          $ Abs ("x", @{typ int}, Rewrite.mk_hole 1 (@{typ int} --> TVar (("'b",0), [])) $ Bound 0), [(x, @{typ int})]),
        Rewrite.In,
        Rewrite.Term (@{const plus(int)} $ Free (x, @{typ int}) $ Var (("c", 0), @{typ int}), [])
        ]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

(* There is also conversion-like rewrite function: *)
ML \<open>
  val ct = @{cprop "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))"}
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" @{context}
  val pat = [
    Rewrite.Concl,
    Rewrite.In,
    Rewrite.Term (Free ("Q", (@{typ "int"} --> TVar (("'b",0), [])) --> @{typ bool})
      $ Abs ("x", @{typ int}, Rewrite.mk_hole 1 (@{typ int} --> TVar (("'b",0), [])) $ Bound 0), [(x, @{typ int})]),
    Rewrite.In,
    Rewrite.Term (@{const plus(int)} $ Free (x, @{typ int}) $ Var (("c", 0), @{typ int}), [])
    ]
  val to = NONE
  val th = Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute} ct
\<close>

section \<open>Regression tests\<close>

ML \<open>
  val ct = @{cterm "(\<lambda>b :: int. (\<lambda>a. b + a))"}
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" @{context}
  val pat = [
    Rewrite.In,
    Rewrite.Term (@{const plus(int)} $ Var (("c", 0), @{typ int}) $ Var (("c", 0), @{typ int}), [])
    ]
  val to = NONE
  val _ =
    case try (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) ct of
      NONE => ()
    | _ => error "should not have matched anything"
\<close>

ML \<open>
  Rewrite.params_pconv (Conv.all_conv |> K |> K) @{context} (Vartab.empty, []) @{cterm "\<And>x. PROP A"}
\<close>

lemma
  assumes eq: "PROP A \<Longrightarrow> PROP B \<equiv> PROP C"
  assumes f1: "PROP D \<Longrightarrow> PROP A"
  assumes f2: "PROP D \<Longrightarrow> PROP C"
  shows "\<And>x. PROP D \<Longrightarrow> PROP B"
  apply (rewrite eq)
  apply (fact f1)
  apply (fact f2)
  done

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

header {* Framework Instantiations using Marked Regular Expressions *}

(*<*)
theory Position_Autos
imports
  Automaton
  "~~/src/Tools/Permanent_Interpretation"
begin
(*>*)

subsection {* Marked Regular Expressions *}

type_synonym 'a mrexp = "(bool * 'a) rexp"

abbreviation "strip \<equiv> map_rexp snd"

primrec mrexps :: "'a rexp \<Rightarrow> ('a mrexp) set" where
  "mrexps Zero = {Zero}"
| "mrexps One = {One}"
| "mrexps (Atom a) = {Atom (True, a), Atom (False, a)}"
| "mrexps (Plus r s) = split Plus ` (mrexps r \<times> mrexps s)"
| "mrexps (Times r s) = split Times ` (mrexps r \<times> mrexps s)"
| "mrexps (Star r) = Star ` mrexps r"

lemma finite_mrexps[simp]: "finite (mrexps r)"
by (induction r) auto

lemma strip_mrexps: "strip ` mrexps r = {r}"
by (induction r) (auto simp: set_eq_subset subset_iff image_iff)

fun Lm :: "'a mrexp \<Rightarrow> 'a lang" where
"Lm Zero = {}" |
"Lm One = {}" |
"Lm (Atom(m,a)) = (if m then {[a]} else {})" |
"Lm (Plus r s) = Lm r \<union> Lm s" |
"Lm (Times r s) = Lm r @@ lang(strip s) \<union> Lm s" |
"Lm (Star r) = Lm r @@ star(lang(strip r))"

fun final :: "'a mrexp \<Rightarrow> bool" where
"final Zero = False" |
"final One = False" |
"final (Atom(m,a)) = m" |
"final (Plus r s) = (final r \<or> final s)" |
"final (Times r s) = (final s \<or> nullable s \<and> final r)" |
"final (Star r) = final r"

abbreviation read :: "'a \<Rightarrow> 'a mrexp \<Rightarrow> 'a mrexp" where
"read a \<equiv> map_rexp (\<lambda>(m,x). (m \<and> a=x, x))"

lemma read_mrexps[simp]: "r \<in> mrexps s \<Longrightarrow> read a r \<in> mrexps s"
by (induction s arbitrary: a r) (auto simp: image_iff)

fun follow :: "bool \<Rightarrow> 'a mrexp \<Rightarrow> 'a mrexp" where
"follow m Zero = Zero" |
"follow m One = One" |
"follow m (Atom(_,a)) = Atom(m,a)" |
"follow m (Plus r s) = Plus (follow m r) (follow m s)" |
"follow m (Times r s) =
  Times (follow m r) (follow (final r \<or> m \<and> nullable r) s)" |
"follow m (Star r) = Star(follow (final r \<or> m) r)"

lemma follow_mrexps[simp]: "r \<in> mrexps s \<Longrightarrow> follow b r \<in> mrexps s"
by (induction s arbitrary: b r) (auto simp: image_iff)

lemma strip_read[simp]: "strip (read a r) = strip r"
by (simp add: map_map_rexp split_def)

lemma Nil_notin_Lm[simp]: "[] \<notin> Lm r"
by (induction r) (auto split: if_splits)

lemma Nil_in_lang_strip[simp]: "[] \<in> lang(r) \<longleftrightarrow> [] \<in> lang(strip r)"
by (induction r) auto

lemma strip_follow[simp]: "strip(follow m r) = strip r"
by (induction r arbitrary: m) (auto split: if_splits)

lemma conc_lemma: "[] \<notin> A \<Longrightarrow> {w : A @@ B. w \<noteq> [] \<and> P(hd w)} = {w : A. w \<noteq> [] \<and> P(hd w)} @@ B"
  unfolding conc_def by auto (metis hd_append2)+

lemma Lm_read: "Lm (read a r) = {w : Lm r. w \<noteq> [] \<and> hd w = a}"
proof (induction r)
  case (Times r1 r2) thus ?case
    using conc_lemma[OF Nil_notin_Lm, where P = "\<lambda>x. x=a" and r1 = r1] by auto
next
  case Star thus ?case using conc_lemma[OF Nil_notin_Lm, where P = "\<lambda>x. x=a"] by simp
qed (auto split: if_splits)

lemma tl_conc[simp]: "[] \<notin> A \<Longrightarrow>tl ` (A @@ B) = tl ` A @@ B"
by (fastforce simp: image_def Bex_def tl_append split: list.split)

lemma Nil_in_tl_Lm_if_final[simp]: "final r \<Longrightarrow> [] : tl ` Lm r"
by (induction r) (auto simp: nullable_iff image_Un)

lemma Nil_notin_tl_if_not_final: "\<not> final r \<Longrightarrow> [] \<notin> tl ` Lm r"
by (induction r) (auto simp: nullable_iff Nil_tl singleton_in_conc intro!: image_eqI[rotated])

lemma Lm_follow: "Lm (follow m r) = tl ` Lm r \<union> (if m then lang(strip r) else {}) - {[]}"
proof (induction r arbitrary: m)
  case (Atom mb) thus ?case by (cases mb) auto
next
  case (Times r s) thus ?case
    by (simp add: Un_Diff image_Un conc_Un_distrib nullable_iff
          conc_Diff_if_Nil1 Nil_notin_tl_if_not_final Un_ac)
next
  case (Star r) thus ?case
    by (simp add: Un_Diff conc_Un_distrib
          conc_Diff_if_Nil1 Nil_notin_tl_if_not_final star_Diff_Nil_fold)
qed auto

subsection {* Mark Before Atom *}

text{* Position automaton where mark is placed before atoms. *}

abbreviation "empty_mrexp \<equiv> map_rexp (\<lambda>a. (False,a))"

lemma empty_mrexp_mrexps[simp]: "empty_mrexp r \<in> mrexps r"
by (induction r) auto

lemma nullable_empty_mrexp[simp]: "nullable (empty_mrexp r) = nullable r"
  by (induct r) auto

definition "init_b r = (follow True (empty_mrexp r), nullable r)"

lemma init_b_mrexps[simp]: "init_b r \<in> mrexps r \<times> UNIV"
  unfolding init_b_def by auto

fun delta_b where
"delta_b a (r,b) = (let r' = read a r in (follow False r', final r'))"

lemma delta_b_mrexps[simp]: "rb \<in> mrexps r \<times> UNIV \<Longrightarrow> delta_b a rb \<in> mrexps r \<times> UNIV"
by (auto simp: Let_def)

lemma fold_delta_b_init_b_mrexps[simp]: "fold delta_b w (init_b s) \<in> mrexps s \<times> UNIV"
by (induction w arbitrary: s rule: rev_induct) auto

fun L_b where
"L_b (r,b) = Lm r \<union> (if b then {[]} else {})"

abbreviation "final_b \<equiv> snd"

lemma Lm_empty: "Lm (empty_mrexp r) = {}"
by (induction r) auto

lemma final_read_Lm: "final(read a r) \<longleftrightarrow> [a] \<in> Lm r"
by (induction r) (auto simp: nullable_iff concI_if_Nil2 singleton_in_conc split: if_splits)

permanent_interpretation before: rexp_DFA init_b delta_b final_b L_b
  defining before_closure = "rexp_DA.closure delta_b (final_b ::  (bool \<times> 'a) rexp \<times> bool \<Rightarrow> bool)"
    and check_eqv_b = "rexp_DA.check_eqv init_b delta_b (final_b ::  (bool \<times> 'a) rexp \<times> bool \<Rightarrow> bool)"
    and reachable_b = "rexp_DA.reachable (init_b :: 'a rexp \<Rightarrow> (bool \<times> 'a) rexp \<times> bool) delta_b"
    and automaton_b = "rexp_DA.automaton (init_b :: 'a rexp \<Rightarrow> (bool \<times> 'a) rexp \<times> bool) delta_b"
    and match_b = "rexp_DA.match (init_b :: 'a rexp \<Rightarrow> (bool \<times> 'a) rexp \<times> bool) delta_b final_b"
proof
  case goal1 show "L_b (init_b r) = lang r"
    by(auto simp add: init_b_def Lm_follow Lm_empty map_map_rexp nullable_iff)
next
  case (goal2 a rb) show "L_b (delta_b a rb) = Deriv a (L_b rb)"
    by (cases rb) (auto simp add: Deriv_def final_read_Lm image_def Lm_read Lm_follow)
next
  case (goal3 rb) show  "final_b rb \<longleftrightarrow> [] \<in> L_b rb" by (cases rb) simp
next
  case goal4
  have "{fold delta_b w (init_b s) |w. True} \<subseteq> mrexps s \<times> UNIV"
    by (intro subsetI, elim CollectE exE) (simp only: fold_delta_b_init_b_mrexps)
  then show "finite {fold delta_b w (init_b s) |w. True}" by (rule finite_subset) simp
qed

subsection {* Mark After Atom *}

text{* Position automaton where mark is placed after atoms. This is the
Glushkov and McNaughton/Yamada construction. *}

definition "init_a r = (True, empty_mrexp r)"

lemma init_a_mrexps[simp]: "init_a r \<in> UNIV \<times> mrexps r"
  unfolding init_a_def by auto

fun delta_a where
"delta_a a (b,r) = (False, read a (follow b r))"

lemma delta_a_mrexps[simp]: "br \<in> UNIV \<times> mrexps r \<Longrightarrow> delta_a a br \<in> UNIV \<times> mrexps r"
by auto

lemma fold_delta_a_init_a_mrexps[simp]: "fold delta_a w (init_a s) \<in> UNIV \<times> mrexps s"
by (induction w arbitrary: s rule: rev_induct) auto

fun final_a where
"final_a (b,r) \<longleftrightarrow> final r \<or> b \<and> nullable r"

fun L_a where
"L_a (b,r) = Lm (follow b r) \<union> (if final_a(b,r)  then {[]} else {})"

lemma nonfinal_empty_mrexp: "\<not> final (empty_mrexp r)"
by (induction r) auto

lemma Cons_eq_tl_iff[simp]: "x # xs = tl ys \<longleftrightarrow> (\<exists>y. ys = y # x # xs)"
by (cases ys) auto

lemma tl_eq_Cons_iff[simp]: "tl ys = x # xs \<longleftrightarrow> (\<exists>y. ys = y # x # xs)"
by (cases ys) auto

permanent_interpretation after: rexp_DFA init_a delta_a final_a L_a
  defining after_closure = "rexp_DA.closure delta_a (final_a ::  bool \<times> (bool \<times> 'a) rexp \<Rightarrow> bool)"
    and check_eqv_a = "rexp_DA.check_eqv init_a delta_a (final_a ::  bool \<times> (bool \<times> 'a) rexp \<Rightarrow> bool)"
    and reachable_a = "rexp_DA.reachable (init_a :: 'a rexp \<Rightarrow> bool \<times> (bool \<times> 'a) rexp) delta_a"
    and automaton_a = "rexp_DA.automaton (init_a :: 'a rexp \<Rightarrow> bool \<times> (bool \<times> 'a) rexp) delta_a"
    and match_a = "rexp_DA.match (init_a :: 'a rexp \<Rightarrow> bool \<times> (bool \<times> 'a) rexp) delta_a final_a"
proof
  case goal1 show "L_a (init_a r) = lang r"
    by (auto simp: init_a_def nonfinal_empty_mrexp Lm_follow Lm_empty map_map_rexp nullable_iff)
next
  case (goal2 a br) show "L_a (delta_a a br) = Deriv a (L_a br)"
    by (cases br) (simp add: Deriv_def final_read_Lm Lm_read Lm_follow,
      fastforce simp: image_def neq_Nil_conv)
next
  case (goal3 br) show  "final_a br \<longleftrightarrow> [] \<in> L_a br" by (cases br) simp
next
  case goal4
  have "{fold delta_a w (init_a s) |w. True} \<subseteq> UNIV \<times> mrexps s"
    by (intro subsetI, elim CollectE exE) (simp only: fold_delta_a_init_a_mrexps)
  then show "finite {fold delta_a w (init_a s) |w. True}" by (rule finite_subset) simp
qed

text {*
The ``before'' atomaton is a quotient of the ``after'' automaton.

The proof below follows an informal proof given by Helmut Seidl in personal communication.
*}

fun hom_ab where
  "hom_ab (b, r) = (follow b r, final_a (b, r))"

lemma hom_delta: "hom_ab (delta_a x br) = delta_b x (hom_ab br)"
by(cases br) (auto simp add: Let_def)

lemma hom_deltas: "hom_ab (fold delta_a w br) = fold delta_b w (hom_ab br)"
  by (induct w arbitrary: br) (auto simp add: hom_delta)

lemma hom_init: "hom_ab (init_a r) = init_b r"
  unfolding init_a_def init_b_def hom_ab.simps by (simp add: nonfinal_empty_mrexp)

lemma reachable_ab: "reachable_b as r = hom_ab ` reachable_a as r"
  unfolding after.reachable before.reachable by (force simp: hom_init hom_deltas)

theorem card_reachable_ab: "card (reachable_b as r) \<le> card (reachable_a as r)"
  unfolding reachable_ab using after.finite_reachable by (rule card_image_le)

text{* The implementation by Fischer et al.: *}

(* better: shift b m r and move m b r *)
fun shift :: "bool \<Rightarrow> 'a mrexp \<Rightarrow> 'a \<Rightarrow> 'a mrexp" where
"shift _ One _ = One" |
"shift _ Zero _ = Zero" |
"shift m (Atom (_,x)) c = Atom (m \<and> (x=c),x)" |
"shift m (Plus r s) c = Plus (shift m r c) (shift m s c)" |
"shift m (Times r s) c =
  Times (shift m r c) (shift (final r \<or> m \<and> nullable r) s c)" |
"shift m (Star r) c = Star (shift (final r \<or> m) r c)"

lemma shift_read_follow: "shift m r x = read x (follow m r)"
by (induction m r x rule: shift.induct) auto

text{* In the spirit of Asperti, and similarly quadratic because of need
to call final1 in move. *}

fun final1 :: "'a mrexp \<Rightarrow> 'a \<Rightarrow> bool" where
"final1 Zero _ = False" |
"final1 One _ = False" |
"final1 (Atom(m,a)) x = (m \<and> a=x)" |
"final1 (Plus r s) x = (final1 r x \<or> final1 s x)" |
"final1 (Times r s) x = (final1 s x \<or> nullable s \<and> final1 r x)" |
"final1 (Star r) x = final1 r x"

fun move :: "'a \<Rightarrow> 'a mrexp \<Rightarrow> bool \<Rightarrow> 'a mrexp" where
"move _ One _ = One" |
"move _ Zero _ = Zero" |
"move c (Atom (_,a)) m = Atom (m, a)" |
"move c (Plus r s) m = Plus (move c r m) (move c s m)" |
"move c (Times r s) m =
  Times (move c r m) (move c s (final1 r c \<or> m \<and> nullable r))" |
"move c (Star r) m = Star (move c r (final1 r c \<or> m))"

lemma nullable_read[simp]: "nullable (read c r) = nullable r"
by (induction r) auto

lemma final_read_final1: "final (read c r) = final1 r c"
by (induction r) auto

lemma move_follow_read: "move c r m = follow m (read c r)"
by (induction c r m rule: move.induct) (auto simp: final_read_final1)

(*<*)
end
(*>*)


section \<open> Unrestriction \<close>

theory utp_unrest
  imports utp_expr_insts
begin

subsection \<open> Definitions and Core Syntax \<close>

text \<open> Unrestriction is an encoding of semantic freshness that allows us to reason about the
  presence of variables in predicates without being concerned with abstract syntax trees.
  An expression $p$ is unrestricted by lens $x$, written $x \mathop{\sharp} p$, if
  altering the value of $x$ has no effect on the valuation of $p$. This is a sufficient
  notion to prove many laws that would ordinarily rely on an \emph{fv} function.

  Unrestriction was first defined in the work of Marcel Oliveira~\<^cite>\<open>"Oliveira2005-PHD" and "Oliveira07"\<close> in his
  UTP mechanisation in \emph{ProofPowerZ}. Our definition modifies his in that our variables
  are semantically characterised as lenses, and supported by the lens laws, rather than named
  syntactic entities. We effectively fuse the ideas from both Feliachi~\<^cite>\<open>"Feliachi2010"\<close> and
  Oliveira's~\<^cite>\<open>"Oliveira07"\<close> mechanisations of the UTP, the former being also purely semantic
  in nature.

  We first set up overloaded syntax for unrestriction, as several concepts will have this
  defined. \<close>

consts
  unrest :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_unrest" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<sharp>" 20)

translations
  "_unrest x p" == "CONST unrest x p"
  "_unrest (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_unrest (x +\<^sub>L y) P"

text \<open> Our syntax translations support both variables and variable sets such that we can write down
  predicates like @{term "&x \<sharp> P"} and also @{term "{&x,&y,&z} \<sharp> P"}.

  We set up a simple tactic for discharging unrestriction conjectures using a simplification set. \<close>

named_theorems unrest
method unrest_tac = (simp add: unrest)?

text \<open> Unrestriction for expressions is defined as a lifted construct using the underlying lens
  operations. It states that lens $x$ is unrestricted by expression $e$ provided that, for any
  state-space binding $b$ and variable valuation $v$, the value which the expression evaluates
  to is unaltered if we set $x$ to $v$ in $b$. In other words, we cannot effect the behaviour
  of $e$ by changing $x$. Thus $e$ does not observe the portion of state-space characterised
  by $x$. We add this definition to our overloaded constant. \<close>

lift_definition unrest_uexpr :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. \<forall> b v. e (put\<^bsub>x\<^esub> b v) = e b" .

adhoc_overloading
  unrest unrest_uexpr

lemma unrest_expr_alt_def:
  "weak_lens x \<Longrightarrow> (x \<sharp> P) = (\<forall> b b'. \<lbrakk>P\<rbrakk>\<^sub>e (b \<oplus>\<^sub>L b' on x) = \<lbrakk>P\<rbrakk>\<^sub>e b)"
  by (transfer, metis lens_override_def weak_lens.put_get)

subsection \<open> Unrestriction laws \<close>

text \<open> We now prove unrestriction laws for the key constructs of our expression model. Many
  of these depend on lens properties and so variously employ the assumptions @{term mwb_lens} and
  @{term vwb_lens}, depending on the number of assumptions from the lenses theory is required.

  Firstly, we prove a general property -- if $x$ and $y$ are both unrestricted in $P$, then their composition
  is also unrestricted in $P$. One can interpret the composition here as a union -- if the two sets
  of variables $x$ and $y$ are unrestricted, then so is their union. \<close>

lemma unrest_var_comp [unrest]:
  "\<lbrakk> x \<sharp> P; y \<sharp> P \<rbrakk> \<Longrightarrow> x;y \<sharp> P"
  by (transfer, simp add: lens_defs)

lemma unrest_svar [unrest]: "(&x \<sharp> P) \<longleftrightarrow> (x \<sharp> P)"
  by (transfer, simp add: lens_defs)

text \<open> No lens is restricted by a literal, since it returns the same value for any state binding. \<close>

lemma unrest_lit [unrest]: "x \<sharp> \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

text \<open> If one lens is smaller than another, then any unrestriction on the larger lens implies
  unrestriction on the smaller. \<close>

lemma unrest_sublens:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<sharp> P" "y \<subseteq>\<^sub>L x"
  shows "y \<sharp> P"
  using assms
  by (transfer, metis (no_types, lifting) lens.select_convs(2) lens_comp_def sublens_def)

text \<open> If two lenses are equivalent, and thus they characterise the same state-space regions,
  then clearly unrestrictions over them are equivalent. \<close>

lemma unrest_equiv:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "mwb_lens y" "x \<approx>\<^sub>L y" "x \<sharp> P"
  shows "y \<sharp> P"
  by (metis assms lens_equiv_def sublens_pres_mwb sublens_put_put unrest_uexpr.rep_eq)

text \<open> If we can show that an expression is unrestricted on a bijective lens, then is unrestricted
  on the entire state-space. \<close>

lemma bij_lens_unrest_all:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X" "X \<sharp> P"
  shows "\<Sigma> \<sharp> P"
  using assms bij_lens_equiv_id lens_equiv_def unrest_sublens by blast

lemma bij_lens_unrest_all_eq:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X"
  shows "(\<Sigma> \<sharp> P) \<longleftrightarrow> (X \<sharp> P)"
  by (meson assms bij_lens_equiv_id lens_equiv_def unrest_sublens)

text \<open> If an expression is unrestricted by all variables, then it is unrestricted by any variable \<close>

lemma unrest_all_var:
  fixes e :: "('a, '\<alpha>) uexpr"
  assumes "\<Sigma> \<sharp> e"
  shows "x \<sharp> e"
  by (metis assms id_lens_def lens.simps(2) unrest_uexpr.rep_eq)

text \<open> We can split an unrestriction composed by lens plus \<close>

lemma unrest_plus_split:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<bowtie> y" "vwb_lens x" "vwb_lens y"
  shows "unrest (x +\<^sub>L y) P \<longleftrightarrow> (x \<sharp> P) \<and> (y \<sharp> P)"
  using assms
  by (meson lens_plus_right_sublens lens_plus_ub sublens_refl unrest_sublens unrest_var_comp vwb_lens_wb)

text \<open> The following laws demonstrate the primary motivation for lens independence: a variable
  expression is unrestricted by another variable only when the two variables are independent.
  Lens independence thus effectively allows us to semantically characterise when two variables,
  or sets of variables, are different. \<close>

lemma unrest_var [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> y \<sharp> var x"
  by (transfer, auto)

lemma unrest_iuvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y \<sharp> $x"
  by (simp add: unrest_var)

lemma unrest_ouvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y\<acute> \<sharp> $x\<acute>"
  by (simp add: unrest_var)

text \<open> The following laws follow automatically from independence of input and output variables. \<close>

lemma unrest_iuvar_ouvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x \<sharp> $y\<acute>"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_out var_update_in)

lemma unrest_ouvar_iuvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x\<acute> \<sharp> $y"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_in var_update_out)

text \<open> Unrestriction distributes through the various function lifting expression constructs;
  this allows us to prove unrestrictions for the majority of the expression language. \<close>

lemma unrest_uop [unrest]: "x \<sharp> e \<Longrightarrow> x \<sharp> uop f e"
  by (transfer, simp)

lemma unrest_bop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> bop f u v"
  by (transfer, simp)

lemma unrest_trop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w \<rbrakk> \<Longrightarrow> x \<sharp> trop f u v w"
  by (transfer, simp)

lemma unrest_qtop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w; x \<sharp> y \<rbrakk> \<Longrightarrow> x \<sharp> qtop f u v w y"
  by (transfer, simp)

text \<open> For convenience, we also prove unrestriction rules for the bespoke operators on equality,
  numbers, arithmetic etc. \<close>

lemma unrest_eq [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u =\<^sub>u v"
  by (simp add: eq_upred_def, transfer, simp)

lemma unrest_zero [unrest]: "x \<sharp> 0"
  by (simp add: unrest_lit zero_uexpr_def)

lemma unrest_one [unrest]: "x \<sharp> 1"
  by (simp add: one_uexpr_def unrest_lit)

lemma unrest_numeral [unrest]: "x \<sharp> (numeral n)"
  by (simp add: numeral_uexpr_simp unrest_lit)

lemma unrest_sgn [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> sgn u"
  by (simp add: sgn_uexpr_def unrest_uop)

lemma unrest_abs [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> abs u"
  by (simp add: abs_uexpr_def unrest_uop)

lemma unrest_plus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u + v"
  by (simp add: plus_uexpr_def unrest)

lemma unrest_uminus [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> - u"
  by (simp add: uminus_uexpr_def unrest)

lemma unrest_minus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u - v"
  by (simp add: minus_uexpr_def unrest)

lemma unrest_times [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u * v"
  by (simp add: times_uexpr_def unrest)

lemma unrest_divide [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u / v"
  by (simp add: divide_uexpr_def unrest)

lemma unrest_case_prod [unrest]: "\<lbrakk> \<And> i j. x \<sharp> P i j \<rbrakk> \<Longrightarrow> x \<sharp> case_prod P v"
  by (simp add: prod.split_sel_asm)

text \<open> For a $\lambda$-term we need to show that the characteristic function expression does
  not restrict $v$ for any input value $x$. \<close>

lemma unrest_ulambda [unrest]:
  "\<lbrakk> \<And> x. v \<sharp> F x \<rbrakk> \<Longrightarrow> v \<sharp> (\<lambda> x \<bullet> F x)"
  by (transfer, simp)

end


(*  Title:      HOL/Library/List_Lenlexorder.thy
*)

section \<open>Lexicographic order on lists\<close>

theory List_Lenlexorder
imports Main
begin

instantiation list :: (ord) ord
begin

definition
  list_less_def: "xs < ys \<longleftrightarrow> (xs, ys) \<in> lenlex {(u, v). u < v}"

definition
  list_le_def: "(xs :: _ list) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance list :: (order) order
proof
  have tr: "trans {(u, v::'a). u < v}"
    using trans_def by fastforce
  have \<section>: False
    if "(xs,ys) \<in> lenlex {(u, v). u < v}" "(ys,xs) \<in> lenlex {(u, v). u < v}" for xs ys :: "'a list"
  proof -
    have "(xs,xs) \<in> lenlex {(u, v). u < v}"
      using that transD [OF lenlex_transI [OF tr]] by blast
    then show False
      by (meson case_prodD lenlex_irreflexive less_irrefl mem_Collect_eq)
  qed
  show "xs \<le> xs" for xs :: "'a list" by (simp add: list_le_def)
  show "xs \<le> zs" if "xs \<le> ys" and "ys \<le> zs" for xs ys zs :: "'a list"
    using that transD [OF lenlex_transI [OF tr]] by (auto simp add: list_le_def list_less_def)
  show "xs = ys" if "xs \<le> ys" "ys \<le> xs" for xs ys :: "'a list"
    using \<section> that list_le_def list_less_def by blast
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs" for xs ys :: "'a list"
    by (auto simp add: list_less_def list_le_def dest: \<section>)
qed

instance list :: (linorder) linorder
proof
  fix xs ys :: "'a list"
  have "total (lenlex {(u, v::'a). u < v})"
    by (rule total_lenlex) (auto simp: total_on_def)
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: total_on_def list_le_def list_less_def)
qed

instantiation list :: (linorder) distrib_lattice
begin

definition "(inf :: 'a list \<Rightarrow> _) = min"

definition "(sup :: 'a list \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_list_def sup_list_def max_min_distrib2)

end

lemma not_less_Nil [simp]: "\<not> x < []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "[] < a # x"
  by (simp add: list_less_def)

lemma Cons_less_Cons: "a # x < b # y \<longleftrightarrow> length x < length y \<or> length x = length y \<and> (a < b \<or> a = b \<and> x < y)"
  using lenlex_length
  by (fastforce simp: list_less_def Cons_lenlex_iff)

lemma le_Nil [simp]: "x \<le> [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "[] \<le> x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons: "a # x \<le> b # y \<longleftrightarrow> length x < length y \<or> length x = length y \<and> (a < b \<or> a = b \<and> x \<le> y)"
  by (auto simp: list_le_def Cons_less_Cons)

instantiation list :: (order) order_bot
begin

definition "bot = []"

instance
  by standard (simp add: bot_list_def)

end

end