theory prop_20
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun len :: "Nat list => Nat" where
    "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun le :: "Nat => Nat => bool" where
    "le (Z) y = True"
  | "le (y) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insort :: "Nat => Nat list => Nat list" where
    "insort x (Nil2) = Cons2 x (Nil2)"
  | "insort x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insort x xs))"
  fun sort :: "Nat list => Nat list" where
    "sort (Nil2) = Nil2"
  | "sort (Cons2 y xs) = insort y (sort xs)"
  (*hipster len le insort sort *)
  (*hipster insort*)

lemma lemma_a [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes insort.simps)

lemma lemma_aa [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes insort.simps)

lemma lemma_ab [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes insort.simps)

lemma unknown [thy_expl]: "insort x (insort y z) = insort y (insort x z)"
oops

lemma unknown [thy_expl]: "insort Z (insort x y) = insort x (insort Z y)"
oops

(*hipster len sort*)
lemma lemma_ac [thy_expl]: "insort Z (sort x2) = sort (insort Z x2)"
by (hipster_induct_schemes len.simps sort.simps)

lemma unknown [thy_expl]: "sort (insort x y) = insort x (sort y)"
oops

lemma unknown [thy_expl]: "sort (sort x) = sort x"
oops

(*hipster_cond le*)
lemma lemma_ad [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_af [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma lemma_ag [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

(*lemma le_a : "(le (S Z) (S x) = True)"
by (tactic {* Tactic_Data.routine_tac @{context}*})

lemma le_aa []: "(le x y \<Longrightarrow> le x (S y))"
by (tactic {* Tactic_Data.routine_tac @{context}*})

lemma le_ac: "(le x y \<Longrightarrow> le (S x) (S y) = True)"
by (tactic {* Tactic_Data.routine_tac @{context}*})*)

(* false:
lemma le_ai: "(le x y \<and> le x z \<Longrightarrow> le x (S Z) = True)"
by (hipster_induct_schemes le.simps Nat.exhaust)*)

(*hipster len insort le*)
lemma lemma_ah [thy_expl]: "S (len x5) = len (insort y5 x5)"
by (hipster_induct_schemes len.simps insort.simps le.simps)

lemma lemma_ai [thy_expl]: "insort Z (insort x2 y2) = insort x2 (insort Z y2)"
by (hipster_induct_schemes len.simps insort.simps le.simps)

lemma unknown [thy_expl]: "insort x (insort y z) = insort y (insort x z)"
oops

  theorem x0 :
    "(len (sort xs)) = (len xs)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*  Title:      ZF/upair.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge

Observe the order of dependence:
    Upair is defined in terms of Replace
    \<union> is defined in terms of Upair and \<Union>(similarly for Int)
    cons is defined in terms of Upair and Un
    Ordered pairs and descriptions are defined using cons ("set notation")
*)

section{*Unordered Pairs*}

theory upair
imports ZF
keywords "print_tcset" :: diag
begin

ML_file "Tools/typechk.ML"

lemma atomize_ball [symmetric, rulify]:
     "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
by (simp add: Ball_def atomize_all atomize_imp)

subsection{*Unordered Pairs: constant @{term Upair}*}

lemma Upair_iff [simp]: "c \<in> Upair(a,b) \<longleftrightarrow> (c=a | c=b)"
by (unfold Upair_def, blast)

lemma UpairI1: "a \<in> Upair(a,b)"
by simp

lemma UpairI2: "b \<in> Upair(a,b)"
by simp

lemma UpairE: "[| a \<in> Upair(b,c);  a=b ==> P;  a=c ==> P |] ==> P"
by (simp, blast)

subsection{*Rules for Binary Union, Defined via @{term Upair}*}

lemma Un_iff [simp]: "c \<in> A \<union> B \<longleftrightarrow> (c \<in> A | c \<in> B)"
apply (simp add: Un_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma UnI1: "c \<in> A ==> c \<in> A \<union> B"
by simp

lemma UnI2: "c \<in> B ==> c \<in> A \<union> B"
by simp

declare UnI1 [elim?]  UnI2 [elim?]

lemma UnE [elim!]: "[| c \<in> A \<union> B;  c \<in> A ==> P;  c \<in> B ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma UnE': "[| c \<in> A \<union> B;  c \<in> A ==> P;  [| c \<in> B;  c\<notin>A |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI [intro!]: "(c \<notin> B ==> c \<in> A) ==> c \<in> A \<union> B"
by (simp, blast)

subsection{*Rules for Binary Intersection, Defined via @{term Upair}*}

lemma Int_iff [simp]: "c \<in> A \<inter> B \<longleftrightarrow> (c \<in> A & c \<in> B)"
apply (unfold Int_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma IntI [intro!]: "[| c \<in> A;  c \<in> B |] ==> c \<in> A \<inter> B"
by simp

lemma IntD1: "c \<in> A \<inter> B ==> c \<in> A"
by simp

lemma IntD2: "c \<in> A \<inter> B ==> c \<in> B"
by simp

lemma IntE [elim!]: "[| c \<in> A \<inter> B;  [| c \<in> A; c \<in> B |] ==> P |] ==> P"
by simp

subsection{*Rules for Set Difference, Defined via @{term Upair}*}

lemma Diff_iff [simp]: "c \<in> A-B \<longleftrightarrow> (c \<in> A & c\<notin>B)"
by (unfold Diff_def, blast)

lemma DiffI [intro!]: "[| c \<in> A;  c \<notin> B |] ==> c \<in> A - B"
by simp

lemma DiffD1: "c \<in> A - B ==> c \<in> A"
by simp

lemma DiffD2: "c \<in> A - B ==> c \<notin> B"
by simp

lemma DiffE [elim!]: "[| c \<in> A - B;  [| c \<in> A; c\<notin>B |] ==> P |] ==> P"
by simp

subsection{*Rules for @{term cons}*}

lemma cons_iff [simp]: "a \<in> cons(b,A) \<longleftrightarrow> (a=b | a \<in> A)"
apply (unfold cons_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

(*risky as a typechecking rule, but solves otherwise unconstrained goals of
the form x \<in> ?A*)
lemma consI1 [simp,TC]: "a \<in> cons(a,B)"
by simp

lemma consI2: "a \<in> B ==> a \<in> cons(b,B)"
by simp

lemma consE [elim!]: "[| a \<in> cons(b,A);  a=b ==> P;  a \<in> A ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma consE':
    "[| a \<in> cons(b,A);  a=b ==> P;  [| a \<in> A;  a\<noteq>b |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule*)
lemma consCI [intro!]: "(a\<notin>B ==> a=b) ==> a \<in> cons(b,B)"
by (simp, blast)

lemma cons_not_0 [simp]: "cons(a,B) \<noteq> 0"
by (blast elim: equalityE)

lemmas cons_neq_0 = cons_not_0 [THEN notE]

declare cons_not_0 [THEN not_sym, simp]

subsection{*Singletons*}

lemma singleton_iff: "a \<in> {b} \<longleftrightarrow> a=b"
by simp

lemma singletonI [intro!]: "a \<in> {a}"
by (rule consI1)

lemmas singletonE = singleton_iff [THEN iffD1, elim_format, elim!]

subsection{*Descriptions*}

lemma the_equality [intro]:
    "[| P(a);  !!x. P(x) ==> x=a |] ==> (THE x. P(x)) = a"
apply (unfold the_def)
apply (fast dest: subst)
done

(* Only use this if you already know EX!x. P(x) *)
lemma the_equality2: "[| EX! x. P(x);  P(a) |] ==> (THE x. P(x)) = a"
by blast

lemma theI: "EX! x. P(x) ==> P(THE x. P(x))"
apply (erule ex1E)
apply (subst the_equality)
apply (blast+)
done

(*No congruence rule is necessary: if @{term"\<forall>y.P(y)\<longleftrightarrow>Q(y)"} then
  @{term "THE x.P(x)"}  rewrites to @{term "THE x.Q(x)"} *)

(*If it's "undefined", it's zero!*)
lemma the_0: "~ (EX! x. P(x)) ==> (THE x. P(x))=0"
apply (unfold the_def)
apply (blast elim!: ReplaceE)
done

(*Easier to apply than theI: conclusion has only one occurrence of P*)
lemma theI2:
    assumes p1: "~ Q(0) ==> EX! x. P(x)"
        and p2: "!!x. P(x) ==> Q(x)"
    shows "Q(THE x. P(x))"
apply (rule classical)
apply (rule p2)
apply (rule theI)
apply (rule classical)
apply (rule p1)
apply (erule the_0 [THEN subst], assumption)
done

lemma the_eq_trivial [simp]: "(THE x. x = a) = a"
by blast

lemma the_eq_trivial2 [simp]: "(THE x. a = x) = a"
by blast

subsection{*Conditional Terms: @{text "if-then-else"}*}

lemma if_true [simp]: "(if True then a else b) = a"
by (unfold if_def, blast)

lemma if_false [simp]: "(if False then a else b) = b"
by (unfold if_def, blast)

(*Never use with case splitting, or if P is known to be true or false*)
lemma if_cong:
    "[| P\<longleftrightarrow>Q;  Q ==> a=c;  ~Q ==> b=d |]
     ==> (if P then a else b) = (if Q then c else d)"
by (simp add: if_def cong add: conj_cong)

(*Prevents simplification of x and y \<in> faster and allows the execution
  of functional programs. NOW THE DEFAULT.*)
lemma if_weak_cong: "P\<longleftrightarrow>Q ==> (if P then x else y) = (if Q then x else y)"
by simp

(*Not needed for rewriting, since P would rewrite to True anyway*)
lemma if_P: "P ==> (if P then a else b) = a"
by (unfold if_def, blast)

(*Not needed for rewriting, since P would rewrite to False anyway*)
lemma if_not_P: "~P ==> (if P then a else b) = b"
by (unfold if_def, blast)

lemma split_if [split]:
     "P(if Q then x else y) \<longleftrightarrow> ((Q \<longrightarrow> P(x)) & (~Q \<longrightarrow> P(y)))"
by (case_tac Q, simp_all)

(** Rewrite rules for boolean case-splitting: faster than split_if [split]
**)

lemmas split_if_eq1 = split_if [of "%x. x = b"] for b
lemmas split_if_eq2 = split_if [of "%x. a = x"] for x

lemmas split_if_mem1 = split_if [of "%x. x \<in> b"] for b
lemmas split_if_mem2 = split_if [of "%x. a \<in> x"] for x

lemmas split_ifs = split_if_eq1 split_if_eq2 split_if_mem1 split_if_mem2

(*Logically equivalent to split_if_mem2*)
lemma if_iff: "a: (if P then x else y) \<longleftrightarrow> P & a \<in> x | ~P & a \<in> y"
by simp

lemma if_type [TC]:
    "[| P ==> a \<in> A;  ~P ==> b \<in> A |] ==> (if P then a else b): A"
by simp

(** Splitting IFs in the assumptions **)

lemma split_if_asm: "P(if Q then x else y) \<longleftrightarrow> (~((Q & ~P(x)) | (~Q & ~P(y))))"
by simp

lemmas if_splits = split_if split_if_asm

subsection{*Consequences of Foundation*}

(*was called mem_anti_sym*)
lemma mem_asym: "[| a \<in> b;  ~P ==> b \<in> a |] ==> P"
apply (rule classical)
apply (rule_tac A1 = "{a,b}" in foundation [THEN disjE])
apply (blast elim!: equalityE)+
done

(*was called mem_anti_refl*)
lemma mem_irrefl: "a \<in> a ==> P"
by (blast intro: mem_asym)

(*mem_irrefl should NOT be added to default databases:
      it would be tried on most goals, making proofs slower!*)

lemma mem_not_refl: "a \<notin> a"
apply (rule notI)
apply (erule mem_irrefl)
done

(*Good for proving inequalities by rewriting*)
lemma mem_imp_not_eq: "a \<in> A ==> a \<noteq> A"
by (blast elim!: mem_irrefl)

lemma eq_imp_not_mem: "a=A ==> a \<notin> A"
by (blast intro: elim: mem_irrefl)

subsection{*Rules for Successor*}

lemma succ_iff: "i \<in> succ(j) \<longleftrightarrow> i=j | i \<in> j"
by (unfold succ_def, blast)

lemma succI1 [simp]: "i \<in> succ(i)"
by (simp add: succ_iff)

lemma succI2: "i \<in> j ==> i \<in> succ(j)"
by (simp add: succ_iff)

lemma succE [elim!]:
    "[| i \<in> succ(j);  i=j ==> P;  i \<in> j ==> P |] ==> P"
apply (simp add: succ_iff, blast)
done

(*Classical introduction rule*)
lemma succCI [intro!]: "(i\<notin>j ==> i=j) ==> i \<in> succ(j)"
by (simp add: succ_iff, blast)

lemma succ_not_0 [simp]: "succ(n) \<noteq> 0"
by (blast elim!: equalityE)

lemmas succ_neq_0 = succ_not_0 [THEN notE, elim!]

declare succ_not_0 [THEN not_sym, simp]
declare sym [THEN succ_neq_0, elim!]

(* @{term"succ(c) \<subseteq> B ==> c \<in> B"} *)
lemmas succ_subsetD = succI1 [THEN [2] subsetD]

(* @{term"succ(b) \<noteq> b"} *)
lemmas succ_neq_self = succI1 [THEN mem_imp_not_eq, THEN not_sym]

lemma succ_inject_iff [simp]: "succ(m) = succ(n) \<longleftrightarrow> m=n"
by (blast elim: mem_asym elim!: equalityE)

lemmas succ_inject = succ_inject_iff [THEN iffD1, dest!]

subsection{*Miniscoping of the Bounded Universal Quantifier*}

lemma ball_simps1:
     "(\<forall>x\<in>A. P(x) & Q)   \<longleftrightarrow> (\<forall>x\<in>A. P(x)) & (A=0 | Q)"
     "(\<forall>x\<in>A. P(x) | Q)   \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) | Q)"
     "(\<forall>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x\<in>A. P(x))) \<longleftrightarrow> (\<exists>x\<in>A. ~P(x))"
     "(\<forall>x\<in>0.P(x)) \<longleftrightarrow> True"
     "(\<forall>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) & (\<forall>x\<in>i. P(x))"
     "(\<forall>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) & (\<forall>x\<in>B. P(x))"
     "(\<forall>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<forall>y\<in>A. P(f(y)))"
     "(\<forall>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P(x))"
by blast+

lemma ball_simps2:
     "(\<forall>x\<in>A. P & Q(x))   \<longleftrightarrow> (A=0 | P) & (\<forall>x\<in>A. Q(x))"
     "(\<forall>x\<in>A. P | Q(x))   \<longleftrightarrow> (P | (\<forall>x\<in>A. Q(x)))"
     "(\<forall>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x\<in>A. Q(x)))"
by blast+

lemma ball_simps3:
     "(\<forall>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<forall>x\<in>A. Q(x) \<longrightarrow> P(x))"
by blast+

lemmas ball_simps [simp] = ball_simps1 ball_simps2 ball_simps3

lemma ball_conj_distrib:
    "(\<forall>x\<in>A. P(x) & Q(x)) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) & (\<forall>x\<in>A. Q(x)))"
by blast

subsection{*Miniscoping of the Bounded Existential Quantifier*}

lemma bex_simps1:
     "(\<exists>x\<in>A. P(x) & Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) & Q)"
     "(\<exists>x\<in>A. P(x) | Q) \<longleftrightarrow> (\<exists>x\<in>A. P(x)) | (A\<noteq>0 & Q)"
     "(\<exists>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) \<longrightarrow> (A\<noteq>0 & Q))"
     "(\<exists>x\<in>0.P(x)) \<longleftrightarrow> False"
     "(\<exists>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) | (\<exists>x\<in>i. P(x))"
     "(\<exists>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) | (\<exists>x\<in>B. P(x))"
     "(\<exists>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<exists>y\<in>A. P(f(y)))"
     "(\<exists>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y.  P(x))"
     "(~(\<exists>x\<in>A. P(x))) \<longleftrightarrow> (\<forall>x\<in>A. ~P(x))"
by blast+

lemma bex_simps2:
     "(\<exists>x\<in>A. P & Q(x)) \<longleftrightarrow> (P & (\<exists>x\<in>A. Q(x)))"
     "(\<exists>x\<in>A. P | Q(x)) \<longleftrightarrow> (A\<noteq>0 & P) | (\<exists>x\<in>A. Q(x))"
     "(\<exists>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> ((A=0 | P) \<longrightarrow> (\<exists>x\<in>A. Q(x)))"
by blast+

lemma bex_simps3:
     "(\<exists>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<exists>x\<in>A. Q(x) & P(x))"
by blast

lemmas bex_simps [simp] = bex_simps1 bex_simps2 bex_simps3

lemma bex_disj_distrib:
    "(\<exists>x\<in>A. P(x) | Q(x)) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) | (\<exists>x\<in>A. Q(x)))"
by blast

(** One-point rule for bounded quantifiers: see HOL/Set.ML **)

lemma bex_triv_one_point1 [simp]: "(\<exists>x\<in>A. x=a) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_triv_one_point2 [simp]: "(\<exists>x\<in>A. a=x) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_one_point1 [simp]: "(\<exists>x\<in>A. x=a & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma bex_one_point2 [simp]: "(\<exists>x\<in>A. a=x & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma ball_one_point1 [simp]: "(\<forall>x\<in>A. x=a \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

lemma ball_one_point2 [simp]: "(\<forall>x\<in>A. a=x \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

subsection{*Miniscoping of the Replacement Operator*}

text{*These cover both @{term Replace} and @{term Collect}*}
lemma Rep_simps [simp]:
     "{x. y \<in> 0, R(x,y)} = 0"
     "{x \<in> 0. P(x)} = 0"
     "{x \<in> A. Q} = (if Q then A else 0)"
     "RepFun(0,f) = 0"
     "RepFun(succ(i),f) = cons(f(i), RepFun(i,f))"
     "RepFun(cons(a,B),f) = cons(f(a), RepFun(B,f))"
by (simp_all, blast+)

subsection{*Miniscoping of Unions*}

lemma UN_simps1:
     "(\<Union>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<union> B')   = (if C=0 then 0 else (\<Union>x\<in>C. A(x)) \<union> B')"
     "(\<Union>x\<in>C. A' \<union> B(x))   = (if C=0 then 0 else A' \<union> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<inter> B')  = ((\<Union>x\<in>C. A(x)) \<inter> B')"
     "(\<Union>x\<in>C. A' \<inter> B(x))  = (A' \<inter> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) - B')    = ((\<Union>x\<in>C. A(x)) - B')"
     "(\<Union>x\<in>C. A' - B(x))    = (if C=0 then 0 else A' - (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI )+
done

lemma UN_simps2:
      "(\<Union>x\<in>\<Union>(A). B(x)) = (\<Union>y\<in>A. \<Union>x\<in>y. B(x))"
      "(\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z\<in>B(x). C(z))"
      "(\<Union>x\<in>RepFun(A,f). B(x))     = (\<Union>a\<in>A. B(f(a)))"
by blast+

lemmas UN_simps [simp] = UN_simps1 UN_simps2

text{*Opposite of miniscoping: pull the operator out*}

lemma UN_extend_simps1:
     "(\<Union>x\<in>C. A(x)) \<union> B   = (if C=0 then B else (\<Union>x\<in>C. A(x) \<union> B))"
     "((\<Union>x\<in>C. A(x)) \<inter> B) = (\<Union>x\<in>C. A(x) \<inter> B)"
     "((\<Union>x\<in>C. A(x)) - B) = (\<Union>x\<in>C. A(x) - B)"
apply simp_all
apply blast+
done

lemma UN_extend_simps2:
     "cons(a, \<Union>x\<in>C. B(x)) = (if C=0 then {a} else (\<Union>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Union>x\<in>C. A \<union> B(x)))"
     "(A \<inter> (\<Union>x\<in>C. B(x))) = (\<Union>x\<in>C. A \<inter> B(x))"
     "A - (\<Inter>x\<in>C. B(x))    = (if C=0 then A else (\<Union>x\<in>C. A - B(x)))"
     "(\<Union>y\<in>A. \<Union>x\<in>y. B(x)) = (\<Union>x\<in>\<Union>(A). B(x))"
     "(\<Union>a\<in>A. B(f(a))) = (\<Union>x\<in>RepFun(A,f). B(x))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemma UN_UN_extend:
     "(\<Union>x\<in>A. \<Union>z\<in>B(x). C(z)) = (\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z))"
by blast

lemmas UN_extend_simps = UN_extend_simps1 UN_extend_simps2 UN_UN_extend

subsection{*Miniscoping of Intersections*}

lemma INT_simps1:
     "(\<Inter>x\<in>C. A(x) \<inter> B) = (\<Inter>x\<in>C. A(x)) \<inter> B"
     "(\<Inter>x\<in>C. A(x) - B)   = (\<Inter>x\<in>C. A(x)) - B"
     "(\<Inter>x\<in>C. A(x) \<union> B)  = (if C=0 then 0 else (\<Inter>x\<in>C. A(x)) \<union> B)"
by (simp_all add: Inter_def, blast+)

lemma INT_simps2:
     "(\<Inter>x\<in>C. A \<inter> B(x)) = A \<inter> (\<Inter>x\<in>C. B(x))"
     "(\<Inter>x\<in>C. A - B(x))   = (if C=0 then 0 else A - (\<Union>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Inter>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. A \<union> B(x))  = (if C=0 then 0 else A \<union> (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_simps [simp] = INT_simps1 INT_simps2

text{*Opposite of miniscoping: pull the operator out*}

lemma INT_extend_simps1:
     "(\<Inter>x\<in>C. A(x)) \<inter> B = (\<Inter>x\<in>C. A(x) \<inter> B)"
     "(\<Inter>x\<in>C. A(x)) - B = (\<Inter>x\<in>C. A(x) - B)"
     "(\<Inter>x\<in>C. A(x)) \<union> B  = (if C=0 then B else (\<Inter>x\<in>C. A(x) \<union> B))"
apply (simp_all add: Inter_def, blast+)
done

lemma INT_extend_simps2:
     "A \<inter> (\<Inter>x\<in>C. B(x)) = (\<Inter>x\<in>C. A \<inter> B(x))"
     "A - (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Inter>x\<in>C. A - B(x)))"
     "cons(a, \<Inter>x\<in>C. B(x)) = (if C=0 then {a} else (\<Inter>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Inter>x\<in>C. B(x))  = (if C=0 then A else (\<Inter>x\<in>C. A \<union> B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_extend_simps = INT_extend_simps1 INT_extend_simps2

subsection{*Other simprules*}

(*** Miniscoping: pushing in big Unions, Intersections, quantifiers, etc. ***)

lemma misc_simps [simp]:
     "0 \<union> A = A"
     "A \<union> 0 = A"
     "0 \<inter> A = 0"
     "A \<inter> 0 = 0"
     "0 - A = 0"
     "A - 0 = A"
     "\<Union>(0) = 0"
     "\<Union>(cons(b,A)) = b \<union> \<Union>(A)"
     "\<Inter>({b}) = b"
by blast+

end


theory Weak_Transition_System
imports
  Transition_System
begin

section \<open>Nominal Transition Systems and Bisimulations with Unobservable Transitions\<close>

subsection \<open>Nominal transition systems with unobservable transitions\<close>

locale weak_nominal_ts = nominal_ts satisfies transition
  for satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool" (infix "\<turnstile>" 70)
  and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool" (infix "\<rightarrow>" 70) +
  fixes \<tau> :: 'act
  assumes tau_eqvt [eqvt]: "p \<bullet> \<tau> = \<tau>"
begin

  lemma bn_tau_empty [simp]: "bn \<tau> = {}"
  using bn_eqvt bn_finite tau_eqvt by (metis eqvt_def supp_finite_atom_set supp_fun_eqvt)

  lemma bn_tau_fresh [simp]: "bn \<tau> \<sharp>* P"
  by (simp add: fresh_star_def)

  inductive tau_transition :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infix "\<Rightarrow>" 70) where
    tau_refl [simp]: "P \<Rightarrow> P"
  | tau_step: "\<lbrakk> P \<rightarrow> \<langle>\<tau>, P'\<rangle>; P' \<Rightarrow> P'' \<rbrakk> \<Longrightarrow> P \<Rightarrow> P''"

  definition observable_transition :: "'state \<Rightarrow> 'act \<Rightarrow> 'state \<Rightarrow> bool" ("_/ \<Rightarrow>{_}/ _" [70, 70, 71] 71) where
    "P \<Rightarrow>{\<alpha>} P' \<equiv> \<exists>Q Q'. P \<Rightarrow> Q \<and> Q \<rightarrow> \<langle>\<alpha>, Q'\<rangle> \<and> Q' \<Rightarrow> P'"

  definition weak_transition :: "'state \<Rightarrow> 'act \<Rightarrow> 'state \<Rightarrow> bool" ("_/ \<Rightarrow>\<langle>_\<rangle>/ _" [70, 70, 71] 71) where
    "P \<Rightarrow>\<langle>\<alpha>\<rangle> P' \<equiv> if \<alpha> = \<tau> then P \<Rightarrow> P' else P \<Rightarrow>{\<alpha>} P'"

  text \<open>The transition relations defined above are equivariant.\<close>

  lemma tau_transition_eqvt (*[eqvt]*):
    assumes "P \<Rightarrow> P'" shows "p \<bullet> P \<Rightarrow> p \<bullet> P'"
  using assms proof (induction)
    case (tau_refl P) show ?case
      by (fact tau_transition.tau_refl)
  next
    case (tau_step P P' P'')
      from \<open>P \<rightarrow> \<langle>\<tau>,P'\<rangle>\<close> have "p \<bullet> P \<rightarrow> \<langle>\<tau>,p \<bullet> P'\<rangle>"
        using tau_eqvt transition_eqvt' by fastforce
      with \<open>p \<bullet> P' \<Rightarrow> p \<bullet> P''\<close> show ?case
        using tau_transition.tau_step by blast
  qed

  lemma observable_transition_eqvt (*[eqvt]*):
    assumes "P \<Rightarrow>{\<alpha>} P'" shows "p \<bullet> P \<Rightarrow>{p \<bullet> \<alpha>} p \<bullet> P'"
  using assms unfolding observable_transition_def by (metis transition_eqvt' tau_transition_eqvt)

  lemma weak_transition_eqvt (*[eqvt]*):
    assumes "P \<Rightarrow>\<langle>\<alpha>\<rangle> P'" shows "p \<bullet> P \<Rightarrow>\<langle>p \<bullet> \<alpha>\<rangle> p \<bullet> P'"
  using assms unfolding weak_transition_def by (metis (full_types) observable_transition_eqvt permute_minus_cancel(2) tau_eqvt tau_transition_eqvt)

  text \<open>Additional lemmas about @{const tau_transition}, @{const observable_transition} and
  @{const weak_transition}.\<close>

  lemma tau_transition_trans:
    assumes "P \<Rightarrow> Q" and "Q \<Rightarrow> R"
    shows "P \<Rightarrow> R"
  using assms by (induction, auto simp add: tau_step)

  lemma observable_transitionI:
    assumes "P \<Rightarrow> Q" and "Q \<rightarrow> \<langle>\<alpha>, Q'\<rangle>" and "Q' \<Rightarrow> P'"
    shows "P \<Rightarrow>{\<alpha>} P'"
  using assms observable_transition_def by blast

  lemma observable_transition_stepI [simp]:
    assumes "P \<rightarrow> \<langle>\<alpha>, P'\<rangle>"
    shows "P \<Rightarrow>{\<alpha>} P'"
  using assms observable_transitionI tau_refl by blast

  lemma observable_tau_transition:
    assumes "P \<Rightarrow>{\<tau>} P'"
    shows "P \<Rightarrow> P'"
  proof -
    from \<open>P \<Rightarrow>{\<tau>} P'\<close> obtain Q Q' where "P \<Rightarrow> Q" and "Q \<rightarrow> \<langle>\<tau>, Q'\<rangle>" and "Q' \<Rightarrow> P'"
      unfolding observable_transition_def by blast
    then show ?thesis
      by (metis tau_step tau_transition_trans)
  qed

  lemma weak_transition_tau_iff [simp]:
    "P \<Rightarrow>\<langle>\<tau>\<rangle> P' \<longleftrightarrow> P \<Rightarrow> P'"
  by (simp add: weak_transition_def)

  lemma weak_transition_not_tau_iff [simp]:
    assumes "\<alpha> \<noteq> \<tau>"
    shows "P \<Rightarrow>\<langle>\<alpha>\<rangle> P' \<longleftrightarrow> P \<Rightarrow>{\<alpha>} P'"
  using assms by (simp add: weak_transition_def)

  lemma weak_transition_stepI [simp]:
    assumes "P \<Rightarrow>{\<alpha>} P'"
    shows "P \<Rightarrow>\<langle>\<alpha>\<rangle> P'"
  using assms by (cases "\<alpha> = \<tau>", simp_all add: observable_tau_transition)

  lemma weak_transition_weakI:
    assumes "P \<Rightarrow> Q" and "Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q'" and "Q' \<Rightarrow> P'"
    shows "P \<Rightarrow>\<langle>\<alpha>\<rangle> P'"
  proof (cases "\<alpha> = \<tau>")
    case True with assms show ?thesis
      by (metis tau_transition_trans weak_transition_tau_iff)
  next
    case False with assms show ?thesis
      using observable_transition_def tau_transition_trans weak_transition_not_tau_iff by blast
  qed

end

subsection \<open>Weak bisimulations\<close>

context weak_nominal_ts
begin

  definition is_weak_bisimulation :: "('state \<Rightarrow> 'state \<Rightarrow> bool) \<Rightarrow> bool" where
    "is_weak_bisimulation R \<equiv>
      symp R \<and>
      \<comment> \<open>weak static implication\<close>
      (\<forall>P Q \<phi>. R P Q \<and> P \<turnstile> \<phi> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow> Q' \<and> R P Q' \<and> Q' \<turnstile> \<phi>)) \<and>
      \<comment> \<open>weak simulation\<close>
      (\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> R P' Q')))"

  definition weakly_bisimilar :: "'state \<Rightarrow> 'state \<Rightarrow> bool"  (infix "\<approx>\<cdot>" 100) where
    "P \<approx>\<cdot> Q \<equiv> \<exists>R. is_weak_bisimulation R \<and> R P Q"

  text \<open>@{const weakly_bisimilar} is an equivariant equivalence relation.\<close>

  lemma is_weak_bisimulation_eqvt (*[eqvt]*):
    assumes "is_weak_bisimulation R" shows "is_weak_bisimulation (p \<bullet> R)"
  using assms unfolding is_weak_bisimulation_def
  proof (clarify)
    assume 1: "symp R"
    assume 2: "\<forall>P Q \<phi>. R P Q \<and> P \<turnstile> \<phi> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow> Q' \<and> R P Q' \<and> Q' \<turnstile> \<phi>)"
    assume 3: "\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> R P' Q'))"
    have "symp (p \<bullet> R)" (is ?S)
      using 1 by (simp add: symp_eqvt)
    moreover have "\<forall>P Q \<phi>. (p \<bullet> R) P Q \<and> P \<turnstile> \<phi> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow> Q' \<and> (p \<bullet> R) P Q' \<and> Q' \<turnstile> \<phi>)" (is ?T)
      proof (clarify)
        fix P Q \<phi>
        assume pR: "(p \<bullet> R) P Q" and phi: "P \<turnstile> \<phi>"
        from pR have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover from phi have "(-p \<bullet> P) \<turnstile> (-p \<bullet> \<phi>)"
          by (metis satisfies_eqvt)
        ultimately obtain Q' where *: "-p \<bullet> Q \<Rightarrow> Q'" and **: "R (-p \<bullet> P) Q'" and ***: "Q' \<turnstile> (-p \<bullet> \<phi>)"
          using 2 by blast
        from * have "Q \<Rightarrow> p \<bullet> Q'"
          by (metis permute_minus_cancel(1) tau_transition_eqvt)
        moreover from ** have "(p \<bullet> R) P (p \<bullet> Q')"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover from *** have "p \<bullet> Q' \<turnstile> \<phi>"
          by (metis permute_minus_cancel(1) satisfies_eqvt)
        ultimately show "\<exists>Q'. Q \<Rightarrow> Q' \<and> (p \<bullet> R) P Q' \<and> Q' \<turnstile> \<phi>"
          by metis
      qed
    moreover have "\<forall>P Q. (p \<bullet> R) P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> (p \<bullet> R) P' Q'))" (is ?U)
      proof (clarify)
        fix P Q \<alpha> P'
        assume *: "(p \<bullet> R) P Q" and **: "bn \<alpha> \<sharp>* Q" and ***: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        from * have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover have "bn (-p \<bullet> \<alpha>) \<sharp>* (-p \<bullet> Q)"
          using ** by (metis bn_eqvt fresh_star_permute_iff)
        moreover have "-p \<bullet> P \<rightarrow> \<langle>-p \<bullet> \<alpha>, -p \<bullet> P'\<rangle>"
          using *** by (metis transition_eqvt')
        ultimately obtain Q' where T: "-p \<bullet> Q \<Rightarrow>\<langle>-p \<bullet> \<alpha>\<rangle> Q'" and R: "R (-p \<bullet> P') Q'"
          using 3 by metis
        from T have "Q \<Rightarrow>\<langle>\<alpha>\<rangle> (p \<bullet> Q')"
          by (metis permute_minus_cancel(1) weak_transition_eqvt)
        moreover from R have "(p \<bullet> R) P' (p \<bullet> Q')"
          by (metis eqvt_apply eqvt_lambda permute_bool_def unpermute_def)
        ultimately show "\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> (p \<bullet> R) P' Q'"
          by metis
      qed
    ultimately show "?S \<and> ?T \<and> ?U" by simp
  qed

  lemma weakly_bisimilar_eqvt (*[eqvt]*):
    assumes "P \<approx>\<cdot> Q" shows "(p \<bullet> P) \<approx>\<cdot> (p \<bullet> Q)"
  proof -
    from assms obtain R where *: "is_weak_bisimulation R \<and> R P Q"
      unfolding weakly_bisimilar_def ..
    then have "is_weak_bisimulation (p \<bullet> R)"
      by (simp add: is_weak_bisimulation_eqvt)
    moreover from "*" have "(p \<bullet> R) (p \<bullet> P) (p \<bullet> Q)"
      by (metis eqvt_apply permute_boolI)
    ultimately show "(p \<bullet> P) \<approx>\<cdot> (p \<bullet> Q)"
      unfolding weakly_bisimilar_def by auto
  qed

  lemma weakly_bisimilar_reflp: "reflp weakly_bisimilar"
  proof (rule reflpI)
    fix x
    have "is_weak_bisimulation (=)"
      unfolding is_weak_bisimulation_def by (simp add: symp_def)
    then show "x \<approx>\<cdot> x"
      unfolding weakly_bisimilar_def by auto
  qed

  lemma weakly_bisimilar_symp: "symp weakly_bisimilar"
  proof (rule sympI)
    fix P Q
    assume "P \<approx>\<cdot> Q"
    then obtain R where *: "is_weak_bisimulation R \<and> R P Q"
      unfolding weakly_bisimilar_def ..
    then have "R Q P"
      unfolding is_weak_bisimulation_def by (simp add: symp_def)
    with "*" show "Q \<approx>\<cdot> P"
      unfolding weakly_bisimilar_def by auto
  qed

  lemma weakly_bisimilar_is_weak_bisimulation: "is_weak_bisimulation weakly_bisimilar"
  unfolding is_weak_bisimulation_def proof
    show "symp (\<approx>\<cdot>)"
      by (fact weakly_bisimilar_symp)
  next
    show "(\<forall>P Q \<phi>. P \<approx>\<cdot> Q \<and> P \<turnstile> \<phi> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow> Q' \<and> P \<approx>\<cdot> Q' \<and> Q' \<turnstile> \<phi>)) \<and>
      (\<forall>P Q. P \<approx>\<cdot> Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> P' \<approx>\<cdot> Q')))"
      by (auto simp add: is_weak_bisimulation_def weakly_bisimilar_def) blast+
  qed

  lemma weakly_bisimilar_tau_simulation_step:
    assumes "P \<approx>\<cdot> Q" and "P \<Rightarrow> P'"
    obtains Q' where "Q \<Rightarrow> Q'" and "P' \<approx>\<cdot> Q'"
  using \<open>P \<Rightarrow> P'\<close> \<open>P \<approx>\<cdot> Q\<close> proof (induct arbitrary: Q)
    case (tau_refl P) then show ?case
      by (metis tau_transition.tau_refl)
  next
    case (tau_step P P'' P')
    from \<open>P \<rightarrow> \<langle>\<tau>,P''\<rangle>\<close> and \<open>P \<approx>\<cdot> Q\<close> obtain Q'' where "Q \<Rightarrow> Q''" and "P'' \<approx>\<cdot> Q''"
      by (metis bn_tau_fresh is_weak_bisimulation_def weak_transition_def weakly_bisimilar_is_weak_bisimulation)
    then show ?case
      using tau_step.hyps(3) tau_step.prems(1) by (metis tau_transition_trans)
  qed

  lemma weakly_bisimilar_weak_simulation_step:
    assumes "P \<approx>\<cdot> Q" and "bn \<alpha> \<sharp>* Q" and "P \<Rightarrow>\<langle>\<alpha>\<rangle> P'"
    obtains Q' where "Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q'" and "P' \<approx>\<cdot> Q'"
  proof (cases "\<alpha> = \<tau>")
    case True with \<open>P \<approx>\<cdot> Q\<close> and \<open>P \<Rightarrow>\<langle>\<alpha>\<rangle> P'\<close> and that show ?thesis
      using weak_transition_tau_iff weakly_bisimilar_tau_simulation_step by force
  next
    case False with \<open>P \<Rightarrow>\<langle>\<alpha>\<rangle> P'\<close> have "P \<Rightarrow>{\<alpha>} P'"
      by simp
    then obtain P1 P2 where tauP: "P \<Rightarrow> P1" and trans: "P1 \<rightarrow> \<langle>\<alpha>,P2\<rangle>" and tauP2: "P2 \<Rightarrow> P'"
      using observable_transition_def by blast
    from \<open>P \<approx>\<cdot> Q\<close> and tauP obtain Q1 where tauQ: "Q \<Rightarrow> Q1" and P1Q1: "P1 \<approx>\<cdot> Q1"
      by (metis weakly_bisimilar_tau_simulation_step)

    \<comment> \<open>rename~@{term "\<langle>\<alpha>,P2\<rangle>"} to avoid~@{term Q1}, without touching~@{term Q}\<close>
    obtain p where 1: "(p \<bullet> bn \<alpha>) \<sharp>* Q1" and 2: "supp (\<langle>\<alpha>,P2\<rangle>, Q) \<sharp>* p"
      proof (rule at_set_avoiding2[of "bn \<alpha>" Q1 "(\<langle>\<alpha>,P2\<rangle>, Q)", THEN exE])
        show "finite (bn \<alpha>)" by (fact bn_finite)
      next
        show "finite (supp Q1)" by (fact finite_supp)
      next
        show "finite (supp (\<langle>\<alpha>,P2\<rangle>, Q))" by (simp add: finite_supp supp_Pair)
      next
        show "bn \<alpha> \<sharp>* (\<langle>\<alpha>,P2\<rangle>, Q)" using \<open>bn \<alpha> \<sharp>* Q\<close> by (simp add: fresh_star_Pair)
      qed metis
    from 2 have 3: "supp \<langle>\<alpha>,P2\<rangle> \<sharp>* p" and 4: "supp Q \<sharp>* p"
      by (simp add: fresh_star_Un supp_Pair)+
    from 3 have "\<langle>p \<bullet> \<alpha>, p \<bullet> P2\<rangle> = \<langle>\<alpha>,P2\<rangle>"
      using supp_perm_eq by fastforce
    then obtain Q2 where trans': "Q1 \<Rightarrow>\<langle>p \<bullet> \<alpha>\<rangle> Q2" and P2Q2: "(p \<bullet> P2) \<approx>\<cdot> Q2"
      using P1Q1 trans 1 by (metis (mono_tags, lifting) weakly_bisimilar_is_weak_bisimulation bn_eqvt is_weak_bisimulation_def)

    from tauP2 have "p \<bullet> P2 \<Rightarrow> p \<bullet> P'"
      by (fact tau_transition_eqvt)
    with P2Q2 obtain Q' where tauQ2: "Q2 \<Rightarrow> Q'" and P'Q': "(p \<bullet> P') \<approx>\<cdot> Q'"
      by (metis weakly_bisimilar_tau_simulation_step)

    from tauQ and trans' and tauQ2 have "Q \<Rightarrow>\<langle>p \<bullet> \<alpha>\<rangle> Q'"
      by (rule weak_transition_weakI)
    with 4 have "Q \<Rightarrow>\<langle>\<alpha>\<rangle> (-p \<bullet> Q')"
      by (metis permute_minus_cancel(2) supp_perm_eq weak_transition_eqvt)
    moreover from P'Q' have "P' \<approx>\<cdot> (-p \<bullet> Q')"
      by (metis permute_minus_cancel(2) weakly_bisimilar_eqvt)
    ultimately show ?thesis ..
  qed

  lemma weakly_bisimilar_transp: "transp weakly_bisimilar"
  proof (rule transpI)
    fix P Q R
    assume PQ: "P \<approx>\<cdot> Q" and QR: "Q \<approx>\<cdot> R"
    let ?bisim = "weakly_bisimilar OO weakly_bisimilar"
    have "symp ?bisim"
      proof (rule sympI)
        fix P R
        assume "?bisim P R"
        then obtain Q where "P \<approx>\<cdot> Q" and "Q \<approx>\<cdot> R"
          by blast
        then have "R \<approx>\<cdot> Q" and "Q \<approx>\<cdot> P"
          by (metis weakly_bisimilar_symp sympE)+
        then show "?bisim R P"
          by blast
      qed
    moreover have "\<forall>P Q \<phi>. ?bisim P Q \<and> P \<turnstile> \<phi> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow> Q' \<and> ?bisim P Q' \<and> Q' \<turnstile> \<phi>)"
      proof (clarify)
        fix P Q \<phi> R
        assume phi: "P \<turnstile> \<phi>" and PR: "P \<approx>\<cdot> R" and RQ: "R \<approx>\<cdot> Q"
        from PR and phi obtain R' where "R \<Rightarrow> R'" and "P \<approx>\<cdot> R'" and *: "R' \<turnstile> \<phi>"
          using weakly_bisimilar_is_weak_bisimulation is_weak_bisimulation_def by force
        from RQ and \<open>R \<Rightarrow> R'\<close> obtain Q' where "Q \<Rightarrow> Q'" and "R' \<approx>\<cdot> Q'"
          by (metis weakly_bisimilar_tau_simulation_step)
        from \<open>R' \<approx>\<cdot> Q'\<close> and * obtain Q'' where "Q' \<Rightarrow> Q''" and "R' \<approx>\<cdot> Q''" and **: "Q'' \<turnstile> \<phi>"
          using weakly_bisimilar_is_weak_bisimulation is_weak_bisimulation_def by force
        from \<open>Q \<Rightarrow> Q'\<close> and \<open>Q' \<Rightarrow> Q''\<close> have "Q \<Rightarrow> Q''"
          by (fact tau_transition_trans)
        moreover from \<open>P \<approx>\<cdot> R'\<close> and \<open>R' \<approx>\<cdot> Q''\<close> have "?bisim P Q''"
          by blast
        ultimately show "\<exists>Q'. Q \<Rightarrow> Q' \<and> ?bisim P Q' \<and> Q' \<turnstile> \<phi>"
          using ** by metis
      qed
    moreover have "\<forall>P Q. ?bisim P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> ?bisim P' Q'))"
      proof (clarify)
        fix P Q R \<alpha> P'
        assume PR: "P \<approx>\<cdot> R" and RQ: "R \<approx>\<cdot> Q" and fresh: "bn \<alpha> \<sharp>* Q" and trans: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        \<comment> \<open>rename~@{term "\<langle>\<alpha>,P'\<rangle>"} to avoid~@{term R}, without touching~@{term Q}\<close>
        obtain p where 1: "(p \<bullet> bn \<alpha>) \<sharp>* R" and 2: "supp (\<langle>\<alpha>,P'\<rangle>, Q) \<sharp>* p"
          proof (rule at_set_avoiding2[of "bn \<alpha>" R "(\<langle>\<alpha>,P'\<rangle>, Q)", THEN exE])
            show "finite (bn \<alpha>)" by (fact bn_finite)
          next
            show "finite (supp R)" by (fact finite_supp)
          next
            show "finite (supp (\<langle>\<alpha>,P'\<rangle>, Q))" by (simp add: finite_supp supp_Pair)
          next
            show "bn \<alpha> \<sharp>* (\<langle>\<alpha>,P'\<rangle>, Q)" by (simp add: fresh fresh_star_Pair)
          qed metis
        from 2 have 3: "supp \<langle>\<alpha>,P'\<rangle> \<sharp>* p" and 4: "supp Q \<sharp>* p"
          by (simp add: fresh_star_Un supp_Pair)+
        from 3 have "\<langle>p \<bullet> \<alpha>, p \<bullet> P'\<rangle> = \<langle>\<alpha>,P'\<rangle>"
          using supp_perm_eq by fastforce
        with trans obtain pR' where 5: "R \<Rightarrow>\<langle>p \<bullet> \<alpha>\<rangle> pR'" and 6: "(p \<bullet> P') \<approx>\<cdot> pR'"
          using PR 1 by (metis bn_eqvt weakly_bisimilar_is_weak_bisimulation is_weak_bisimulation_def)
        from fresh and 4 have "bn (p \<bullet> \<alpha>) \<sharp>* Q"
          by (metis bn_eqvt fresh_star_permute_iff supp_perm_eq)
        then obtain pQ' where 7: "Q \<Rightarrow>\<langle>p \<bullet> \<alpha>\<rangle> pQ'" and 8: "pR' \<approx>\<cdot> pQ'"
          using RQ 5 by (metis weakly_bisimilar_weak_simulation_step)
        from 7 have "Q \<Rightarrow>\<langle>\<alpha>\<rangle> (-p \<bullet> pQ')"
          using 4 by (metis permute_minus_cancel(2) supp_perm_eq weak_transition_eqvt)
        moreover from 6 and 8 have "?bisim P' (-p \<bullet> pQ')"
          by (metis (no_types, hide_lams) weakly_bisimilar_eqvt permute_minus_cancel(2) relcompp.simps)
        ultimately show "\<exists>Q'. Q \<Rightarrow>\<langle>\<alpha>\<rangle> Q' \<and> ?bisim P' Q'"
          by metis
      qed
    ultimately have "is_weak_bisimulation ?bisim"
      unfolding is_weak_bisimulation_def by metis
    moreover have "?bisim P R"
      using PQ QR by blast
    ultimately show "P \<approx>\<cdot> R"
      unfolding weakly_bisimilar_def by meson
  qed

  lemma weakly_bisimilar_equivp: "equivp weakly_bisimilar"
  by (metis weakly_bisimilar_reflp weakly_bisimilar_symp weakly_bisimilar_transp equivp_reflp_symp_transp)

end

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 Rene Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and Rene Thiemann
    License:     LGPL
*)

(*
Copyright 2009 Christian Sternagel, René Thiemann, Sarah Winkler, Harald Zankl

This file is part of IsaFoR/CeTA.

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

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

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Monotonicity criteria of Neurauter, Zankl, and Middeldorp\<close>

theory NZM
imports "Abstract-Rewriting.SN_Order_Carrier" Polynomials
begin

text \<open>
We show that our check on monotonicity is strong enough to capture the
exact criterion for polynomials of degree 2 that is presented in \cite{NZM10}:
\begin{itemize}
\item $ax^2 + bx + c$ is monotone if $b + a > 0$ and $a \geq 0$
\item $ax^2 + bx + c$ is weakly monotone if $b + a \geq 0$ and $a \geq 0$
\end{itemize}
\<close>

lemma var_monom_x_x [simp]: "var_monom x * var_monom x \<noteq> 1"
  by (unfold eq_monom_sum_var, auto simp: sum_var_monom_mult sum_var_monom_var)

lemma monom_list_x_x[simp]: "monom_list (var_monom x * var_monom x) = [(x,2)]"
  by (transfer, auto simp: monom_mult_list.simps)

lemma assumes b: "b + a > 0" and a: "(a :: int) \<ge> 0"
  shows "check_poly_strict_mono_discrete (>) (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
    extract_def check_poly_strict_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "b > 0 \<and> b \<noteq> 0" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

lemma assumes b: "b + a \<ge> 0" and a: "(a :: int) \<ge> 0"
  shows "check_poly_weak_mono_discrete (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
    extract_def check_poly_weak_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "0 \<le> b" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

end


theory Chapter12_3
imports "HOL-IMP.Hoare_Sound_Complete"
begin

text\<open>
\exercise
Prove
\<close>

lemma "\<Turnstile> {P} c {Q} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> wp c Q s)"
(* your definition/proof here *)

text\<open>
\endexercise

\begin{exercise}
Replace the assignment command with a new command \mbox{@{term"Do f"}} where
@{text "f ::"} @{typ "state \<Rightarrow> state"} can be an arbitrary state transformer.
Update the big-step semantics, Hoare logic and the soundness and completeness proofs.
\end{exercise}

\exercise
Which of the following rules are correct? Proof or counterexample!
\<close>

lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
  \<turnstile> {\<lambda>s. P s \<or> P' s} c {\<lambda>s. Q s \<or> Q' s}"
(* your definition/proof here *)

lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
  \<turnstile> {\<lambda>s. P s \<and> P' s} c {\<lambda>s. Q s \<and> Q' s}"
(* your definition/proof here *)

lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
  \<turnstile> {\<lambda>s. P s \<longrightarrow> P' s} c {\<lambda>s. Q s \<longrightarrow> Q' s}"
(* your definition/proof here *)

text\<open>
\endexercise

\begin{exercise}
Based on Exercise~\ref{exe:IMP:OR}, extend Hoare logic and the soundness and completeness proofs
with nondeterministic choice.
\end{exercise}

\begin{exercise}
Based on Exercise~\ref{exe:IMP:REPEAT}, extend Hoare logic and the soundness and completeness proofs
with a @{text REPEAT} loop. Hint: think of @{text"REPEAT c UNTIL b"} as
equivalent to \noquotes{@{term[source]"c;; WHILE Not b DO c"}}.
\end{exercise}

\exercise\label{exe:sp}
The dual of the weakest precondition is the \concept{strongest postcondition}
@{text sp}. Define @{text sp} in analogy with @{const wp} via the big-step semantics:
\<close>

definition sp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
(* your definition/proof here *)

text\<open> Prove that @{const sp} really is the strongest postcondition: \<close>

lemma "(\<Turnstile> {P} c {Q}) \<longleftrightarrow> (\<forall>s. sp c P s \<longrightarrow> Q s)"
(* your definition/proof here *)

text\<open>
In analogy with the derived equations for @{const wp} given in the text,
give and prove equations for \<open>\<close>calculating'' @{const sp} for three constructs:
@{prop"sp (x ::= a) P = Q\<^sub>1"}, @{prop"sp (c\<^sub>1;;c\<^sub>2) P = Q\<^sub>2"}, and
@{prop"sp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) P = Q\<^sub>3"}.
The @{text Q\<^sub>i} must not involve the semantics and may only call
@{const sp} recursively on the subcommands @{text c\<^sub>i}.
Hint: @{text Q\<^sub>1} requires an existential quantifier.
\<close>

text\<open>
\endexercise
\<close>

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Finite_Fun.thy                                                       *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Finite Functions \<close>

theory Finite_Fun
imports Map_Extra Partial_Fun
begin

subsection \<open> Finite function type and operations \<close>

typedef ('a, 'b) ffun = "{f :: ('a, 'b) pfun. finite(pdom(f))}"
  morphisms pfun_of Abs_pfun
  by (rule_tac x="{}\<^sub>p" in exI, auto)

type_notation ffun (infixr "\<Zffun>" 1)

setup_lifting type_definition_ffun

lift_definition ffun_app :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>f" [999,0] 999) is "pfun_app" .

lift_definition ffun_upd :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<Zffun> 'b" is "pfun_upd" by simp

lift_definition fdom :: "'a \<Zffun> 'b \<Rightarrow> 'a set" is pdom .

lift_definition fran :: "'a \<Zffun> 'b \<Rightarrow> 'b set" is pran .

lift_definition ffun_comp :: "('b, 'c) ffun \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> ('a, 'c) ffun" (infixl "\<circ>\<^sub>f" 55) is pfun_comp by auto

lift_definition ffun_member :: "'a \<times> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" (infix "\<in>\<^sub>f" 50) is "(\<in>\<^sub>p)" .

lift_definition fdom_res :: "'a set \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b" (infixr "\<lhd>\<^sub>f" 85)
is pdom_res by simp

abbreviation fdom_nres (infixr "-\<lhd>\<^sub>f" 85) where "fdom_nres A P \<equiv> (- A) \<lhd>\<^sub>f P"

lift_definition fran_res :: "'a \<Zffun> 'b \<Rightarrow> 'b set \<Rightarrow> 'a \<Zffun> 'b" (infixl "\<rhd>\<^sub>f" 85)
is pran_res by simp

abbreviation fran_nres (infixr "\<rhd>\<^sub>f-" 66) where "fran_nres P A \<equiv> P \<rhd>\<^sub>f (- A)"

lift_definition ffun_graph :: "'a \<Zffun> 'b \<Rightarrow> ('a \<times> 'b) set" is pfun_graph .

lift_definition graph_ffun :: "('a \<times> 'b) set \<Rightarrow> 'a \<Zffun> 'b" is
  "\<lambda> R. if (finite (Domain R)) then graph_pfun R else pempty"
  by (simp add: finite_Domain) (meson pdom_graph_pfun rev_finite_subset)

unbundle lattice_syntax

lift_definition ffun_entries :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Zffun> 'b"
  is "\<lambda> A f. if (finite A) then pfun_entries A f else \<bottom>" by simp

instantiation ffun :: (type, type) bot
begin
lift_definition bot_ffun :: "'a \<Zffun> 'b" is "\<bottom>" by simp
instance ..
end

abbreviation fempty :: "'a \<Zffun> 'b" ("{}\<^sub>f")
where "fempty \<equiv> \<bottom>"

instantiation ffun :: (type, type) oplus
begin
lift_definition oplus_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b" is "(\<oplus>)" by simp
instance ..
end

instantiation ffun :: (type, type) minus
begin
lift_definition minus_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b" is "(-)"
  by (metis Dom_pfun_graph finite_Diff finite_Domain pdom_pfun_graph_finite pfun_graph_minus)
instance ..
end

instantiation ffun :: (type, type) inf
begin
lift_definition inf_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b" is inf
  by (meson finite_Int infinite_super pdom_inter)
instance ..
end

abbreviation ffun_inter :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b" (infixl "\<inter>\<^sub>f" 80)
where "ffun_inter \<equiv> inf"

instantiation ffun :: (type, type) order
begin
  lift_definition less_eq_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>p g" .
  lift_definition less_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" is
  "\<lambda> f g. f < g" .
instance
  by (intro_classes, (transfer, auto)+)
end

abbreviation ffun_subset :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" (infix "\<subset>\<^sub>f" 50)
where "ffun_subset \<equiv> less"

abbreviation ffun_subset_eq :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" (infix "\<subseteq>\<^sub>f" 50)
where "ffun_subset_eq \<equiv> less_eq"

instance ffun :: (type, type) semilattice_inf
  by (intro_classes, (transfer, auto)+)

lemma ffun_subset_eq_least [simp]:
  "{}\<^sub>f \<subseteq>\<^sub>f f"
  by (transfer, auto)

instantiation ffun :: (type, type) size
begin

definition size_ffun :: "'a \<Zffun> 'b \<Rightarrow> nat" where
[simp]: "size_ffun f = card (fdom f)"

instance ..

end

syntax
  "_FfunUpd"  :: "['a \<Zffun> 'b, maplets] => 'a \<Zffun> 'b" ("_'(_')\<^sub>f" [900,0]900)
  "_Ffun"     :: "maplets => 'a \<Zffun> 'b"            ("(1{_}\<^sub>f)")

translations
  "_FfunUpd m (_Maplets xy ms)"  == "_FfunUpd (_FfunUpd m xy) ms"
  "_FfunUpd m (_maplet  x y)"    == "CONST ffun_upd m x y"
  "_Ffun ms"                     => "_FfunUpd (CONST fempty) ms"
  "_Ffun (_Maplets ms1 ms2)"     <= "_FfunUpd (_Ffun ms1) ms2"
  "_Ffun ms"                     <= "_FfunUpd (CONST fempty) ms"

subsection \<open> Algebraic laws \<close>

lemma ffun_comp_assoc: "f \<circ>\<^sub>f (g \<circ>\<^sub>f h) = (f \<circ>\<^sub>f g) \<circ>\<^sub>f h"
  by (transfer, simp add: pfun_comp_assoc)

lemma ffun_override_dist_comp:
  "(f \<oplus> g) \<circ>\<^sub>f h = (f \<circ>\<^sub>f h) \<oplus> (g \<circ>\<^sub>f h)"
  by (transfer, simp add: pfun_override_dist_comp)

lemma ffun_minus_unit [simp]:
  fixes f :: "'a \<Zffun> 'b"
  shows "f - \<bottom> = f"
  by (transfer, simp)

lemma ffun_minus_zero [simp]:
  fixes f :: "'a \<Zffun> 'b"
  shows "\<bottom> - f = \<bottom>"
  by (transfer, simp)

lemma ffun_minus_self [simp]:
  fixes f :: "'a \<Zffun> 'b"
  shows "f - f = \<bottom>"
  by (transfer, simp)

instantiation ffun :: (type, type) override
begin
  lift_definition compatible_ffun :: "'a \<Zffun> 'b \<Rightarrow> 'a \<Zffun> 'b \<Rightarrow> bool" is compatible .

instance
  by (intro_classes; transfer, simp_all add: compatible_sym override_assoc override_comm)
     (transfer, simp add: override_compat_iff)+
end

lemma compatible_ffun_alt_def: "R ## S = ((fdom R) \<lhd>\<^sub>f S = (fdom S) \<lhd>\<^sub>f R)"
  by (transfer, simp add: compatible_pfun_def)

lemma ffun_indep_compat: "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> f ## g"
  by (transfer, simp add: pfun_indep_compat)

lemma ffun_override_commute:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> f \<oplus> g = g \<oplus> f"
  by (meson ffun_indep_compat override_comm)

lemma ffun_minus_override_commute:
  "fdom(g) \<inter> fdom(h) = {} \<Longrightarrow> (f - g) \<oplus> h = (f \<oplus> h) - g"
  by (transfer, simp add: pfun_minus_override_commute)

lemma ffun_override_minus:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> (g - f) \<oplus> f = g"
  by (transfer, simp add: pfun_override_minus)

lemma ffun_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>f f; h \<subseteq>\<^sub>f g \<rbrakk> \<Longrightarrow> (f - h = g - h) = (f = g)"
  by (transfer, simp add: pfun_minus_common_subset)

lemma ffun_minus_override:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> (f \<oplus> g) - g = f"
  by (transfer, simp add: pfun_minus_override)

lemma ffun_override_pos: "x \<oplus> y = {}\<^sub>f \<Longrightarrow> x = {}\<^sub>f"
  by (transfer, simp add: pfun_override_pos)

lemma ffun_le_override: "fdom x \<inter> fdom y = {} \<Longrightarrow> x \<le> x \<oplus> y"
  by (transfer, simp add: pfun_le_override)

subsection \<open> Membership, application, and update \<close>

lemma ffun_ext: "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>f f \<longleftrightarrow> (x, y) \<in>\<^sub>f g \<rbrakk> \<Longrightarrow> f = g"
  by (transfer, simp add: pfun_ext)

lemma ffun_member_alt_def:
  "(x, y) \<in>\<^sub>f f \<longleftrightarrow> (x \<in> fdom f \<and> f(x)\<^sub>f = y)"
  by (transfer, simp add: pfun_member_alt_def)

lemma ffun_member_override:
  "(x, y) \<in>\<^sub>f f \<oplus> g \<longleftrightarrow> ((x \<notin> fdom(g) \<and> (x, y) \<in>\<^sub>f f) \<or> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_override)

lemma ffun_member_minus:
  "(x, y) \<in>\<^sub>f f - g \<longleftrightarrow> (x, y) \<in>\<^sub>f f \<and> (\<not> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_minus)

lemma ffun_app_upd_1 [simp]: "x = y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = v"
  by (transfer, simp)

lemma ffun_app_upd_2 [simp]: "x \<noteq> y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = f(y)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_ext [simp]: "x \<in> fdom(f) \<Longrightarrow> f(x \<mapsto> f(x)\<^sub>f)\<^sub>f = f"
  by (transfer, simp)

lemma ffun_app_add [simp]: "x \<in> fdom(g) \<Longrightarrow> (f \<oplus> g)(x)\<^sub>f = g(x)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_add [simp]: "f \<oplus> g(x \<mapsto> v)\<^sub>f = (f \<oplus> g)(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_twice [simp]: "f(x \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_comm:
  assumes "x \<noteq> y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, simp add: pfun_upd_comm)

lemma ffun_upd_add_left [simp]: "x \<notin> fdom(g) \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<oplus> g = (f \<oplus> g)(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_app_add' [simp]: "\<lbrakk> e \<in> fdom f; e \<notin> fdom g \<rbrakk> \<Longrightarrow> (f \<oplus> g)(e)\<^sub>f = f(e)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_comm_linorder [simp]:
  fixes x y :: "'a :: linorder"
  assumes "x < y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, auto)

lemma ffun_app_minus [simp]: "x \<notin> fdom g \<Longrightarrow> (f - g)(x)\<^sub>f = f(x)\<^sub>f"
  by (transfer, auto)

lemma ffun_upd_minus [simp]:
  "x \<notin> fdom g \<Longrightarrow> (f - g)(x \<mapsto> v)\<^sub>f = (f(x \<mapsto> v)\<^sub>f - g)"
  by (transfer, auto)

lemma fdom_member_minus_iff [simp]:
  "x \<notin> fdom g \<Longrightarrow> x \<in> fdom(f - g) \<longleftrightarrow> x \<in> fdom(f)"
  by (transfer, simp)

lemma fsubseteq_ffun_upd1 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(g) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_ffun_upd2 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(f) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma psubseteq_pfun_upd3 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; g(x)\<^sub>f = v \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_dom_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fdom(f) \<subseteq> fdom(g)"
  by (transfer, auto simp add: psubseteq_dom_subset)

lemma fsubseteq_ran_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fran(f) \<subseteq> fran(g)"
  by (transfer, simp add: psubseteq_ran_subset)

lemma fdom_res_apply [simp]:
  "x \<in> A \<Longrightarrow> (A \<lhd>\<^sub>f f)(x)\<^sub>f = f(x)\<^sub>f"
  by (transfer, simp)

subsection \<open> Domain laws \<close>

lemma fdom_finite [simp]: "finite(fdom(f))"
  by (transfer, simp)

lemma fdom_zero [simp]: "fdom \<bottom> = {}"
  by (transfer, simp)

lemma fdom_plus [simp]: "fdom (f \<oplus> g) = fdom f \<union> fdom g"
  by (transfer, auto)

lemma fdom_inter: "fdom (f \<inter>\<^sub>f g) \<subseteq> fdom f \<inter> fdom g"
  by (transfer, meson pdom_inter)

lemma fdom_comp [simp]: "fdom (g \<circ>\<^sub>f f) = fdom (f \<rhd>\<^sub>f fdom g)"
  by (transfer, auto)

lemma fdom_upd [simp]: "fdom (f(k \<mapsto> v)\<^sub>f) = insert k (fdom f)"
  by (transfer, simp)

lemma fdom_fdom_res [simp]: "fdom (A \<lhd>\<^sub>f f) = A \<inter> fdom(f)"
  by (transfer, auto)

lemma ffun_fdom_antires_upd [simp]:
  "k \<in> A \<Longrightarrow> ((- A) \<lhd>\<^sub>f m)(k \<mapsto> v)\<^sub>f = ((- (A - {k})) \<lhd>\<^sub>f m)(k \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma fdom_res_UNIV [simp]: "UNIV \<lhd>\<^sub>f f = f"
  by (transfer, simp)

lemma fdom_graph_ffun [simp]:
  "\<lbrakk> functional R; finite (Domain R) \<rbrakk> \<Longrightarrow> fdom (graph_ffun R) = Domain R"
  by (transfer, simp add: Domain_fst graph_map_dom)

lemma pdom_pfun_of [simp]: "pdom (pfun_of f) = fdom f"
  by (transfer, simp)

lemma finite_pdom_ffun [simp]: "finite (pdom (pfun_of f))"
  by (transfer, simp)

subsection \<open> Range laws \<close>

lemma fran_zero [simp]: "fran \<bottom> = {}"
  by (transfer, simp)

lemma fran_upd [simp]: "fran (f(k \<mapsto> v)\<^sub>f) = insert v (fran ((- {k}) \<lhd>\<^sub>f f))"
  by (transfer, auto)

lemma fran_fran_res [simp]: "fran (f \<rhd>\<^sub>f A) = fran(f) \<inter> A"
  by (transfer, auto)

lemma fran_comp [simp]: "fran (g \<circ>\<^sub>f f) = fran (fran f \<lhd>\<^sub>f g)"
  by (transfer, auto)

subsection \<open> Domain restriction laws \<close>

lemma fdom_res_zero [simp]: "A \<lhd>\<^sub>f {}\<^sub>f = {}\<^sub>f"
  by (transfer, auto)

lemma fdom_res_empty [simp]:
  "({} \<lhd>\<^sub>f f) = {}\<^sub>f"
  by (transfer, auto)

lemma fdom_res_fdom [simp]:
  "fdom(f) \<lhd>\<^sub>f f = f"
  by (transfer, auto)

lemma fdom_res_upd_in [simp]:
  "k \<in> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = (A \<lhd>\<^sub>f f)(k \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fdom_res_upd_out [simp]:
  "k \<notin> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = A \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_override [simp]: "A \<lhd>\<^sub>f (f \<oplus> g) = (A \<lhd>\<^sub>f f) \<oplus> (A \<lhd>\<^sub>f g)"
  by (metis fdom_res.rep_eq pdom_res_override pfun_of_inject oplus_ffun.rep_eq)

lemma fdom_res_minus [simp]: "A \<lhd>\<^sub>f (f - g) = (A \<lhd>\<^sub>f f) - g"
  by (transfer, auto)

lemma fdom_res_swap: "(A \<lhd>\<^sub>f f) \<rhd>\<^sub>f B = A \<lhd>\<^sub>f (f \<rhd>\<^sub>f B)"
  by (transfer, simp add: pdom_res_swap)

lemma fdom_res_twice [simp]: "A \<lhd>\<^sub>f (B \<lhd>\<^sub>f f) = (A \<inter> B) \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_comp [simp]: "A \<lhd>\<^sub>f (g \<circ>\<^sub>f f) =  g \<circ>\<^sub>f (A \<lhd>\<^sub>f f)"
  by (transfer, simp)

lemma ffun_split_domain: "A \<lhd>\<^sub>f f \<oplus> (- A) \<lhd>\<^sub>f f = f"
  by (transfer, simp add: pfun_split_domain)

subsection \<open> Range restriction laws \<close>

lemma fran_res_zero [simp]: "{}\<^sub>f \<rhd>\<^sub>f A = {}\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_1 [simp]: "v \<in> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = (f \<rhd>\<^sub>f A)(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_2 [simp]: "v \<notin> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = ((- {x}) \<lhd>\<^sub>f f) \<rhd>\<^sub>f A"
  by (transfer, auto)

lemma fran_res_override: "(f \<oplus> g) \<rhd>\<^sub>f A \<subseteq>\<^sub>f (f \<rhd>\<^sub>f A) \<oplus> (g \<rhd>\<^sub>f A)"
  by (transfer, simp add: pran_res_override)

subsection \<open> Graph laws \<close>

lemma ffun_graph_inv: "graph_ffun (ffun_graph f) = f"
  by (transfer, auto simp add: pfun_graph_inv finite_Domain)

lemma ffun_graph_zero: "ffun_graph \<bottom> = {}"
  by (transfer, simp add: pfun_graph_zero)

lemma ffun_graph_minus: "ffun_graph (f - g) = ffun_graph f - ffun_graph g"
  by (transfer, simp add: pfun_graph_minus)

lemma ffun_graph_inter: "ffun_graph (f \<inter>\<^sub>f g) = ffun_graph f \<inter> ffun_graph g"
  by (transfer, simp add: pfun_graph_inter)

subsection \<open> Conversions \<close>

lift_definition list_ffun :: "'a list \<Rightarrow> nat \<Zffun> 'a" is
list_pfun by simp

lemma fdom_list_ffun [simp]: "fdom (list_ffun xs) = {1..length xs}"
  by (transfer, auto)

lemma fran_list_ffun [simp]: "fran (list_ffun xs) = set xs"
  by (transfer, simp)

lemma ffun_app_list_ffun: "\<lbrakk> 0 < i; i < length xs \<rbrakk> \<Longrightarrow> (list_ffun xs)(i)\<^sub>f = xs ! (i - 1)"
  by (transfer, simp add: pfun_app_list_pfun)

lemma range_list_ffun: "range list_ffun = {f. \<exists> i. fdom(f) = {1..i}}"
  by (transfer, auto simp add: range_list_pfun)

subsection \<open> Finite Function Lens \<close>

definition ffun_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> 'a \<Zffun> 'b)" where
[lens_defs]: "ffun_lens i = \<lparr> lens_get = \<lambda> s. s(i)\<^sub>f, lens_put = \<lambda> s v. s(i \<mapsto> v)\<^sub>f \<rparr>"

lemma ffun_lens_mwb [simp]: "mwb_lens (ffun_lens i)"
  by (unfold_locales, simp_all add: ffun_lens_def)

lemma ffun_lens_src: "\<S>\<^bsub>ffun_lens i\<^esub> = {f. i \<in> fdom(f)}"
  by (auto simp add: lens_defs lens_source_def, metis ffun_upd_ext)

subsection \<open> Notation \<close>

bundle Z_Ffun_Notation
begin

no_notation "Stream.stream.SCons" (infixr \<open>##\<close> 65)

no_notation funcset (infixr "\<rightarrow>" 60)

notation fdom_res (infixr "\<Zdres>" 86)
notation fdom_nres (infixr "\<Zndres>" 86)

notation fran_res (infixl "\<Zrres>" 86)
notation fran_nres (infixl "\<Znrres>" 86)

notation fempty ("{\<mapsto>}")

syntax "_Ffun"     :: "maplets => logic" ("(1{_})")

end

text \<open> Hide implementation details for finite functions \<close>

lifting_update ffun.lifting
lifting_forget ffun.lifting

unbundle no_lattice_syntax

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor\<close>

theory Tensor
imports Main
begin

typedef 'a tensor = "{t::nat list \<times> 'a list. length (snd t) = prod_list (fst t)}"
by (simp add: Ex_list_of_length)

definition dims::"'a tensor \<Rightarrow> nat list" where
  "dims A = fst (Rep_tensor A)"

definition vec::"'a tensor \<Rightarrow> 'a list" where
  "vec A = snd (Rep_tensor A)"

definition tensor_from_vec::"nat list \<Rightarrow> 'a list \<Rightarrow> 'a tensor" where
  "tensor_from_vec d v = Abs_tensor (d,v)"

lemma
assumes "length v = prod_list d"
shows dims_tensor[simp]: "dims (tensor_from_vec d v) = d"
and   vec_tensor[simp]:  "vec (tensor_from_vec d v) = v"
by (simp add: Abs_tensor_inverse assms dims_def tensor_from_vec_def vec_def)+

lemma tensor_from_vec_simp[simp]: "tensor_from_vec (dims A) (vec A) = A"
by (simp add: Rep_tensor_inverse Tensor.vec_def dims_def tensor_from_vec_def)

lemma length_vec: "length (vec A) = prod_list (dims A)"
by (metis (mono_tags, lifting) Rep_tensor Tensor.vec_def dims_def mem_Collect_eq)

lemma tensor_eqI[intro]:
assumes "dims A = dims B" and "vec A = vec B"
shows "A=B"
by (metis assms tensor_from_vec_simp)

abbreviation order::"'a tensor \<Rightarrow> nat" where
  "order t == length (dims t)"

inductive valid_index::"nat list \<Rightarrow> nat list \<Rightarrow> bool" (infix "\<lhd>" 50) where
  Nil: "[] \<lhd> []" |
  Cons: "is \<lhd> ds \<Longrightarrow> i<d \<Longrightarrow> i#is \<lhd> d#ds"

inductive_cases valid_indexE[elim]: "is \<lhd> ds"
inductive_cases valid_index_dimsE[elim]: "is \<lhd> dims A"

lemma valid_index_length: "is \<lhd> ds \<Longrightarrow> length is = length ds"
  by (induction rule:valid_index.induct; auto)

lemma valid_index_lt: "is \<lhd> ds \<Longrightarrow> m<length ds \<Longrightarrow> is!m < ds!m"
proof (induction arbitrary:m rule:valid_index.induct)
  case Nil
  then show ?case by auto
next
  case Cons
  then show ?case by (metis gr0_conv_Suc length_Cons linorder_neqE_nat not_less_eq nth_Cons' nth_Cons_Suc)
qed

lemma valid_indexI:
assumes "length is = length ds" and "\<And>m. m<length ds \<Longrightarrow> is!m < ds!m"
shows "is \<lhd> ds"
using assms proof (induction "is" arbitrary:ds)
  case Nil
  then show ?case by (metis length_0_conv valid_index.simps)
next
  case (Cons a "is" ds)
  then obtain d ds' where "ds = d # ds'" by (metis length_Suc_conv)
  then have "is \<lhd> ds'" using Cons by (metis length_Cons less_irrefl linorder_neqE_nat not_less_eq nth_Cons_Suc)
  then show ?case using Cons.prems(2) \<open>ds = d # ds'\<close> valid_index.Cons by fastforce
qed

lemma valid_index_append:
assumes is1_valid:"is1 \<lhd> ds1" and is2_valid:"is2 \<lhd> ds2"
shows "is1 @ is2 \<lhd> ds1 @ ds2"
  apply (rule valid_indexI[of "is1 @ is2" "ds1 @ ds2"])
  unfolding nth_append
  using valid_index_lt[OF is2_valid] valid_index_lt[OF is1_valid] valid_index_length[OF is1_valid] valid_index_length[OF is2_valid] length_append
  by (auto simp add: \<open>length is1 = length ds1\<close>)

lemma valid_index_list_all2_iff: "is \<lhd> ds \<longleftrightarrow> list_all2 (<) is ds"
by (metis list_all2_conv_all_nth list_all2_nthD valid_indexI valid_index_length valid_index_lt)

definition fixed_length_sublist::"'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
"fixed_length_sublist xs l i = (take l (drop (l*i) xs))"

fun lookup_base::"nat list \<Rightarrow> 'a list \<Rightarrow> nat list \<Rightarrow> 'a" where
  lookup_base_Nil: "lookup_base [] v [] = hd v" |
  lookup_base_Cons: "lookup_base (d # ds) v (i # is) =
    lookup_base ds (fixed_length_sublist v (prod_list ds) i) is"

definition lookup::"'a tensor \<Rightarrow> nat list \<Rightarrow> 'a" where
  "lookup A = lookup_base (dims A) (vec A)"

fun tensor_vec_from_lookup::"nat list \<Rightarrow> (nat list \<Rightarrow> 'a) \<Rightarrow> 'a list" where
  tensor_vec_from_lookup_Nil: "tensor_vec_from_lookup [] e = [e []]" |
  tensor_vec_from_lookup_Cons: "tensor_vec_from_lookup (d # ds) e = concat (map (\<lambda>i. tensor_vec_from_lookup ds (\<lambda>is. e (i # is))) [0..<d])"

definition tensor_from_lookup::"nat list \<Rightarrow> (nat list \<Rightarrow> 'a) \<Rightarrow> 'a tensor" where
  "tensor_from_lookup ds e = tensor_from_vec ds (tensor_vec_from_lookup ds e)"

lemma concat_parts_leq:
assumes "a * d \<le> length v"
shows "concat (map (fixed_length_sublist v d) [0..<a]) = take (a*d) v"
using assms proof (induction a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  then have "concat (map (fixed_length_sublist v d) [0..<a]) = take (a * d) v" by auto
  then have "concat (map (fixed_length_sublist v d) [0..<Suc a]) =
        take (a * d) v @ fixed_length_sublist v d a" using fixed_length_sublist_def by auto
  then show ?case using Suc by (metis add.commute mult.commute mult_Suc take_add fixed_length_sublist_def)
qed

lemma concat_parts_eq:
assumes "a * d = length v"
shows "concat (map (fixed_length_sublist v d) [0..<a]) = v"
by (simp add: concat_parts_leq assms)

lemma tensor_lookup_base:
assumes "length v = prod_list ds"
and "\<And>is. is \<lhd> ds \<Longrightarrow> lookup_base ds v is = e is"
shows "tensor_vec_from_lookup ds e = v"
using assms proof (induction ds arbitrary:v e)
  case Nil
  then show ?case unfolding tensor_vec_from_lookup.simps
    by (metis One_nat_def Tensor.lookup_base_Nil length_0_conv length_Suc_conv list.sel(1) prod_list.Nil valid_index.Nil)
next
  case (Cons a ds)
  then have "a * prod_list ds = length v" by auto
  {
    fix i assume "i<a"
    then have "prod_list ds * (i+1) \<le> length v" using \<open>a * prod_list ds = length v\<close> using discrete mult.commute mult_le_mono1 by metis
    have "\<And>is'. is' \<lhd> ds \<Longrightarrow> e (i # is') = lookup_base ds (fixed_length_sublist v (prod_list ds) i) is'"
      using \<open>i<a\<close> by (metis Cons.prems(2) Tensor.lookup_base_Cons valid_index.simps)
    then have "tensor_vec_from_lookup ds (\<lambda>is'. e (i # is')) = fixed_length_sublist v (prod_list ds) i"
      using Cons using \<open>prod_list ds * (i + 1) \<le> length v\<close> by (simp add: Cons.IH fixed_length_sublist_def)
  }
  then show ?case unfolding tensor_vec_from_lookup_Cons lookup_base_Cons
    using   concat_parts_eq[OF \<open>a * prod_list ds = length v\<close>]
     atLeastLessThan_iff map_eq_conv set_upt Cons by (metis (no_types, lifting))
qed

lemma tensor_lookup:
assumes "\<And>is. is \<lhd> dims A \<Longrightarrow> lookup A is = e is"
shows "tensor_from_lookup (dims A) e = A"
using tensor_lookup_base lookup_def length_vec tensor_from_lookup_def by (metis assms tensor_from_vec_simp)

lemma concat_equal_length:
assumes "\<And>xs. xs\<in>set xss \<Longrightarrow> length xs = l"
shows "length (concat xss) = length xss*l"
using assms by (induction xss;auto)

lemma concat_equal_length_map:
assumes "\<And>i. i<a \<Longrightarrow> length (f i) = d"
shows "length (concat (map (\<lambda>i. f i) [0..<a])) = a*d"
using assms by (induction a;auto)

lemma concat_parts:
assumes "\<And>xs. xs\<in>set xss \<Longrightarrow> length xs = d" and "i<length xss"
shows "fixed_length_sublist (concat xss) d i = xss ! i"
using assms proof (induction xss arbitrary:i)
  case Nil
  then show ?case by simp
next
  case (Cons xs xss)
  then have "length (concat xss) = length xss * d" by (simp add: Cons.prems(1) concat_equal_length)
  show ?case
  proof (cases i)
    case 0
    then have "fixed_length_sublist (concat (xs # xss)) d i = xs"
      unfolding fixed_length_sublist_def by (simp add: Cons.prems(1))
    then show ?thesis using 0 by auto
  next
    case (Suc i')
    then have "fixed_length_sublist (concat xss) d i' = xss ! i'" using Cons by auto
    then show ?thesis unfolding fixed_length_sublist_def using Suc Cons.prems(1) by auto
  qed
qed

lemma concat_parts':
assumes "\<And>i. i<a \<Longrightarrow> length (f i) = d"
and "i<a"
shows "fixed_length_sublist (concat (map (\<lambda>i. f i) [0..<a])) d i = f i"
using assms proof (induction a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  then have "(\<And>i. i < a \<Longrightarrow> length (f i) = d)" by auto
  then have "length (concat (map f [0..<a])) = a*d" using concat_equal_length_map by auto
  show ?case
  proof (cases "i=a")
    assume "i=a"
    then have "fixed_length_sublist (concat (map f [0..<Suc a])) d i = f a"
      by (simp add: Suc.prems(1) \<open>length (concat (map f [0..<a])) = a * d\<close> fixed_length_sublist_def)
    then show ?case using \<open>i=a\<close> by auto
  next
    assume "i\<noteq>a"
    then have "fixed_length_sublist (concat (map f [0..<a])) d i = f i"
      "concat (map f [0..<Suc a]) = concat (map f [0..<a]) @ f a" using Suc by auto
    show ?case unfolding \<open>concat (map f [0..<Suc a]) = concat (map f [0..<a]) @ f a\<close>
      unfolding fixed_length_sublist_def drop_append
      using  \<open>length (concat (map f [0..<a])) = a * d\<close>  \<open>fixed_length_sublist (concat (map f [0..<a])) d i = f i\<close>
      using append_assoc append_eq_conv_conj append_take_drop_id assms(1) assms(2)  fixed_length_sublist_def
      by metis
  qed
qed

lemma length_tensor_vec_from_lookup:
"length (tensor_vec_from_lookup ds e) = prod_list ds"
by (induction ds arbitrary:e; auto simp add: concat_equal_length_map)

lemma lookup_tensor_vec:
assumes "is\<lhd>ds"
shows "lookup_base ds (tensor_vec_from_lookup ds e) is = e is"
using assms proof (induction arbitrary:e rule:valid_index.induct)
  case Nil
  then show ?case by simp
next
  case (Cons "is" ds i d e)
  then show ?case unfolding tensor_vec_from_lookup_Cons lookup_base_Cons
    by (simp add: length_tensor_vec_from_lookup concat_parts'[of d "\<lambda>i. tensor_vec_from_lookup ds (\<lambda>is. e (i # is))" "prod_list ds" i] \<open>i < d\<close>)
qed

lemma lookup_tensor_from_lookup:
assumes "is\<lhd>ds"
shows "lookup (tensor_from_lookup ds e) is = e is"
  unfolding lookup_def tensor_from_lookup_def
  by (simp add: lookup_tensor_vec assms length_tensor_vec_from_lookup)

lemma dims_tensor_from_lookup: "dims (tensor_from_lookup ds e) = ds"
  unfolding tensor_from_lookup_def
  by (simp add: length_tensor_vec_from_lookup)

lemma tensor_lookup_cong:
assumes "tensor_from_lookup ds e\<^sub>1 = tensor_from_lookup ds e\<^sub>2"
and "is\<lhd>ds"
shows "e\<^sub>1 is = e\<^sub>2 is" using assms lookup_tensor_from_lookup by metis

lemma tensor_from_lookup_eqI:
assumes "\<And>is. is\<lhd>ds \<Longrightarrow> e\<^sub>1 is = e\<^sub>2 is"
shows "tensor_from_lookup ds e\<^sub>1 = tensor_from_lookup ds e\<^sub>2"
by (metis assms lookup_tensor_vec length_tensor_vec_from_lookup tensor_lookup_base tensor_from_lookup_def)

lemma tensor_lookup_eqI:
assumes "dims A = dims B" and "\<And>is. is\<lhd>(dims A) \<Longrightarrow> lookup A is = lookup B is"
shows "A = B" by (metis assms(1) assms(2) tensor_lookup)

end


(*  Title:      HOL/Proofs/Extraction/Greatest_Common_Divisor.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Helmut Schwichtenberg, LMU Muenchen
*)

section {* Greatest common divisor *}

theory Greatest_Common_Divisor
imports QuotRem
begin

theorem greatest_common_divisor:
  "\<And>n::nat. Suc m < n \<Longrightarrow> \<exists>k n1 m1. k * n1 = n \<and> k * m1 = Suc m \<and>
     (\<forall>l l1 l2. l * l1 = n \<longrightarrow> l * l2 = Suc m \<longrightarrow> l \<le> k)"
proof (induct m rule: nat_wf_ind)
  case (1 m n)
  from division obtain r q where h1: "n = Suc m * q + r" and h2: "r \<le> m"
    by iprover
  show ?case
  proof (cases r)
    case 0
    with h1 have "Suc m * q = n" by simp
    moreover have "Suc m * 1 = Suc m" by simp
    moreover {
      fix l2 have "\<And>l l1. l * l1 = n \<Longrightarrow> l * l2 = Suc m \<Longrightarrow> l \<le> Suc m"
        by (cases l2) simp_all }
    ultimately show ?thesis by iprover
  next
    case (Suc nat)
    with h2 have h: "nat < m" by simp
    moreover from h have "Suc nat < Suc m" by simp
    ultimately have "\<exists>k m1 r1. k * m1 = Suc m \<and> k * r1 = Suc nat \<and>
      (\<forall>l l1 l2. l * l1 = Suc m \<longrightarrow> l * l2 = Suc nat \<longrightarrow> l \<le> k)"
      by (rule 1)
    then obtain k m1 r1 where
      h1': "k * m1 = Suc m"
      and h2': "k * r1 = Suc nat"
      and h3': "\<And>l l1 l2. l * l1 = Suc m \<Longrightarrow> l * l2 = Suc nat \<Longrightarrow> l \<le> k"
      by iprover
    have mn: "Suc m < n" by (rule 1)
    from h1 h1' h2' Suc have "k * (m1 * q + r1) = n"
      by (simp add: add_mult_distrib2 mult.assoc [symmetric])
    moreover have "\<And>l l1 l2. l * l1 = n \<Longrightarrow> l * l2 = Suc m \<Longrightarrow> l \<le> k"
    proof -
      fix l l1 l2
      assume ll1n: "l * l1 = n"
      assume ll2m: "l * l2 = Suc m"
      moreover have "l * (l1 - l2 * q) = Suc nat"
        by (simp add: diff_mult_distrib2 h1 Suc [symmetric] mn ll1n ll2m [symmetric])
      ultimately show "l \<le> k" by (rule h3')
    qed
    ultimately show ?thesis using h1' by iprover
  qed
qed

extract greatest_common_divisor

text {*
The extracted program for computing the greatest common divisor is
@{thm [display] greatest_common_divisor_def}
*}

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation prod :: (default, default) default
begin

definition "default = (default, default)"

instance ..

end

instantiation "fun" :: (type, default) default
begin

definition "default = (\<lambda>x. default)"

instance ..

end

lemma "greatest_common_divisor 7 12 = (4, 3, 2)" by eval

end


theory T169
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T8
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Exe3p5
  imports Main
begin

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
s_empty: "S []" |
s_aSb: "S w \<Longrightarrow> S (a # w @ [b])" |
s_SS: "S w1 \<Longrightarrow> S w2 \<Longrightarrow> S (w1 @ w2)"

inductive T :: "alpha list \<Rightarrow> bool" where
t_empty: "T []" |
t_TaTb: "T w1 \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ [a] @ w2 @ [b])"

lemma "T w \<Longrightarrow> T (a # w @ [b])"
  apply(induction rule: T.induct)
   apply(auto simp add: t_empty t_TaTb)
  oops

lemma "T w = S w"
  apply(rule iffI)
   apply(induction rule: T.induct)
    apply(auto simp add: s_empty s_aSb s_SS)
  apply(induction rule: S.induct)
    apply(auto simp add: t_empty t_TaTb)
  oops


theory T85
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T48
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end