(*<*)
theory Table
  imports Main
begin
(*>*)

section \<open>Finite Tables\<close>

primrec tabulate :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
  "tabulate f x 0 = []"
| "tabulate f x (Suc n) = f x # tabulate f (Suc x) n"

lemma tabulate_alt: "tabulate f x n = map f [x ..< x + n]"
  by (induct n arbitrary: x) (auto simp: not_le Suc_le_eq upt_rec)

lemma length_tabulate[simp]: "length (tabulate f x n) = n"
  by (induction n arbitrary: x) simp_all

lemma map_tabulate[simp]: "map f (tabulate g x n) = tabulate (\<lambda>x. f (g x)) x n"
  by (induction n arbitrary: x) simp_all

lemma nth_tabulate[simp]: "k < n \<Longrightarrow> tabulate f x n ! k = f (x + k)"
proof (induction n arbitrary: x k)
  case (Suc n)
  then show ?case by (cases k) simp_all
qed simp

type_synonym 'a tuple = "'a option list"
type_synonym 'a table = "'a tuple set"

definition wf_tuple :: "nat \<Rightarrow> nat set \<Rightarrow> 'a tuple \<Rightarrow> bool" where
  "wf_tuple n V x \<longleftrightarrow> length x = n \<and> (\<forall>i<n. x!i = None \<longleftrightarrow> i \<notin> V)"

definition table :: "nat \<Rightarrow> nat set \<Rightarrow> 'a table \<Rightarrow> bool" where
  "table n V X \<longleftrightarrow> (\<forall>x\<in>X. wf_tuple n V x)"

definition "empty_table = {}"

definition "unit_table n = {replicate n None}"

definition "singleton_table n i x = {tabulate (\<lambda>j. if i = j then Some x else None) 0 n}"

lemma in_empty_table[simp]: "\<not> x \<in> empty_table"
  unfolding empty_table_def by simp

lemma empty_table[simp]: "table n V empty_table"
  unfolding table_def empty_table_def by simp

lemma unit_table_wf_tuple[simp]: "V = {} \<Longrightarrow> x \<in> unit_table n \<Longrightarrow> wf_tuple n V x"
  unfolding unit_table_def wf_tuple_def by simp

lemma unit_table[simp]: "V = {} \<Longrightarrow> table n V (unit_table n)"
  unfolding table_def by simp

lemma in_unit_table: "v \<in> unit_table n \<longleftrightarrow> wf_tuple n {} v"
  unfolding unit_table_def wf_tuple_def by (auto intro!: nth_equalityI)

lemma singleton_table_wf_tuple[simp]: "V = {i} \<Longrightarrow> x \<in> singleton_table n i z \<Longrightarrow> wf_tuple n V x"
  unfolding singleton_table_def wf_tuple_def by simp

lemma singleton_table[simp]: "V = {i} \<Longrightarrow> table n V (singleton_table n i z)"
  unfolding table_def by simp

lemma table_Un[simp]: "table n V X \<Longrightarrow> table n V Y \<Longrightarrow> table n V (X \<union> Y)"
  unfolding table_def by auto

lemma wf_tuple_length: "wf_tuple n V x \<Longrightarrow> length x = n"
  unfolding wf_tuple_def by simp

fun join1 :: "'a tuple \<times> 'a tuple \<Rightarrow> 'a tuple option" where
  "join1 ([], []) = Some []"
| "join1 (None # xs, None # ys) = map_option (Cons None) (join1 (xs, ys))"
| "join1 (Some x # xs, None # ys) = map_option (Cons (Some x)) (join1 (xs, ys))"
| "join1 (None # xs, Some y # ys) = map_option (Cons (Some y)) (join1 (xs, ys))"
| "join1 (Some x # xs, Some y # ys) = (if x = y
    then map_option (Cons (Some x)) (join1 (xs, ys))
    else None)"
| "join1 _ = None"

definition join :: "'a table \<Rightarrow> bool \<Rightarrow> 'a table \<Rightarrow> 'a table" where
  "join A pos B = (if pos then Option.these (join1 ` (A \<times> B))
    else A - Option.these (join1 ` (A \<times> B)))"

lemma join_True_code[code]: "join A True B = (\<Union>a \<in> A. \<Union>b \<in> B. set_option (join1 (a, b)))"
  unfolding join_def by (force simp: Option.these_def image_iff)

lemma join_False_alt: "join X False Y = X - join X True Y"
  unfolding join_def by auto

lemma join_False_code[code]: "join A False B = {a \<in> A. \<forall>b \<in> B. join1 (a, b) \<noteq> Some a}"
  unfolding join_False_alt join_True_code
  by (auto simp: Option.these_def image_iff dest: self_join1)

lemma wf_tuple_Nil[simp]: "wf_tuple n A [] = (n = 0)"
  unfolding wf_tuple_def by auto

lemma Suc_pred': "Suc (x - Suc 0) = (case x of 0 \<Rightarrow> Suc 0 | _ \<Rightarrow> x)"
  by (auto split: nat.splits)

lemma wf_tuple_Cons[simp]:
  "wf_tuple n A (x # xs) \<longleftrightarrow> ((if x = None then 0 \<notin> A else 0 \<in> A) \<and>
   (\<exists>m. n = Suc m \<and> wf_tuple m ((\<lambda>x. x - 1) ` (A - {0})) xs))"
  unfolding wf_tuple_def
  by (auto 0 3 simp: nth_Cons image_iff Ball_def gr0_conv_Suc Suc_pred' split: nat.splits)

lemma join1_wf_tuple:
  "join1 (v1, v2) = Some v \<Longrightarrow> wf_tuple n A v1 \<Longrightarrow> wf_tuple n B v2 \<Longrightarrow> wf_tuple n (A \<union> B) v"
  by (induct "(v1, v2)" arbitrary: n v v1 v2 A B rule: join1.induct)
    (auto simp: image_Un Un_Diff split: if_splits)

lemma join_wf_tuple: "x \<in> join X b Y \<Longrightarrow>
  \<forall>v \<in> X. wf_tuple n A v \<Longrightarrow> \<forall>v \<in> Y. wf_tuple n B v \<Longrightarrow> (\<not> b \<Longrightarrow> B \<subseteq> A) \<Longrightarrow> A \<union> B = C \<Longrightarrow> wf_tuple n C x"
  unfolding join_def
  by (fastforce simp: Option.these_def image_iff sup_absorb1 dest: join1_wf_tuple split: if_splits)

lemma join_table: "table n A X \<Longrightarrow> table n B Y \<Longrightarrow> (\<not> b \<Longrightarrow> B \<subseteq> A) \<Longrightarrow> A \<union> B = C \<Longrightarrow>
  table n C (join X b Y)"
  unfolding table_def by (auto elim!: join_wf_tuple)

lemma wf_tuple_Suc: "wf_tuple (Suc m) A a \<longleftrightarrow> a \<noteq> [] \<and>
   wf_tuple m ((\<lambda>x. x - 1) ` (A - {0})) (tl a) \<and> (0 \<in> A \<longleftrightarrow> hd a \<noteq> None)"
  by (cases a) (auto simp: nth_Cons image_iff split: nat.splits)

lemma table_project: "table (Suc n) A X \<Longrightarrow> table n ((\<lambda>x. x - Suc 0) ` (A - {0})) (tl ` X)"
  unfolding table_def
  by (auto simp: wf_tuple_Suc)

definition restrict where
  "restrict A v = map (\<lambda>i. if i \<in> A then v ! i else None) [0 ..< length v]"

lemma restrict_Nil[simp]: "restrict A [] = []"
  unfolding restrict_def by auto

lemma restrict_Cons[simp]: "restrict A (x # xs) =
  (if 0 \<in> A then x # restrict ((\<lambda>x. x - 1) ` (A - {0})) xs else None # restrict ((\<lambda>x. x - 1) ` A) xs)"
  unfolding restrict_def
  by (auto simp: map_upt_Suc image_iff Suc_pred' Ball_def simp del: upt_Suc split: nat.splits)

lemma wf_tuple_restrict: "wf_tuple n B v \<Longrightarrow> A \<inter> B = C \<Longrightarrow> wf_tuple n C (restrict A v)"
  unfolding restrict_def wf_tuple_def by auto

lemma wf_tuple_restrict_simple: "wf_tuple n B v \<Longrightarrow> A \<subseteq> B \<Longrightarrow> wf_tuple n A (restrict A v)"
  unfolding restrict_def wf_tuple_def by auto

lemma nth_restrict: "i \<in> A \<Longrightarrow> i < length v \<Longrightarrow> restrict A v ! i = v ! i"
  unfolding restrict_def by auto

lemma restrict_eq_Nil[simp]: "restrict A v = [] \<longleftrightarrow> v = []"
  unfolding restrict_def by auto

lemma length_restrict[simp]: "length (restrict A v) = length v"
  unfolding restrict_def by auto

lemma join1_Some_restrict:
  fixes x y :: "'a tuple"
  assumes "wf_tuple n A x" "wf_tuple n B y"
  shows "join1 (x, y) = Some z \<longleftrightarrow> wf_tuple n (A \<union> B) z \<and> restrict A z = x \<and> restrict B z = y"
  using assms
proof (induct "(x, y)" arbitrary: n x y z A B rule: join1.induct)
  case (2 xs ys)
  then show ?case
    by (cases z) (auto 4 0 simp: image_Un Un_Diff)+
next
  case (3 x xs ys)
  then show ?case
    by (cases z) (auto 4 0 simp: image_Un Un_Diff)+
next
  case (4 xs y ys)
  then show ?case
    by (cases z) (auto 4 0 simp: image_Un Un_Diff)+
next
  case (5 x xs y ys)
  then show ?case
    by (cases z) (auto 4 0 simp: image_Un Un_Diff)+
qed auto

lemma restrict_idle: "wf_tuple n A v \<Longrightarrow> restrict A v = v"
  by (induct v arbitrary: n A) (auto split: if_splits)

lemma map_the_restrict:
  "i \<in> A \<Longrightarrow> map the (restrict A v) ! i = map the v ! i"
  by (induct v arbitrary: A i) (auto simp: nth_Cons' gr0_conv_Suc split: option.splits)

lemma join_restrict_table:
  assumes "table n A X" "table n B Y" "\<not> b \<Longrightarrow> B \<subseteq> A"
  shows "v \<in> join X b Y \<longleftrightarrow>
    wf_tuple n (A \<union> B) v \<and> restrict A v \<in> X \<and> (if b then restrict B v \<in> Y else restrict B v \<notin> Y)"
  using assms unfolding table_def
  by (simp add: join_restrict)

lemma join_restrict_annotated:
  fixes X Y :: "'a tuple set"
  assumes "\<not> b =simp=> B \<subseteq> A"
  shows "join {v. wf_tuple n A v \<and> P v} b {v. wf_tuple n B v \<and> Q v} =
    {v. wf_tuple n (A \<union> B) v \<and> P (restrict A v) \<and> (if b then Q (restrict B v) else \<not> Q (restrict B v))}"
  using assms
  by (intro set_eqI, subst join_restrict) (auto simp: wf_tuple_restrict_simple simp_implies_def)

lemma in_joinI: "table n A X \<Longrightarrow> table n B Y \<Longrightarrow> (\<not>b \<Longrightarrow> B \<subseteq> A) \<Longrightarrow> wf_tuple n (A \<union> B) v \<Longrightarrow>
  restrict A v \<in> X \<Longrightarrow> (b \<Longrightarrow> restrict B v \<in> Y) \<Longrightarrow> (\<not>b \<Longrightarrow> restrict B v \<notin> Y) \<Longrightarrow> v \<in> join X b Y"
  unfolding table_def
  by (subst join_restrict) (auto)

lemma in_joinE: "v \<in> join X b Y \<Longrightarrow> table n A X \<Longrightarrow> table n B Y \<Longrightarrow> (\<not> b \<Longrightarrow> B \<subseteq> A) \<Longrightarrow>
  (wf_tuple n (A \<union> B) v \<Longrightarrow> restrict A v \<in> X \<Longrightarrow> if b then restrict B v \<in> Y else restrict B v \<notin> Y \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding table_def
  by (subst (asm) join_restrict) (auto)

definition qtable :: "nat \<Rightarrow> nat set \<Rightarrow> ('a tuple \<Rightarrow> bool) \<Rightarrow> ('a tuple \<Rightarrow> bool) \<Rightarrow>
  'a table \<Rightarrow> bool" where
  "qtable n A P Q X \<longleftrightarrow> table n A X \<and> (\<forall>x. (x \<in> X \<and> P x \<longrightarrow> Q x) \<and> (wf_tuple n A x \<and> P x \<and> Q x \<longrightarrow> x \<in> X))"

abbreviation wf_table where
  "wf_table n A Q X \<equiv> qtable n A (\<lambda>_. True) Q X"

lemma wf_table_iff: "wf_table n A Q X \<longleftrightarrow> (\<forall>x. x \<in> X \<longleftrightarrow> (Q x \<and> wf_tuple n A x))"
  unfolding qtable_def table_def by auto

lemma table_wf_table: "table n A X = wf_table n A (\<lambda>v. v \<in> X) X"
  unfolding table_def wf_table_iff by auto

lemma qtableI: "table n A X \<Longrightarrow>
  (\<And>x. x \<in> X \<Longrightarrow> wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow>
  (\<And>x. wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x \<Longrightarrow> x \<in> X) \<Longrightarrow>
  qtable n A P Q X"
  unfolding qtable_def table_def by auto

lemma in_qtableI: "qtable n A P Q X \<Longrightarrow> wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x \<Longrightarrow> x \<in> X"
  unfolding qtable_def by blast

lemma in_qtableE: "qtable n A P Q X \<Longrightarrow> x \<in> X \<Longrightarrow> P x \<Longrightarrow> (wf_tuple n A x \<Longrightarrow> Q x \<Longrightarrow> R) \<Longrightarrow> R"
  unfolding qtable_def table_def by blast

lemma qtable_empty: "(\<And>x. wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x \<Longrightarrow> False) \<Longrightarrow> qtable n A P Q empty_table"
  unfolding qtable_def table_def empty_table_def by auto

lemma qtable_empty_iff: "qtable n A P Q empty_table = (\<forall>x. wf_tuple n A x \<longrightarrow> P x \<longrightarrow> Q x \<longrightarrow> False)"
  unfolding qtable_def table_def empty_table_def by auto

lemma qtable_unit_table: "(\<And>x. wf_tuple n {} x \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> qtable n {} P Q (unit_table n)"
  unfolding qtable_def table_def in_unit_table by auto

lemma qtable_union: "qtable n A P Q1 X \<Longrightarrow> qtable n A P Q2 Y \<Longrightarrow>
  (\<And>x. wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x \<longleftrightarrow> Q1 x \<or> Q2 x) \<Longrightarrow> qtable n A P Q (X \<union> Y)"
  unfolding qtable_def table_def by blast

lemma qtable_Union: "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> qtable n A P (Qi i) (Xi i)) \<Longrightarrow>
  (\<And>x. wf_tuple n A x \<Longrightarrow> P x \<Longrightarrow> Q x \<longleftrightarrow> (\<exists>i \<in> I. Qi i x)) \<Longrightarrow> qtable n A P Q (\<Union>i \<in> I. Xi i)"
proof (induct I arbitrary: Q rule: finite_induct)
  case (insert i F)
  then show ?case
    by (auto intro!: qtable_union[where ?Q1.0 = "Qi i" and ?Q2.0 = "\<lambda>x. \<exists>i\<in>F. Qi i x"])
qed (auto intro!: qtable_empty[unfolded empty_table_def])

lemma qtable_join:
  assumes "qtable n A P Q1 X" "qtable n B P Q2 Y" "\<not> b \<Longrightarrow> B \<subseteq> A" "C = A \<union> B"
  "\<And>x. wf_tuple n C x \<Longrightarrow> P x \<Longrightarrow> P (restrict A x) \<and> P (restrict B x)"
  "\<And>x. b \<Longrightarrow> wf_tuple n C x \<Longrightarrow> P x \<Longrightarrow> Q x \<longleftrightarrow> Q1 (restrict A x) \<and> Q2 (restrict B x)"
  "\<And>x. \<not> b \<Longrightarrow> wf_tuple n C x \<Longrightarrow> P x \<Longrightarrow> Q x \<longleftrightarrow> Q1 (restrict A x) \<and> \<not> Q2 (restrict B x)"
  shows "qtable n C P Q (join X b Y)"
proof (rule qtableI)
  from assms(1-4) show "table n C (join X b Y)"
    unfolding qtable_def by (auto simp: join_table)
next
  fix x assume "x \<in> join X b Y" "wf_tuple n C x" "P x"
  with assms(1-3) assms(5-7)[of x] show "Q x" unfolding qtable_def
    by (auto 0 2 simp: wf_tuple_restrict_simple elim!: in_joinE split: if_splits)
next
  fix x assume "wf_tuple n C x" "P x" "Q x"
  with assms(1-4) assms(5-7)[of x] show "x \<in> join X b Y" unfolding qtable_def
    by (auto dest: wf_tuple_restrict_simple intro!: in_joinI[of n A X B Y])
qed

lemma qtable_join_fixed:
  assumes "qtable n A P Q1 X" "qtable n B P Q2 Y" "\<not> b \<Longrightarrow> B \<subseteq> A" "C = A \<union> B"
  "\<And>x. wf_tuple n C x \<Longrightarrow> P x \<Longrightarrow> P (restrict A x) \<and> P (restrict B x)"
  shows "qtable n C P (\<lambda>x. Q1 (restrict A x) \<and> (if b then Q2 (restrict B x) else \<not> Q2 (restrict B x))) (join X b Y)"
  by (rule qtable_join[OF assms]) auto

lemma wf_tuple_cong:
  assumes "wf_tuple n A v" "wf_tuple n A w" "\<forall>x \<in> A. map the v ! x = map the w ! x"
  shows "v = w"
proof -
  from assms(1,2) have "length v = length w" unfolding wf_tuple_def by simp
  from this assms show "v = w"
  proof (induct v w arbitrary: n A rule: list_induct2)
    case (Cons x xs y ys)
    let ?n = "n - 1" and ?A = "(\<lambda>x. x - 1) ` (A - {0})"
    have *: "map the xs ! z = map the ys ! z" if "z \<in> ?A" for z
      using that Cons(5)[THEN bspec, of "Suc z"]
      by (cases z) (auto simp: le_Suc_eq split: if_splits)
    from Cons(1,3-5) show ?case
      by (auto intro!: Cons(2)[of ?n ?A] * split: if_splits)
  qed simp
qed

definition mem_restr :: "'a list set \<Rightarrow> 'a tuple \<Rightarrow> bool" where
  "mem_restr A x \<longleftrightarrow> (\<exists>y\<in>A. list_all2 (\<lambda>a b. a \<noteq> None \<longrightarrow> a = Some b) x y)"

lemma mem_restrI: "y \<in> A \<Longrightarrow> length y = n \<Longrightarrow> wf_tuple n V x \<Longrightarrow> \<forall>i\<in>V. x ! i = Some (y ! i) \<Longrightarrow> mem_restr A x"
  unfolding mem_restr_def wf_tuple_def by (force simp add: list_all2_conv_all_nth)

lemma mem_restrE: "mem_restr A x \<Longrightarrow> wf_tuple n V x \<Longrightarrow> \<forall>i\<in>V. i < n \<Longrightarrow>
  (\<And>y. y \<in> A \<Longrightarrow> \<forall>i\<in>V. x ! i = Some (y ! i) \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding mem_restr_def wf_tuple_def by (fastforce simp add: list_all2_conv_all_nth)

lemma mem_restr_IntD: "mem_restr (A \<inter> B) v \<Longrightarrow> mem_restr A v \<and> mem_restr B v"
  unfolding mem_restr_def by auto

lemma mem_restr_Un_iff: "mem_restr (A \<union> B) x \<longleftrightarrow> mem_restr A x \<or> mem_restr B x"
  unfolding mem_restr_def by blast

lemma mem_restr_UNIV [simp]: "mem_restr UNIV x"
  unfolding mem_restr_def
  by (auto simp add: list.rel_map intro!: exI[of _ "map the x"] list.rel_refl)

lemma restrict_mem_restr[simp]: "mem_restr A x \<Longrightarrow> mem_restr A (restrict V x)"
  unfolding mem_restr_def restrict_def
  by (auto simp: list_all2_conv_all_nth elim!: bexI[rotated])

definition lift_envs :: "'a list set \<Rightarrow> 'a list set" where
  "lift_envs R = (\<lambda>(a,b). a # b) ` (UNIV \<times> R)"

lemma lift_envs_mem_restr[simp]: "mem_restr A x \<Longrightarrow> mem_restr (lift_envs A) (a # x)"
  by (auto simp: mem_restr_def lift_envs_def)

lemma qtable_project:
  assumes "qtable (Suc n) A (mem_restr (lift_envs R)) P X"
  shows "qtable n ((\<lambda>x. x - Suc 0) ` (A - {0})) (mem_restr R)
      (\<lambda>v. \<exists>x. P ((if 0 \<in> A then Some x else None) # v)) (tl ` X)"
      (is "qtable n ?A (mem_restr R) ?P ?X")
proof ((rule qtableI; (elim exE)?), goal_cases table left right)
  case table
  with assms show ?case
    unfolding qtable_def by (simp add: table_project)
next
  case (left v)
  from assms have "[] \<notin> X"
    unfolding qtable_def table_def by fastforce
  with left(1) obtain x where "x # v \<in> X"
    by (metis (no_types, hide_lams) image_iff hd_Cons_tl)
  with assms show ?case
    by (rule in_qtableE) (auto simp: left(3) split: if_splits)
next
  case (right v x)
  with assms have "(if 0 \<in> A then Some x else None) # v \<in> X"
    by (elim in_qtableI) auto
  then show ?case
    by (auto simp: image_iff elim: bexI[rotated])
qed

lemma qtable_cong: "qtable n A P Q X \<Longrightarrow> A = B \<Longrightarrow> (\<And>v. P v \<Longrightarrow> Q v \<longleftrightarrow> Q' v) \<Longrightarrow> qtable n B P Q' X"
  by (auto simp: qtable_def)

(*<*)
end
(*>*)


(*  Title:      ZF/AC/WO1_WO7.thy
    Author:     Lawrence C Paulson, CU Computer Laboratory
    Copyright   1998  University of Cambridge

WO7 \<longleftrightarrow> LEMMA \<longleftrightarrow> WO1 (Rubin & Rubin p. 5)
LEMMA is the sentence denoted by (**)

Also, WO1 \<longleftrightarrow> WO8
*)

theory WO1_WO7
imports AC_Equiv
begin

definition
    "LEMMA \<equiv>
     \<forall>X. \<not>Finite(X) \<longrightarrow> (\<exists>R. well_ord(X,R) \<and> \<not>well_ord(X,converse(R)))"

(* ********************************************************************** *)
(* It is easy to see that WO7 is equivalent to (**)                       *)
(* ********************************************************************** *)

lemma WO7_iff_LEMMA: "WO7 \<longleftrightarrow> LEMMA"
  unfolding WO7_def LEMMA_def
apply (blast intro: Finite_well_ord_converse)
done

(* ********************************************************************** *)
(* It is also easy to show that LEMMA implies WO1.                        *)
(* ********************************************************************** *)

lemma LEMMA_imp_WO1: "LEMMA \<Longrightarrow> WO1"
  unfolding WO1_def LEMMA_def Finite_def eqpoll_def
apply (blast intro!: well_ord_rvimage [OF bij_is_inj nat_implies_well_ord])
done

(* ********************************************************************** *)
(* The Rubins' proof of the other implication is contained within the     *)
(* following sentence \<in>                                                   *)
(* "... each infinite ordinal is well ordered by < but not by >."         *)
(* This statement can be proved by the following two theorems.            *)
(* But moreover we need to show similar property for any well ordered     *)
(* infinite set. It is not very difficult thanks to Isabelle order types  *)
(* We show that if a set is well ordered by some relation and by its     *)
(* converse, then apropriate order type is well ordered by the converse   *)
(* of it's membership relation, which in connection with the previous     *)
(* gives the conclusion.                                                  *)
(* ********************************************************************** *)

lemma converse_Memrel_not_wf_on:
    "\<lbrakk>Ord(a); \<not>Finite(a)\<rbrakk> \<Longrightarrow> \<not>wf[a](converse(Memrel(a)))"
  unfolding wf_on_def wf_def
apply (drule nat_le_infinite_Ord [THEN le_imp_subset], assumption)
apply (rule notI)
apply (erule_tac x = nat in allE, blast)
done

lemma converse_Memrel_not_well_ord:
    "\<lbrakk>Ord(a); \<not>Finite(a)\<rbrakk> \<Longrightarrow> \<not>well_ord(a,converse(Memrel(a)))"
  unfolding well_ord_def
apply (blast dest: converse_Memrel_not_wf_on)
done

lemma well_ord_rvimage_ordertype:
     "well_ord(A,r) \<Longrightarrow>
       rvimage (ordertype(A,r), converse(ordermap(A,r)),r) =
       Memrel(ordertype(A,r))"
by (blast intro: ordertype_ord_iso [THEN ord_iso_sym] ord_iso_rvimage_eq
             Memrel_type [THEN subset_Int_iff [THEN iffD1]] trans)

lemma well_ord_converse_Memrel:
     "\<lbrakk>well_ord(A,r); well_ord(A,converse(r))\<rbrakk>
      \<Longrightarrow> well_ord(ordertype(A,r), converse(Memrel(ordertype(A,r))))"
apply (subst well_ord_rvimage_ordertype [symmetric], assumption)
apply (rule rvimage_converse [THEN subst])
apply (blast intro: ordertype_ord_iso ord_iso_sym ord_iso_is_bij
                    bij_is_inj well_ord_rvimage)
done

lemma WO1_imp_LEMMA: "WO1 \<Longrightarrow> LEMMA"
apply (unfold WO1_def LEMMA_def, clarify)
apply (blast dest: well_ord_converse_Memrel
                   Ord_ordertype [THEN converse_Memrel_not_well_ord]
             intro: ordertype_ord_iso ord_iso_is_bij bij_is_inj lepoll_Finite
                    lepoll_def [THEN def_imp_iff, THEN iffD2] )
done

lemma WO1_iff_WO7: "WO1 \<longleftrightarrow> WO7"
apply (simp add: WO7_iff_LEMMA)
apply (blast intro: LEMMA_imp_WO1 WO1_imp_LEMMA)
done

(* ********************************************************************** *)
(*            The proof of WO8 \<longleftrightarrow> WO1 (Rubin & Rubin p. 6)               *)
(* ********************************************************************** *)

lemma WO1_WO8: "WO1 \<Longrightarrow> WO8"
by (unfold WO1_def WO8_def, fast)

(* The implication "WO8 \<Longrightarrow> WO1": a faithful image of Rubin & Rubin's proof*)
lemma WO8_WO1: "WO8 \<Longrightarrow> WO1"
  unfolding WO1_def WO8_def
apply (rule allI)
apply (erule_tac x = "{{x}. x \<in> A}" in allE)
apply (erule impE)
 apply (rule_tac x = "\<lambda>a \<in> {{x}. x \<in> A}. THE x. a={x}" in exI)
 apply (force intro!: lam_type simp add: singleton_eq_iff the_equality)
apply (blast intro: lam_sing_bij bij_is_inj well_ord_rvimage)
done

end


theory Circlines_Angle
  imports Oriented_Circlines Elementary_Complex_Geometry
begin

(* ----------------------------------------------------------------- *)
subsection \<open>Angle between circlines\<close>
(* ----------------------------------------------------------------- *)

text \<open>Angle between circlines can be defined in purely algebraic terms (following Schwerdtfeger
\cite{schwerdtfeger}) and using this definitions many properties can be easily proved.\<close>

fun mat_det_12 :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex" where
  "mat_det_12 (A1, B1, C1, D1) (A2, B2, C2, D2) = A1*D2 + A2*D1 - B1*C2 - B2*C1"

lemma mat_det_12_mm_l [simp]:
  shows "mat_det_12 (M *\<^sub>m\<^sub>m A) (M *\<^sub>m\<^sub>m B) = mat_det M * mat_det_12 A B"
  by (cases M, cases A, cases B) (simp add: field_simps)

lemma mat_det_12_mm_r [simp]:
  shows "mat_det_12 (A *\<^sub>m\<^sub>m M) (B *\<^sub>m\<^sub>m M) = mat_det M * mat_det_12 A B"
  by (cases M, cases A, cases B) (simp add: field_simps)

lemma mat_det_12_sm_l [simp]:
  shows "mat_det_12 (k *\<^sub>s\<^sub>m A) B = k * mat_det_12 A B"
  by (cases A, cases B) (simp add: field_simps)

lemma mat_det_12_sm_r [simp]:
  shows "mat_det_12 A (k *\<^sub>s\<^sub>m B) = k * mat_det_12 A B"
  by (cases A, cases B) (simp add: field_simps)

lemma mat_det_12_congruence [simp]:
  shows "mat_det_12 (congruence M A) (congruence M B) = (cor ((cmod (mat_det M))\<^sup>2)) * mat_det_12 A B"
  unfolding congruence_def
  by ((subst mult_mm_assoc[symmetric])+, subst mat_det_12_mm_l, subst mat_det_12_mm_r, subst mat_det_adj) (auto simp add: field_simps complex_mult_cnj_cmod)

definition cos_angle_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> real" where
  [simp]: "cos_angle_cmat H1 H2 = - Re (mat_det_12 H1 H2) / (2 * (sqrt (Re (mat_det H1 * mat_det H2))))"

lift_definition cos_angle_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> real" is cos_angle_cmat
  done

lemma cos_angle_den_scale [simp]:
  assumes "k1 > 0" and "k2 > 0"
  shows "sqrt (Re ((k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2))) =
         k1 * k2 * sqrt (Re (mat_det H1 * mat_det H2))"
proof-
  let ?lhs = "(k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2)"
  let ?rhs = "mat_det H1 * mat_det H2"
  have 1: "?lhs = (k1\<^sup>2*k2\<^sup>2) * ?rhs"
    by simp
  hence "Re ?lhs = (k1\<^sup>2*k2\<^sup>2) * Re ?rhs"
    by (simp add: field_simps)
  thus ?thesis
    using assms
    by (simp add: real_sqrt_mult)
qed

lift_definition cos_angle :: "ocircline \<Rightarrow> ocircline \<Rightarrow> real" is cos_angle_clmat
proof transfer
  fix H1 H2 H1' H2'
  assume "ocircline_eq_cmat H1 H1'" "ocircline_eq_cmat H2 H2'"
  then obtain k1 k2 :: real where
  *:  "k1 > 0" "H1' = cor k1 *\<^sub>s\<^sub>m H1"
      "k2 > 0" "H2' = cor k2 *\<^sub>s\<^sub>m H2"
    by auto
  thus "cos_angle_cmat H1 H2 = cos_angle_cmat H1' H2'"
    unfolding cos_angle_cmat_def
    apply (subst *)+
    apply (subst mat_det_12_sm_l, subst mat_det_12_sm_r)
    apply (subst mat_det_mult_sm)+
    apply (subst power2_eq_square[symmetric])+
    apply (subst cos_angle_den_scale, simp, simp)
    apply simp
    done
qed

text \<open>Möbius transformations are conformal, meaning that they preserve oriented angle between
oriented circlines.\<close>

lemma cos_angle_opposite1 [simp]:
  shows "cos_angle (opposite_ocircline H) H' = - cos_angle H H'"
  by (transfer, transfer, simp)

lemma cos_angle_opposite2 [simp]:
  shows "cos_angle H (opposite_ocircline H') = - cos_angle H H'"
  by (transfer, transfer, simp)

(* ----------------------------------------------------------------- *)
subsubsection \<open>Connection with the elementary angle definition between circles\<close>
(* ----------------------------------------------------------------- *)

text\<open>We want to connect algebraic definition of an angle with a traditional one and
to prove equivalency between these two definitions. For the traditional definition of
an angle we follow the approach suggested by Needham \cite{needham}.\<close>

lemma Re_mult_real3:
  assumes "is_real z1" and "is_real z2" and "is_real z3"
  shows "Re (z1 * z2 * z3) = Re z1 * Re z2 * Re z3"
  using assms
  by (metis Re_mult_real mult_reals)

lemma sgn_sqrt [simp]:
  shows "sgn (sqrt x) = sgn x"
  by (simp add: sgn_root sqrt_def)

lemma real_circle_sgn_r:
  assumes "is_circle H" and "(a, r) = euclidean_circle H"
  shows "sgn r = - circline_type H"
  using assms
proof (transfer, transfer)
  fix H :: complex_mat and a r
  assume hh: "hermitean H \<and> H \<noteq> mat_zero"
  obtain A B C D where HH: "H = (A, B, C, D)"
    by (cases H) auto
  hence "is_real A" "is_real D"
    using hermitean_elems hh
    by auto
  assume "\<not> circline_A0_cmat H" "(a, r) = euclidean_circle_cmat H"
  hence "A \<noteq> 0"
    using \<open>\<not> circline_A0_cmat H\<close> HH
    by simp
  hence "Re A * Re A > 0"
    using \<open>is_real A\<close>
    using complex_eq_if_Re_eq not_real_square_gt_zero
    by fastforce
  thus "sgn r = - circline_type_cmat H"
    using HH \<open>(a, r) = euclidean_circle_cmat H\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0\<close>
    by (simp add: Re_divide_real sgn_minus[symmetric])
qed

text \<open>The definition of an angle using algebraic terms is not intuitive, and we want to connect it to
the more common definition given earlier that defines an
angle between circlines as the angle between tangent vectors in the point of the intersection of the
circlines.\<close>

lemma cos_angle_eq_cos_ang_circ:
  assumes
  "is_circle (of_ocircline H1)" and "is_circle (of_ocircline H2)" and
  "circline_type (of_ocircline H1) < 0" and "circline_type (of_ocircline H2) < 0"
  "(a1, r1) = euclidean_circle (of_ocircline H1)" and "(a2, r2) = euclidean_circle (of_ocircline H2)" and
  "of_complex E \<in> ocircline_set H1 \<inter> ocircline_set H2"
  shows "cos_angle H1 H2 = cos (ang_circ E a1 a2 (pos_oriented H1) (pos_oriented H2))"
proof-
  let ?p1 = "pos_oriented H1" and ?p2 = "pos_oriented H2"
  have "E \<in> circle a1 r1" "E \<in> circle a2 r2"
    using classic_circle[of "of_ocircline H1" a1 r1]  classic_circle[of "of_ocircline H2" a2 r2]
    using assms of_complex_inj
    by auto
  hence *: "cdist E a1 = r1" "cdist E a2 = r2"
    unfolding circle_def
    by (simp_all add: norm_minus_commute)
  have "r1 > 0" "r2 > 0"
    using assms(1-6) real_circle_sgn_r[of "of_ocircline H1" a1 r1]  real_circle_sgn_r[of "of_ocircline H2" a2 r2]
    using sgn_greater
    by fastforce+
  hence "E \<noteq> a1" "E \<noteq> a2"
    using \<open>cdist E a1 = r1\<close> \<open>cdist E a2 = r2\<close>
    by auto

  let ?k = "sgn_bool (?p1 = ?p2)"
  let ?xx = "?k * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) / (2 * r1 * r2)"

  have "cos (ang_circ E a1 a2 ?p1 ?p2) = ?xx"
    using law_of_cosines[of a2 a1 E] * \<open>r1 > 0\<close> \<open>r2 > 0\<close> cos_ang_circ_simp[OF \<open>E \<noteq> a1\<close> \<open>E \<noteq> a2\<close>]
    by (subst (asm) ang_vec_opposite_opposite'[OF \<open>E \<noteq> a1\<close>[symmetric] \<open>E \<noteq> a2\<close>[symmetric], symmetric]) simp
  moreover
  have "cos_angle H1 H2 = ?xx"
    using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
    using \<open>(a1, r1) = euclidean_circle (of_ocircline H1)\<close> \<open>(a2, r2) = euclidean_circle (of_ocircline H2)\<close>
    using \<open>is_circle (of_ocircline H1)\<close> \<open>is_circle (of_ocircline H2)\<close>
    using \<open>circline_type (of_ocircline H1) < 0\<close> \<open>circline_type (of_ocircline H2) < 0\<close>
  proof (transfer, transfer)
    fix a1 r1 H1 H2 a2 r2
    assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
    obtain A1 B1 C1 D1 where HH1: "H1 = (A1, B1, C1, D1)"
      by (cases H1) auto
    obtain A2 B2 C2 D2 where HH2: "H2 = (A2, B2, C2, D2)"
      by (cases H2) auto
    have *: "is_real A1" "is_real A2" "is_real D1" "is_real D2" "cnj B1 = C1" "cnj B2 = C2"
      using hh hermitean_elems[of A1 B1 C1 D1] hermitean_elems[of A2 B2 C2 D2] HH1 HH2
      by auto
    have "cnj A1 = A1" "cnj A2 = A2"
      using \<open>is_real A1\<close> \<open>is_real A2\<close>
      by (case_tac[!] A1, case_tac[!] A2, auto simp add: Complex_eq)

    assume "\<not> circline_A0_cmat (id H1)" "\<not> circline_A0_cmat (id H2)"
    hence "A1 \<noteq> 0" "A2 \<noteq> 0"
      using HH1 HH2
      by auto
    hence "Re A1 \<noteq> 0" "Re A2 \<noteq> 0"
      using \<open>is_real A1\<close> \<open>is_real A2\<close>
      using complex.expand
      by auto

    assume "circline_type_cmat (id H1) < 0" "circline_type_cmat (id H2) < 0"
    assume "(a1, r1) = euclidean_circle_cmat (id H1)" "(a2, r2) = euclidean_circle_cmat (id H2)"
    assume "r1 > 0" "r2 > 0"

    let ?D12 = "mat_det_12 H1 H2" and ?D1 = "mat_det H1" and ?D2 = "mat_det H2"
    let ?x1 = "(cdist a2 a1)\<^sup>2 - r1\<^sup>2 - r2\<^sup>2" and ?x2 = "2*r1*r2"
    let ?x = "?x1 / ?x2"
    have *:  "Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2)))) = Re (sgn A1) * Re (sgn A2) * ?x"
    proof-
      let ?M1 = "(A1, B1, C1, D1)" and ?M2 = "(A2, B2, C2, D2)"
      let ?d1 = "B1 * C1 - A1 * D1" and ?d2 = "B2 * C2 - A2 * D2"
      have "Re ?d1 > 0" "Re ?d2 > 0"
        using HH1 HH2 \<open>circline_type_cmat (id H1) < 0\<close>  \<open>circline_type_cmat (id H2) < 0\<close>
        by auto
      hence **: "Re (?d1 / (A1 * A1)) > 0" "Re (?d2 / (A2 * A2)) > 0"
        using \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
        by (subst Re_divide_real, simp_all add: complex_neq_0 power2_eq_square)+
      have ***: "is_real (?d1 / (A1 * A1)) \<and> is_real (?d2 / (A2 * A2))"
        using \<open>is_real A1\<close>  \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj B1 = C1\<close>[symmetric] \<open>cnj B2 = C2\<close>[symmetric] \<open>is_real D1\<close> \<open>is_real D2\<close>
        by (subst div_reals, simp, simp, simp)+

      have "cor ?x = mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
      proof-
        have "A1*A2*cor ?x1 = mat_det_12 ?M1 ?M2"
        proof-
          have 1: "A1*A2*(cor ((cdist a2 a1)\<^sup>2)) = ((B2*A1 - A2*B1)*(C2*A1 - C1*A2)) / (A1*A2)"
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
            unfolding cdist_def cmod_square
            using HH1 HH2 * \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj A1 = A1\<close> \<open>cnj A2 = A2\<close>
            unfolding Let_def
            apply (subst complex_of_real_Re)
            apply (simp add: field_simps)
            apply (simp add: complex_mult_cnj_cmod power2_eq_square)
            apply (simp add: field_simps)
            done
          have 2: "A1*A2*cor (-r1\<^sup>2) = A2*D1 - B1*C1*A2/A1"
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close>
            using HH1 ** * *** \<open>A1 \<noteq> 0\<close>
            by (simp add: power2_eq_square field_simps)
          have 3: "A1*A2*cor (-r2\<^sup>2) = A1*D2 - B2*C2*A1/A2"
            using \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
            using HH2 ** * *** \<open>A2 \<noteq> 0\<close>
            by (simp add: power2_eq_square field_simps)
          have "A1*A2*cor((cdist a2 a1)\<^sup>2) + A1*A2*cor(-r1\<^sup>2) + A1*A2*cor(-r2\<^sup>2) = mat_det_12 ?M1 ?M2"
            using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
            by (subst 1, subst 2, subst 3) (simp add: field_simps)
          thus ?thesis
            by (simp add: field_simps)
        qed

        moreover

        have "A1 * A2 * cor (?x2) = 2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2))"
        proof-
          have 1: "sqrt (Re (?d1/ (A1 * A1))) = sqrt (Re ?d1) / \<bar>Re A1\<bar>"
            using \<open>A1 \<noteq> 0\<close> \<open>is_real A1\<close>
            by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)

          have 2: "sqrt (Re (?d2/ (A2 * A2))) = sqrt (Re ?d2) / \<bar>Re A2\<bar>"
            using \<open>A2 \<noteq> 0\<close> \<open>is_real A2\<close>
            by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)
          have "sgn A1 = A1 / cor \<bar>Re A1\<bar>"
            using \<open>is_real A1\<close>
            unfolding sgn_eq
            by (simp add: cmod_eq_Re)
          moreover
          have "sgn A2 = A2 / cor \<bar>Re A2\<bar>"
            using \<open>is_real A2\<close>
            unfolding sgn_eq
            by (simp add: cmod_eq_Re)
          ultimately
          show ?thesis
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>  HH1 HH2
            using *** \<open>is_real A1\<close> \<open>is_real A2\<close>
            by simp (subst 1, subst 2, simp)
        qed

        ultimately

        have "(A1 * A2 * cor ?x1) / (A1 * A2 * (cor ?x2)) =
               mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
          by simp
        thus ?thesis
          using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
          by simp
      qed
      hence "cor ?x * sgn A1 * sgn A2 = mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
        using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
        by (simp add: sgn_zero_iff)
      moreover
      have "Re (cor ?x * sgn A1 * sgn A2) = Re (sgn A1) * Re (sgn A2) * ?x"
      proof-
        have "is_real (cor ?x)" "is_real (sgn A1)" "is_real (sgn A2)"
          using \<open>is_real A1\<close> \<open>is_real A2\<close> Im_complex_of_real[of ?x]
          by auto
        thus ?thesis
          using Re_complex_of_real[of ?x]
          by (subst Re_mult_real3, auto simp add: field_simps)
      qed
      moreover
      have *: "sqrt (Re ?D1) * sqrt (Re ?D2) = sqrt (Re ?d1) * sqrt (Re ?d2)"
        using HH1 HH2
        by (subst real_sqrt_mult[symmetric])+ (simp add: field_simps)
      have "2 * (sqrt (Re (?D1 * ?D2))) \<noteq> 0"
        using \<open>Re ?d1 > 0\<close>  \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close>  \<open>is_real D1\<close> \<open>is_real D2\<close>
        using hh mat_det_hermitean_real[of "H1"]
        by (subst Re_mult_real, auto)
      hence **: "Re (?D12 / (2 * cor (sqrt (Re (?D1 * ?D2))))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
        using \<open>Re ?d1 > 0\<close>  \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close>  \<open>is_real D1\<close> \<open>is_real D2\<close>
        by (subst Re_divide_real) auto
      have "Re (mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
        using HH1 HH2 hh mat_det_hermitean_real[of "H1"]
        by (subst **[symmetric], subst Re_mult_real, simp, subst real_sqrt_mult, subst *, simp)
      ultimately
      show ?thesis
        by simp
    qed
    have **: "pos_oriented_cmat H1 \<longleftrightarrow> Re A1 > 0"  "pos_oriented_cmat H2 \<longleftrightarrow> Re A2 > 0"
      using \<open>Re A1 \<noteq> 0\<close> HH1  \<open>Re A2 \<noteq> 0\<close> HH2
      by auto
    show "cos_angle_cmat H1 H2 = sgn_bool (pos_oriented_cmat H1 = pos_oriented_cmat H2) * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) /  (2 * r1 * r2)"
      unfolding Let_def
      using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
      unfolding cos_angle_cmat_def
      apply (subst divide_minus_left)
      apply (subst *)
      apply (subst Re_sgn[OF \<open>is_real A1\<close> \<open>A1 \<noteq> 0\<close>], subst Re_sgn[OF \<open>is_real A2\<close> \<open>A2 \<noteq> 0\<close>])
      apply (subst **, subst **)
      apply (simp add: field_simps)
      done
  qed
  ultimately
  show ?thesis
    by simp
qed

(* ----------------------------------------------------------------- *)
subsection \<open>Perpendicularity\<close>
(* ----------------------------------------------------------------- *)

text \<open>Two circlines are perpendicular if the intersect at right angle i.e., the angle with the cosine
0.\<close>

definition perpendicular where
  "perpendicular H1 H2 \<longleftrightarrow> cos_angle (of_circline H1) (of_circline H2) = 0"

lemma perpendicular_sym:
  shows "perpendicular H1 H2 \<longleftrightarrow> perpendicular H2 H1"
  unfolding perpendicular_def
  by (transfer, transfer, auto simp add: field_simps)

(* ----------------------------------------------------------------- *)
subsection \<open>Möbius transforms preserve angles and perpendicularity\<close>
(* ----------------------------------------------------------------- *)

text \<open>Möbius transformations are \emph{conformal} i.e., they preserve angles between circlines.\<close>

lemma perpendicular_moebius [simp]:
  assumes "perpendicular H1 H2"
  shows "perpendicular (moebius_circline M H1) (moebius_circline M H2)"
  using assms
  unfolding perpendicular_def
  using moebius_preserve_circline_angle[of M "of_circline H1" "of_circline H2"]
  using moebius_ocircline_circline[of M "of_circline H1"]
  using moebius_ocircline_circline[of M "of_circline H2"]
  by (auto simp del: moebius_preserve_circline_angle)

end


subsection \<open>The Knapsack Problem\<close>

theory Knapsack
  imports
    "HOL-Library.Code_Target_Numeral"
    "../state_monad/State_Main"
    "../heap_monad/Heap_Default"
    Example_Misc
begin

subsubsection \<open>Definitions\<close>

context (* Subset Sum *)
  fixes w :: "nat \<Rightarrow> nat"
begin

context (* Knapsack *)
  fixes v :: "nat \<Rightarrow> nat"
begin

fun knapsack :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "knapsack 0 W = 0" |
  "knapsack (Suc i) W = (if W < w (Suc i)
    then knapsack i W
    else max (knapsack i W) (v (Suc i) + knapsack i (W - w (Suc i))))"

no_notation fun_app_lifted (infixl "." 999)

text \<open>
  The correctness proof closely follows Kleinberg \<open>&\<close> Tardos: "Algorithm Design",
  chapter "Dynamic Programming" @{cite "Kleinberg-Tardos"}
\<close>

definition
  "OPT n W = Max {\<Sum> i \<in> S. v i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W}"

lemma OPT_0:
  "OPT 0 W = 0"
  unfolding OPT_def by simp

subsubsection \<open>Functional Correctness\<close>

lemma Max_add_left:
  "(x :: nat) + Max S = Max (((+) x) ` S)" (is "?A = ?B") if "finite S" "S \<noteq> {}"
proof -
  have "?A \<le> ?B"
    using that by (force intro: Min.boundedI)
  moreover have "?B \<le> ?A"
    using that by (force intro: Min.boundedI)
  ultimately show ?thesis
    by simp
qed

lemma OPT_Suc:
  "OPT (Suc i) W = (
    if W < w (Suc i)
    then OPT i W
    else max(v (Suc i) + OPT i (W - w (Suc i))) (OPT i W)
  )" (is "?lhs = ?rhs")
proof -
  have OPT_in: "OPT n W \<in> {\<Sum> i \<in> S. v i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W}" for n W
    unfolding OPT_def by - (rule Max_in; force)
  from OPT_in[of "Suc i" W] obtain S where S:
    "S \<subseteq> {1..Suc i}" "sum w S \<le> W" and [simp]: "OPT (Suc i) W = sum v S"
    by auto

  have "OPT i W \<le> OPT (Suc i) W"
    unfolding OPT_def by (force intro: Max_mono)
  moreover have "v (Suc i) + OPT i (W - w (Suc i)) \<le> OPT (Suc i) W" if "w (Suc i) \<le> W"
  proof -
    have *: "
      v (Suc i) + sum v S = sum v (S \<union> {Suc i}) \<and> (S \<union> {Suc i}) \<subseteq> {1..Suc i}
      \<and> sum w (S \<union> {Suc i}) \<le> W" if "S \<subseteq> {1..i}" "sum w S \<le> W - w (Suc i)" for S
      using that \<open>w (Suc i) \<le> W\<close>
      by (subst sum.insert_if | auto intro: finite_subset[OF _ finite_atLeastAtMost])+
    show ?thesis
      unfolding OPT_def
      by (subst Max_add_left;
          fastforce intro: Max_mono finite_subset[OF _ finite_atLeastAtMost] dest: *
         )
  qed
  ultimately have "?lhs \<ge> ?rhs"
    by auto

  from S have *: "sum v S \<le> OPT i W" if "Suc i \<notin> S"
    using that unfolding OPT_def by (auto simp: atLeastAtMostSuc_conv intro!: Max_ge)

  have "sum v S \<le> OPT i W" if "W < w (Suc i)"
  proof (rule *, rule ccontr, simp)
    assume "Suc i \<in> S"
    then have "sum w S \<ge> w (Suc i)"
      using S(1) by (subst sum.remove) (auto intro: finite_subset[OF _ finite_atLeastAtMost])
    with \<open>W < _\<close> \<open>_ \<le> W\<close> show False
      by simp
  qed
  moreover have
    "OPT (Suc i) W \<le> max(v (Suc i) + OPT i (W - w (Suc i))) (OPT i W)" if "w (Suc i) \<le> W"
  proof (cases "Suc i \<in> S")
    case True
    then have [simp]:
      "sum v S = v (Suc i) + sum v (S - {Suc i})" "sum w S = w (Suc i) + sum w (S - {Suc i})"
      using S(1) by (auto intro: finite_subset[OF _ finite_atLeastAtMost] sum.remove)
    have "OPT i (W - w (Suc i)) \<ge> sum v (S - {Suc i})"
      unfolding OPT_def using S by (fastforce intro!: Max_ge)
    then show ?thesis
      by simp
  next
    case False
    then show ?thesis
      by (auto dest: *)
  qed
  ultimately have "?lhs \<le> ?rhs"
    by auto
  with \<open>?lhs \<ge> ?rhs\<close> show ?thesis
    by simp
qed

theorem knapsack_correct:
  "OPT n W = knapsack n W"
  by (induction n arbitrary: W; auto simp: OPT_0 OPT_Suc)

subsubsection \<open>Functional Memoization\<close>

memoize_fun knapsack\<^sub>m: knapsack with_memory dp_consistency_mapping monadifies (state) knapsack.simps

text \<open>Generated Definitions\<close>
context includes state_monad_syntax begin
thm knapsack\<^sub>m'.simps knapsack\<^sub>m_def
end

text \<open>Correspondence Proof\<close>
memoize_correct
  by memoize_prover
print_theorems
lemmas [code] = knapsack\<^sub>m.memoized_correct

subsubsection \<open>Imperative Memoization\<close>

context fixes
  mem :: "nat option array"
  and n W :: nat
begin

memoize_fun knapsack\<^sub>T: knapsack
  with_memory dp_consistency_heap_default where bound = "Bound (0, 0) (n, W)" and mem="mem"
  monadifies (heap) knapsack.simps

context includes heap_monad_syntax begin
thm knapsack\<^sub>T'.simps knapsack\<^sub>T_def
end

memoize_correct
  by memoize_prover

lemmas memoized_empty = knapsack\<^sub>T.memoized_empty

end (* Fixed array *)

text \<open>Adding Memory Initialization\<close>
context
  includes heap_monad_syntax
  notes [simp del] = knapsack\<^sub>T'.simps
begin

definition
  "knapsack\<^sub>h \<equiv> \<lambda> i j. Heap_Monad.bind (mem_empty (i * j)) (\<lambda> mem. knapsack\<^sub>T' mem i j i j)"

lemmas memoized_empty' = memoized_empty[
      of mem n W "\<lambda> m. \<lambda>(i,j). knapsack\<^sub>T' m n W i j",
      OF knapsack\<^sub>T.crel[of mem n W], of "(n, W)" for mem n W
    ]

lemma knapsack_heap:
  "knapsack n W = result_of (knapsack\<^sub>h n W) Heap.empty"
  unfolding knapsack\<^sub>h_def using memoized_empty'[of _ n W] by (simp add: index_size_defs)

end

end (* Knapsack *)

fun su :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "su 0 W = 0" |
  "su (Suc i) W = (if W < w (Suc i)
    then su i W
    else max (su i W) (w (Suc i) + su i (W - w (Suc i))))"

lemma su_knapsack:
  "su n W = knapsack w n W"
  by (induction n arbitrary: W; simp)

lemma su_correct:
  "Max {\<Sum> i \<in> S. w i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W} = su n W"
  unfolding su_knapsack knapsack_correct[symmetric] OPT_def ..

subsubsection \<open>Memoization\<close>

memoize_fun su\<^sub>m: su with_memory dp_consistency_mapping monadifies (state) su.simps

text \<open>Generated Definitions\<close>
context includes state_monad_syntax begin
thm su\<^sub>m'.simps su\<^sub>m_def
end

text \<open>Correspondence Proof\<close>
memoize_correct
  by memoize_prover
print_theorems
lemmas [code] = su\<^sub>m.memoized_correct

end (* Subset Sum *)

subsubsection \<open>Regression Test\<close>

definition
  "knapsack_test = (knapsack\<^sub>h (\<lambda> i. [2,3,4] ! (i - 1)) (\<lambda> i. [2,3,4] ! (i - 1)) 3 8)"

code_reflect Test functions knapsack_test

ML \<open>Test.knapsack_test ()\<close>

end (* Theory *)


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Equivalence Relations for LTL formulas\<close>

theory Equivalence_Relations
imports
  LTL
begin

subsection \<open>Language Equivalence\<close>

definition ltl_lang_equiv :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<sim>\<^sub>L" 75)
where
  "\<phi> \<sim>\<^sub>L \<psi> \<equiv> \<forall>w. w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"

lemma ltl_lang_equiv_equivp:
  "equivp (\<sim>\<^sub>L)"
  unfolding ltl_lang_equiv_def
  by (simp add: equivpI reflp_def symp_def transp_def)

lemma ltl_lang_equiv_and_false[intro, simp]:
  "\<phi>\<^sub>1 \<sim>\<^sub>L false\<^sub>n \<Longrightarrow> \<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>L false\<^sub>n"
  "\<phi>\<^sub>2 \<sim>\<^sub>L false\<^sub>n \<Longrightarrow> \<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>L false\<^sub>n"
  unfolding ltl_lang_equiv_def by auto

lemma ltl_lang_equiv_or_false[simp]:
  "\<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>L false\<^sub>n \<longleftrightarrow> \<phi>\<^sub>1 \<sim>\<^sub>L false\<^sub>n \<and> \<phi>\<^sub>2 \<sim>\<^sub>L false\<^sub>n"
  unfolding ltl_lang_equiv_def by auto

lemma ltl_lang_equiv_or_const[intro, simp]:
  "\<phi>\<^sub>1 \<sim>\<^sub>L true\<^sub>n \<Longrightarrow> \<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>L true\<^sub>n"
  "\<phi>\<^sub>2 \<sim>\<^sub>L true\<^sub>n \<Longrightarrow> \<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>L true\<^sub>n"
  unfolding ltl_lang_equiv_def by auto

subsection \<open>Propositional Equivalence\<close>

fun ltl_prop_entailment :: "'a ltln set \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>P" 80)
where
  "\<A> \<Turnstile>\<^sub>P true\<^sub>n = True"
| "\<A> \<Turnstile>\<^sub>P false\<^sub>n = False"
| "\<A> \<Turnstile>\<^sub>P \<phi> and\<^sub>n \<psi> = (\<A> \<Turnstile>\<^sub>P \<phi> \<and> \<A> \<Turnstile>\<^sub>P \<psi>)"
| "\<A> \<Turnstile>\<^sub>P \<phi> or\<^sub>n \<psi> = (\<A> \<Turnstile>\<^sub>P \<phi> \<or> \<A> \<Turnstile>\<^sub>P \<psi>)"
| "\<A> \<Turnstile>\<^sub>P \<phi> = (\<phi> \<in> \<A>)"

lemma ltl_prop_entailment_monotonI[intro]:
  "S \<Turnstile>\<^sub>P \<phi> \<Longrightarrow> S \<subseteq> S' \<Longrightarrow> S' \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

lemma ltl_models_equiv_prop_entailment:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> {\<psi>. w \<Turnstile>\<^sub>n \<psi>} \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

definition ltl_prop_equiv :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<sim>\<^sub>P" 75)
where
  "\<phi> \<sim>\<^sub>P \<psi> \<equiv> \<forall>\<A>. \<A> \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> \<A> \<Turnstile>\<^sub>P \<psi>"

definition ltl_prop_implies :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<longrightarrow>\<^sub>P" 75)
where
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<equiv> \<forall>\<A>. \<A> \<Turnstile>\<^sub>P \<phi> \<longrightarrow> \<A> \<Turnstile>\<^sub>P \<psi>"

lemma ltl_prop_implies_equiv:
  "\<phi> \<sim>\<^sub>P \<psi> \<longleftrightarrow> (\<phi> \<longrightarrow>\<^sub>P \<psi> \<and> \<psi> \<longrightarrow>\<^sub>P \<phi>)"
  unfolding ltl_prop_equiv_def ltl_prop_implies_def by meson

lemma ltl_prop_equiv_equivp:
  "equivp (\<sim>\<^sub>P)"
  by (simp add: ltl_prop_equiv_def equivpI reflp_def symp_def transp_def)

lemma ltl_prop_equiv_trans[trans]:
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> \<psi> \<sim>\<^sub>P \<chi> \<Longrightarrow> \<phi> \<sim>\<^sub>P \<chi>"
  by (simp add: ltl_prop_equiv_def)

lemma ltl_prop_equiv_true:
  "\<phi> \<sim>\<^sub>P true\<^sub>n \<longleftrightarrow> {} \<Turnstile>\<^sub>P \<phi>"
  using bot.extremum ltl_prop_entailment.simps(1) ltl_prop_equiv_def by blast

lemma ltl_prop_equiv_false:
  "\<phi> \<sim>\<^sub>P false\<^sub>n \<longleftrightarrow> \<not> UNIV \<Turnstile>\<^sub>P \<phi>"
  by (meson ltl_prop_entailment.simps(2) ltl_prop_entailment_monotonI ltl_prop_equiv_def top_greatest)

lemma ltl_prop_equiv_true_implies_true:
  "x \<sim>\<^sub>P true\<^sub>n \<Longrightarrow> x \<longrightarrow>\<^sub>P y \<Longrightarrow> y \<sim>\<^sub>P true\<^sub>n"
  by (simp add: ltl_prop_equiv_def ltl_prop_implies_def)

lemma ltl_prop_equiv_false_implied_by_false:
  "y \<sim>\<^sub>P false\<^sub>n \<Longrightarrow> x \<longrightarrow>\<^sub>P y \<Longrightarrow> x \<sim>\<^sub>P false\<^sub>n"
  by (simp add: ltl_prop_equiv_def ltl_prop_implies_def)

lemma ltl_prop_implication_implies_ltl_implication:
  "w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> \<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  using ltl_models_equiv_prop_entailment ltl_prop_implies_def by blast

lemma ltl_prop_equiv_implies_ltl_lang_equiv:
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> \<phi> \<sim>\<^sub>L \<psi>"
  using ltl_lang_equiv_def ltl_prop_implication_implies_ltl_implication ltl_prop_implies_equiv by blast

lemma ltl_prop_equiv_lt_ltl_lang_equiv[simp]:
  "(\<sim>\<^sub>P) \<le> (\<sim>\<^sub>L)"
  using ltl_prop_equiv_implies_ltl_lang_equiv by blast

subsection \<open>Constants Equivalence\<close>

datatype tvl = Yes | No | Maybe

definition eval_and :: "tvl \<Rightarrow> tvl \<Rightarrow> tvl"
where
  "eval_and \<phi> \<psi> =
    (case (\<phi>, \<psi>) of
      (Yes, Yes) \<Rightarrow> Yes
    | (No, _) \<Rightarrow> No
    | (_, No) \<Rightarrow> No
    | _ \<Rightarrow> Maybe)"

definition eval_or :: "tvl \<Rightarrow> tvl \<Rightarrow> tvl"
where
  "eval_or \<phi> \<psi> =
    (case (\<phi>, \<psi>) of
      (No, No) \<Rightarrow> No
    | (Yes, _) \<Rightarrow> Yes
    | (_, Yes) \<Rightarrow> Yes
    | _ \<Rightarrow> Maybe)"

fun eval :: "'a ltln \<Rightarrow> tvl"
where
  "eval true\<^sub>n = Yes"
| "eval false\<^sub>n = No"
| "eval (\<phi> and\<^sub>n \<psi>) = eval_and (eval \<phi>) (eval \<psi>)"
| "eval (\<phi> or\<^sub>n \<psi>) = eval_or (eval \<phi>) (eval \<psi>)"
| "eval \<phi> = Maybe"

lemma eval_and_const[simp]:
  "eval_and \<phi> \<psi> = No \<longleftrightarrow> \<phi> = No \<or> \<psi> = No"
  "eval_and \<phi> \<psi> = Yes \<longleftrightarrow> \<phi> = Yes \<and> \<psi> = Yes"
  unfolding eval_and_def
  by (cases \<phi>; cases \<psi>, auto)+

lemma eval_or_const[simp]:
  "eval_or \<phi> \<psi> = Yes \<longleftrightarrow> \<phi> = Yes \<or> \<psi> = Yes"
  "eval_or \<phi> \<psi> = No \<longleftrightarrow> \<phi> = No \<and> \<psi> = No"
  unfolding eval_or_def
  by (cases \<phi>; cases \<psi>, auto)+

lemma eval_prop_entailment:
  "eval \<phi> = Yes \<longleftrightarrow> {} \<Turnstile>\<^sub>P \<phi>"
  "eval \<phi> = No \<longleftrightarrow> \<not> UNIV \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

definition ltl_const_equiv :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<sim>\<^sub>C" 75)
where
  "\<phi> \<sim>\<^sub>C \<psi> \<equiv> \<phi> = \<psi> \<or> (eval \<phi> = eval \<psi> \<and> eval \<psi> \<noteq> Maybe)"

lemma ltl_const_equiv_equivp:
  "equivp (\<sim>\<^sub>C)"
  unfolding ltl_const_equiv_def
  by (intro equivpI reflpI sympI transpI) auto

lemma ltl_const_equiv_const:
  "\<phi> \<sim>\<^sub>C true\<^sub>n \<longleftrightarrow> eval \<phi> = Yes"
  "\<phi> \<sim>\<^sub>C false\<^sub>n \<longleftrightarrow> eval \<phi> = No"
  unfolding ltl_const_equiv_def by force+

lemma ltl_const_equiv_and_const[simp]:
  "\<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>C true\<^sub>n \<longleftrightarrow> \<phi>\<^sub>1 \<sim>\<^sub>C true\<^sub>n \<and> \<phi>\<^sub>2 \<sim>\<^sub>C true\<^sub>n"
  "\<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>C false\<^sub>n \<longleftrightarrow> \<phi>\<^sub>1 \<sim>\<^sub>C false\<^sub>n \<or> \<phi>\<^sub>2 \<sim>\<^sub>C false\<^sub>n"
  unfolding ltl_const_equiv_const by force+

lemma ltl_const_equiv_or_const[simp]:
  "\<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>C true\<^sub>n \<longleftrightarrow> \<phi>\<^sub>1 \<sim>\<^sub>C true\<^sub>n \<or> \<phi>\<^sub>2 \<sim>\<^sub>C true\<^sub>n"
  "\<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<sim>\<^sub>C false\<^sub>n \<longleftrightarrow> \<phi>\<^sub>1 \<sim>\<^sub>C false\<^sub>n \<and> \<phi>\<^sub>2 \<sim>\<^sub>C false\<^sub>n"
  unfolding ltl_const_equiv_const by force+

lemma ltl_const_equiv_other[simp]:
  "\<phi> \<sim>\<^sub>C prop\<^sub>n(a) \<longleftrightarrow> \<phi> = prop\<^sub>n(a)"
  "\<phi> \<sim>\<^sub>C nprop\<^sub>n(a) \<longleftrightarrow> \<phi> = nprop\<^sub>n(a)"
  "\<phi> \<sim>\<^sub>C X\<^sub>n \<psi> \<longleftrightarrow> \<phi> = X\<^sub>n \<psi>"
  "\<phi> \<sim>\<^sub>C \<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2 \<longleftrightarrow> \<phi> = \<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2"
  "\<phi> \<sim>\<^sub>C \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<longleftrightarrow> \<phi> = \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2"
  "\<phi> \<sim>\<^sub>C \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<longleftrightarrow> \<phi> = \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2"
  "\<phi> \<sim>\<^sub>C \<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2 \<longleftrightarrow> \<phi> = \<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2"
  using ltl_const_equiv_def by fastforce+

lemma ltl_const_equiv_no_const_singleton:
  "eval \<psi> = Maybe \<Longrightarrow> \<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> \<phi> = \<psi>"
  unfolding ltl_const_equiv_def by fastforce

lemma ltl_const_equiv_implies_prop_equiv:
  "\<phi> \<sim>\<^sub>C true\<^sub>n \<longleftrightarrow> \<phi> \<sim>\<^sub>P true\<^sub>n"
  "\<phi> \<sim>\<^sub>C false\<^sub>n \<longleftrightarrow> \<phi> \<sim>\<^sub>P false\<^sub>n"
  unfolding ltl_const_equiv_const eval_prop_entailment ltl_prop_equiv_def
  by auto

lemma ltl_const_equiv_no_const_prop_equiv:
  "eval \<psi> = Maybe \<Longrightarrow> \<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> \<phi> \<sim>\<^sub>P \<psi>"
  using ltl_const_equiv_no_const_singleton equivp_reflp[OF ltl_prop_equiv_equivp]
  by blast

lemma ltl_const_equiv_implies_ltl_prop_equiv:
  "\<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> \<phi> \<sim>\<^sub>P \<psi>"
proof (induction \<psi>)
  case (And_ltln \<psi>1 \<psi>2)

  show ?case
  proof (cases "eval (\<psi>1 and\<^sub>n \<psi>2)")
    case Yes

    then have "\<phi> \<sim>\<^sub>C true\<^sub>n"
      by (meson And_ltln.prems equivp_transp ltl_const_equiv_const(1) ltl_const_equiv_equivp)
    then show ?thesis
      by (metis (full_types) Yes ltl_const_equiv_const(1) ltl_const_equiv_implies_prop_equiv(1) ltl_prop_equiv_trans ltl_prop_implies_equiv)
  next
    case No

    then have "\<phi> \<sim>\<^sub>C false\<^sub>n"
      by (meson And_ltln.prems equivp_transp ltl_const_equiv_const(2) ltl_const_equiv_equivp)
    then show ?thesis
      by (metis (full_types) No ltl_const_equiv_const(2) ltl_const_equiv_implies_prop_equiv(2) ltl_prop_equiv_trans ltl_prop_implies_equiv)
  next
    case Maybe

    then show ?thesis
      using And_ltln.prems ltl_const_equiv_no_const_prop_equiv by force
  qed
next
  case (Or_ltln \<psi>1 \<psi>2)

  then show ?case
  proof (cases "eval (\<psi>1 or\<^sub>n \<psi>2)")
    case Yes

    then have "\<phi> \<sim>\<^sub>C true\<^sub>n"
      by (meson Or_ltln.prems equivp_transp ltl_const_equiv_const(1) ltl_const_equiv_equivp)
    then show ?thesis
      by (metis (full_types) Yes ltl_const_equiv_const(1) ltl_const_equiv_implies_prop_equiv(1) ltl_prop_equiv_trans ltl_prop_implies_equiv)
  next
    case No

    then have "\<phi> \<sim>\<^sub>C false\<^sub>n"
      by (meson Or_ltln.prems equivp_transp ltl_const_equiv_const(2) ltl_const_equiv_equivp)
    then show ?thesis
      by (metis (full_types) No ltl_const_equiv_const(2) ltl_const_equiv_implies_prop_equiv(2) ltl_prop_equiv_trans ltl_prop_implies_equiv)
  next
    case Maybe

    then show ?thesis
      using Or_ltln.prems ltl_const_equiv_no_const_prop_equiv by force
  qed
qed (simp_all add: ltl_const_equiv_implies_prop_equiv equivp_reflp[OF ltl_prop_equiv_equivp])

lemma ltl_const_equiv_lt_ltl_prop_equiv[simp]:
  "(\<sim>\<^sub>C) \<le> (\<sim>\<^sub>P)"
  using ltl_const_equiv_implies_ltl_prop_equiv by blast

subsection \<open>Quotient types\<close>

quotient_type 'a ltln\<^sub>L = "'a ltln" / "(\<sim>\<^sub>L)"
  by (rule ltl_lang_equiv_equivp)

instantiation ltln\<^sub>L :: (type) equal
begin

lift_definition ltln\<^sub>L_eq_test :: "'a ltln\<^sub>L \<Rightarrow> 'a ltln\<^sub>L \<Rightarrow> bool" is "\<lambda>x y. x \<sim>\<^sub>L y"
  by (metis ltln\<^sub>L.abs_eq_iff)

definition
  eq\<^sub>L: "equal_class.equal \<equiv> ltln\<^sub>L_eq_test"

instance
  by (standard; simp add: eq\<^sub>L ltln\<^sub>L_eq_test.rep_eq, metis Quotient_ltln\<^sub>L Quotient_rel_rep)

end

quotient_type 'a ltln\<^sub>P = "'a ltln" / "(\<sim>\<^sub>P)"
  by (rule ltl_prop_equiv_equivp)

instantiation ltln\<^sub>P :: (type) equal
begin

lift_definition ltln\<^sub>P_eq_test :: "'a ltln\<^sub>P \<Rightarrow> 'a ltln\<^sub>P \<Rightarrow> bool" is "\<lambda>x y. x \<sim>\<^sub>P y"
  by (metis ltln\<^sub>P.abs_eq_iff)

definition
  eq\<^sub>P: "equal_class.equal \<equiv> ltln\<^sub>P_eq_test"

instance
  by (standard; simp add: eq\<^sub>P ltln\<^sub>P_eq_test.rep_eq, metis Quotient_ltln\<^sub>P Quotient_rel_rep)

end

quotient_type 'a ltln\<^sub>C = "'a ltln" / "(\<sim>\<^sub>C)"
  by (rule ltl_const_equiv_equivp)

instantiation ltln\<^sub>C :: (type) equal
begin

lift_definition ltln\<^sub>C_eq_test :: "'a ltln\<^sub>C \<Rightarrow> 'a ltln\<^sub>C \<Rightarrow> bool" is "\<lambda>x y. x \<sim>\<^sub>C y"
  by (metis ltln\<^sub>C.abs_eq_iff)

definition
  eq\<^sub>C: "equal_class.equal \<equiv> ltln\<^sub>C_eq_test"

instance
  by (standard; simp add: eq\<^sub>C ltln\<^sub>C_eq_test.rep_eq, metis Quotient_ltln\<^sub>C Quotient_rel_rep)

end

subsection \<open>Cardinality of propositional quotient sets\<close>

definition sat_models :: "'a ltln\<^sub>P \<Rightarrow> 'a ltln set set"
where
  "sat_models \<phi> = {\<A>. \<A> \<Turnstile>\<^sub>P rep_ltln\<^sub>P \<phi>}"

lemma Rep_Abs_prop_entailment[simp]:
  "\<A> \<Turnstile>\<^sub>P rep_ltln\<^sub>P (abs_ltln\<^sub>P \<phi>) = \<A> \<Turnstile>\<^sub>P \<phi>"
  by (metis Quotient3_ltln\<^sub>P Quotient3_rep_abs ltl_prop_equiv_def)

lemma sat_models_Abs:
  "\<A> \<in> sat_models (abs_ltln\<^sub>P \<phi>) = \<A> \<Turnstile>\<^sub>P \<phi>"
  by (simp add: sat_models_def)

lemma sat_models_inj:
  "inj sat_models"
proof (rule injI)
  fix \<phi> \<psi> :: "'a ltln\<^sub>P"
  assume "sat_models \<phi> = sat_models \<psi>"

  then have "rep_ltln\<^sub>P \<phi> \<sim>\<^sub>P rep_ltln\<^sub>P \<psi>"
    unfolding sat_models_def ltl_prop_equiv_def by force

  then show "\<phi> = \<psi>"
    by (meson Quotient3_ltln\<^sub>P Quotient3_rel_rep)
qed

fun prop_atoms :: "'a ltln \<Rightarrow> 'a ltln set"
where
  "prop_atoms true\<^sub>n = {}"
| "prop_atoms false\<^sub>n = {}"
| "prop_atoms (\<phi> and\<^sub>n \<psi>) = prop_atoms \<phi> \<union> prop_atoms \<psi>"
| "prop_atoms (\<phi> or\<^sub>n \<psi>) = prop_atoms \<phi> \<union> prop_atoms \<psi>"
| "prop_atoms \<phi> = {\<phi>}"

fun nested_prop_atoms :: "'a ltln \<Rightarrow> 'a ltln set"
where
  "nested_prop_atoms true\<^sub>n = {}"
| "nested_prop_atoms false\<^sub>n = {}"
| "nested_prop_atoms (\<phi> and\<^sub>n \<psi>) = nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms (\<phi> or\<^sub>n \<psi>) = nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms (X\<^sub>n \<phi>) = {X\<^sub>n \<phi>} \<union> nested_prop_atoms \<phi>"
| "nested_prop_atoms (\<phi> U\<^sub>n \<psi>) = {\<phi> U\<^sub>n \<psi>} \<union> nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms (\<phi> R\<^sub>n \<psi>) = {\<phi> R\<^sub>n \<psi>} \<union> nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms (\<phi> W\<^sub>n \<psi>) = {\<phi> W\<^sub>n \<psi>} \<union> nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms (\<phi> M\<^sub>n \<psi>) = {\<phi> M\<^sub>n \<psi>} \<union> nested_prop_atoms \<phi> \<union> nested_prop_atoms \<psi>"
| "nested_prop_atoms \<phi> = {\<phi>}"

lemma prop_atoms_nested_prop_atoms:
  "prop_atoms \<phi> \<subseteq> nested_prop_atoms \<phi>"
  by (induction \<phi>) auto

lemma prop_atoms_subfrmlsn:
  "prop_atoms \<phi> \<subseteq> subfrmlsn \<phi>"
  by (induction \<phi>) auto

lemma nested_prop_atoms_subfrmlsn:
  "nested_prop_atoms \<phi> \<subseteq> subfrmlsn \<phi>"
  by (induction \<phi>) auto

lemma prop_atoms_notin[simp]:
  "true\<^sub>n \<notin> prop_atoms \<phi>"
  "false\<^sub>n \<notin> prop_atoms \<phi>"
  "\<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<notin> prop_atoms \<phi>"
  "\<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<notin> prop_atoms \<phi>"
  by (induction \<phi>) auto

lemma nested_prop_atoms_notin[simp]:
  "true\<^sub>n \<notin> nested_prop_atoms \<phi>"
  "false\<^sub>n \<notin> nested_prop_atoms \<phi>"
  "\<phi>\<^sub>1 and\<^sub>n \<phi>\<^sub>2 \<notin> nested_prop_atoms \<phi>"
  "\<phi>\<^sub>1 or\<^sub>n \<phi>\<^sub>2 \<notin> nested_prop_atoms \<phi>"
  by (induction \<phi>) auto

lemma prop_atoms_finite:
  "finite (prop_atoms \<phi>)"
  by (induction \<phi>) auto

lemma nested_prop_atoms_finite:
  "finite (nested_prop_atoms \<phi>)"
  by (induction \<phi>) auto

lemma prop_atoms_entailment_iff:
  "\<phi> \<in> prop_atoms \<psi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> \<phi> \<in> \<A>"
  by (induction \<phi>) auto

lemma prop_atoms_entailment_inter:
  "prop_atoms \<phi> \<subseteq> P \<Longrightarrow> (\<A> \<inter> P) \<Turnstile>\<^sub>P \<phi> = \<A> \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

lemma nested_prop_atoms_entailment_inter:
  "nested_prop_atoms \<phi> \<subseteq> P \<Longrightarrow> (\<A> \<inter> P) \<Turnstile>\<^sub>P \<phi> = \<A> \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

lemma sat_models_inter_inj_helper:
  assumes
    "prop_atoms \<phi> \<subseteq> P"
  and
    "prop_atoms \<psi> \<subseteq> P"
  and
    "sat_models (abs_ltln\<^sub>P \<phi>) \<inter> Pow P = sat_models (abs_ltln\<^sub>P \<psi>) \<inter> Pow P"
  shows
    "\<phi> \<sim>\<^sub>P \<psi>"
proof -
  from assms have "\<forall>\<A>. (\<A> \<inter> P) \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> (\<A> \<inter> P) \<Turnstile>\<^sub>P \<psi>"
    by (auto simp: sat_models_Abs)

  with assms show "\<phi> \<sim>\<^sub>P \<psi>"
    by (simp add: prop_atoms_entailment_inter ltl_prop_equiv_def)
qed

lemma sat_models_inter_inj:
  "inj_on (\<lambda>\<phi>. sat_models \<phi> \<inter> Pow P) {abs_ltln\<^sub>P \<phi> |\<phi>. prop_atoms \<phi> \<subseteq> P}"
  by (auto simp: inj_on_def sat_models_inter_inj_helper ltln\<^sub>P.abs_eq_iff)

lemma sat_models_pow_pow:
  "{sat_models (abs_ltln\<^sub>P \<phi>) \<inter> Pow P | \<phi>. prop_atoms \<phi> \<subseteq> P} \<subseteq> Pow (Pow P)"
  by (auto simp: sat_models_def)

lemma sat_models_finite:
  "finite P \<Longrightarrow> finite {sat_models (abs_ltln\<^sub>P \<phi>) \<inter> Pow P | \<phi>. prop_atoms \<phi> \<subseteq> P}"
  using sat_models_pow_pow finite_subset by fastforce

lemma sat_models_card:
  "finite P \<Longrightarrow> card ({sat_models (abs_ltln\<^sub>P \<phi>) \<inter> Pow P | \<phi>. prop_atoms \<phi> \<subseteq> P}) \<le> 2 ^ 2 ^ card P"
  by (metis (mono_tags, lifting) sat_models_pow_pow Pow_def card_Pow card_mono finite_Collect_subsets)

lemma image_filter:
  "f ` {g a | a. P a} = {f (g a) | a. P a}"
  by blast

lemma prop_equiv_finite:
  "finite P \<Longrightarrow> finite {abs_ltln\<^sub>P \<psi> | \<psi>. prop_atoms \<psi> \<subseteq> P}"
  by (auto simp: image_filter sat_models_finite finite_imageD[OF _ sat_models_inter_inj])

lemma prop_equiv_card:
  "finite P \<Longrightarrow> card {abs_ltln\<^sub>P \<psi> | \<psi>. prop_atoms \<psi> \<subseteq> P} \<le> 2 ^ 2 ^ card P"
  by (auto simp: image_filter sat_models_card card_image[OF sat_models_inter_inj, symmetric])

lemma prop_equiv_subset:
  "{abs_ltln\<^sub>P \<psi> |\<psi>. nested_prop_atoms \<psi> \<subseteq> P} \<subseteq> {abs_ltln\<^sub>P \<psi> |\<psi>. prop_atoms \<psi> \<subseteq> P}"
  using prop_atoms_nested_prop_atoms by blast

lemma prop_equiv_finite':
  "finite P \<Longrightarrow> finite {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> P}"
  using prop_equiv_finite prop_equiv_subset finite_subset by fast

lemma prop_equiv_card':
  "finite P \<Longrightarrow> card {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> P} \<le> 2 ^ 2 ^ card P"
  by (metis (mono_tags, lifting) prop_equiv_card prop_equiv_subset prop_equiv_finite card_mono le_trans)

subsection \<open>Substitution\<close>

fun subst :: "'a ltln \<Rightarrow> ('a ltln \<rightharpoonup> 'a ltln) \<Rightarrow> 'a ltln"
where
  "subst true\<^sub>n m = true\<^sub>n"
| "subst false\<^sub>n m = false\<^sub>n"
| "subst (\<phi> and\<^sub>n \<psi>) m = subst \<phi> m and\<^sub>n subst \<psi> m"
| "subst (\<phi> or\<^sub>n \<psi>) m = subst \<phi> m or\<^sub>n subst \<psi> m"
| "subst \<phi> m = (case m \<phi> of Some \<psi> \<Rightarrow> \<psi> | None \<Rightarrow> \<phi>)"

text \<open>Based on Uwe Schoening's Translation Lemma (Logic for CS, p. 54)\<close>

lemma ltl_prop_equiv_subst_S:
  "S \<Turnstile>\<^sub>P subst \<phi> m = ((S - dom m) \<union> {\<chi> | \<chi> \<chi>'. \<chi> \<in> dom m \<and> m \<chi> = Some \<chi>' \<and> S \<Turnstile>\<^sub>P \<chi>'}) \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) (auto split: option.split)

lemma subst_respects_ltl_prop_entailment:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> subst \<phi> m \<longrightarrow>\<^sub>P subst \<psi> m"
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> subst \<phi> m \<sim>\<^sub>P subst \<psi> m"
  unfolding ltl_prop_equiv_def ltl_prop_implies_def ltl_prop_equiv_subst_S by blast+

lemma eval_subst:
  "eval \<phi> = Yes \<Longrightarrow> eval (subst \<phi> m) = Yes"
  "eval \<phi> = No \<Longrightarrow> eval (subst \<phi> m) = No"
  by (meson empty_subsetI eval_prop_entailment ltl_prop_entailment_monotonI ltl_prop_equiv_subst_S subset_UNIV)+

lemma subst_respects_ltl_const_entailment:
  "\<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> subst \<phi> m \<sim>\<^sub>C subst \<psi> m"
  unfolding ltl_const_equiv_def
  by (cases "eval \<psi>") (metis eval_subst(1), metis eval_subst(2), blast)

subsection \<open>Order of Equivalence Relations\<close>

locale ltl_equivalence =
  fixes
    eq :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<sim>" 75)
  assumes
    eq_equivp: "equivp (\<sim>)"
  and
    ge_const_equiv: "(\<sim>\<^sub>C) \<le> (\<sim>)"
  and
    le_lang_equiv: "(\<sim>) \<le> (\<sim>\<^sub>L)"
begin

lemma eq_implies_ltl_equiv:
  "\<phi> \<sim> \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> = w \<Turnstile>\<^sub>n \<psi>"
  using le_lang_equiv ltl_lang_equiv_def by blast

lemma const_implies_eq:
  "\<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> \<phi> \<sim> \<psi>"
  using ge_const_equiv by blast

lemma eq_implies_lang:
  "\<phi> \<sim> \<psi> \<Longrightarrow> \<phi> \<sim>\<^sub>L \<psi>"
  using le_lang_equiv by blast

lemma eq_refl[simp]:
  "\<phi> \<sim> \<phi>"
  by (meson eq_equivp equivp_reflp)

lemma eq_sym[sym]:
  "\<phi> \<sim> \<psi> \<Longrightarrow> \<psi> \<sim> \<phi>"
  by (meson eq_equivp equivp_symp)

lemma eq_trans[trans]:
  "\<phi> \<sim> \<psi> \<Longrightarrow> \<psi> \<sim> \<chi> \<Longrightarrow> \<phi> \<sim> \<chi>"
  by (meson eq_equivp equivp_transp)

end

interpretation ltl_lang_equivalence: ltl_equivalence "(\<sim>\<^sub>L)"
  using ltl_lang_equiv_equivp ltl_const_equiv_lt_ltl_prop_equiv ltl_prop_equiv_lt_ltl_lang_equiv
  by unfold_locales blast+

interpretation ltl_prop_equivalence: ltl_equivalence "(\<sim>\<^sub>P)"
  using ltl_prop_equiv_equivp ltl_const_equiv_lt_ltl_prop_equiv ltl_prop_equiv_lt_ltl_lang_equiv
  by unfold_locales blast+

interpretation ltl_const_equivalence: ltl_equivalence "(\<sim>\<^sub>C)"
  using ltl_const_equiv_equivp ltl_const_equiv_lt_ltl_prop_equiv ltl_prop_equiv_lt_ltl_lang_equiv
  by unfold_locales blast+

end


(*  Title:      HOL/Computational_Algebra/Normalized_Fraction.thy
    Author:     Manuel Eberl
*)

theory Normalized_Fraction
imports
  MainRLT
  Euclidean_Algorithm
  Fraction_Field
begin

definition quot_to_fract :: "'a :: {idom} \<times> 'a \<Rightarrow> 'a fract" where
  "quot_to_fract = (\<lambda>(a,b). Fraction_Field.Fract a b)"

definition normalize_quot :: "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "normalize_quot =
     (\<lambda>(a,b). if b = 0 then (0,1) else let d = gcd a b * unit_factor b in (a div d, b div d))"

lemma normalize_quot_zero [simp]:
  "normalize_quot (a, 0) = (0, 1)"
  by (simp add: normalize_quot_def)

lemma normalize_quot_proj:
  "fst (normalize_quot (a, b)) = a div (gcd a b * unit_factor b)"
  "snd (normalize_quot (a, b)) = normalize b div gcd a b" if "b \<noteq> 0"
  using that by (simp_all add: normalize_quot_def Let_def mult.commute [of _ "unit_factor b"] dvd_div_mult2_eq mult_unit_dvd_iff')

definition normalized_fracts :: "('a :: {ring_gcd,idom_divide} \<times> 'a) set" where
  "normalized_fracts = {(a,b). coprime a b \<and> unit_factor b = 1}"

lemma not_normalized_fracts_0_denom [simp]: "(a, 0) \<notin> normalized_fracts"
  by (auto simp: normalized_fracts_def)

lemma unit_factor_snd_normalize_quot [simp]:
  "unit_factor (snd (normalize_quot x)) = 1"
  by (simp add: normalize_quot_def case_prod_unfold Let_def dvd_unit_factor_div
                mult_unit_dvd_iff unit_factor_mult unit_factor_gcd)

lemma snd_normalize_quot_nonzero [simp]: "snd (normalize_quot x) \<noteq> 0"
  using unit_factor_snd_normalize_quot[of x]
  by (auto simp del: unit_factor_snd_normalize_quot)

lemma normalize_quot_aux:
  fixes a b
  assumes "b \<noteq> 0"
  defines "d \<equiv> gcd a b * unit_factor b"
  shows   "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
          "d dvd a" "d dvd b" "d \<noteq> 0"
proof -
  from assms show "d dvd a" "d dvd b"
    by (simp_all add: d_def mult_unit_dvd_iff)
  thus "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d" "d \<noteq> 0"
    by (auto simp: normalize_quot_def Let_def d_def \<open>b \<noteq> 0\<close>)
qed

lemma normalize_quotE:
  assumes "b \<noteq> 0"
  obtains d where "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
                  "d dvd a" "d dvd b" "d \<noteq> 0"
  using that[OF normalize_quot_aux[OF assms]] .

lemma normalize_quotE':
  assumes "snd x \<noteq> 0"
  obtains d where "fst x = fst (normalize_quot x) * d" "snd x = snd (normalize_quot x) * d"
                  "d dvd fst x" "d dvd snd x" "d \<noteq> 0"
proof -
  from normalize_quotE[OF assms, of "fst x"] obtain d where
    "fst x = fst (normalize_quot (fst x, snd x)) * d"
    "snd x = snd (normalize_quot (fst x, snd x)) * d"
    "d dvd fst x"
    "d dvd snd x"
    "d \<noteq> 0" .
  then show ?thesis unfolding prod.collapse by (intro that[of d])
qed

lemma coprime_normalize_quot:
  "coprime (fst (normalize_quot x)) (snd (normalize_quot x))"
  by (simp add: normalize_quot_def case_prod_unfold div_mult_unit2)
    (metis coprime_mult_self_right_iff div_gcd_coprime unit_div_mult_self unit_factor_is_unit)

lemma normalize_quot_in_normalized_fracts [simp]: "normalize_quot x \<in> normalized_fracts"
  by (simp add: normalized_fracts_def coprime_normalize_quot case_prod_unfold)

lemma normalize_quot_eq_iff:
  assumes "b \<noteq> 0" "d \<noteq> 0"
  shows   "normalize_quot (a,b) = normalize_quot (c,d) \<longleftrightarrow> a * d = b * c"
proof -
  define x y where "x = normalize_quot (a,b)" and "y = normalize_quot (c,d)"
  from normalize_quotE[OF assms(1), of a] normalize_quotE[OF assms(2), of c]
    obtain d1 d2
      where "a = fst x * d1" "b = snd x * d1" "c = fst y * d2" "d = snd y * d2" "d1 \<noteq> 0" "d2 \<noteq> 0"
    unfolding x_def y_def by metis
  hence "a * d = b * c \<longleftrightarrow> fst x * snd y = snd x * fst y" by simp
  also have "\<dots> \<longleftrightarrow> fst x = fst y \<and> snd x = snd y"
    by (intro coprime_crossproduct') (simp_all add: x_def y_def coprime_normalize_quot)
  also have "\<dots> \<longleftrightarrow> x = y" using prod_eqI by blast
  finally show "x = y \<longleftrightarrow> a * d = b * c" ..
qed

lemma normalize_quot_eq_iff':
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot x = normalize_quot y \<longleftrightarrow> fst x * snd y = snd x * fst y"
  using assms by (cases x, cases y, hypsubst) (subst normalize_quot_eq_iff, simp_all)

lemma normalize_quot_id: "x \<in> normalized_fracts \<Longrightarrow> normalize_quot x = x"
  by (auto simp: normalized_fracts_def normalize_quot_def case_prod_unfold)

lemma normalize_quot_idem [simp]: "normalize_quot (normalize_quot x) = normalize_quot x"
  by (rule normalize_quot_id) simp_all

lemma fractrel_iff_normalize_quot_eq:
  "fractrel x y \<longleftrightarrow> normalize_quot x = normalize_quot y \<and> snd x \<noteq> 0 \<and> snd y \<noteq> 0"
  by (cases x, cases y) (auto simp: fractrel_def normalize_quot_eq_iff)

lemma fractrel_normalize_quot_left:
  assumes "snd x \<noteq> 0"
  shows   "fractrel (normalize_quot x) y \<longleftrightarrow> fractrel x y"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lemma fractrel_normalize_quot_right:
  assumes "snd x \<noteq> 0"
  shows   "fractrel y (normalize_quot x) \<longleftrightarrow> fractrel y x"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lift_definition quot_of_fract ::
  "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract \<Rightarrow> 'a \<times> 'a"
    is normalize_quot
  by (subst (asm) fractrel_iff_normalize_quot_eq) simp_all

lemma quot_to_fract_quot_of_fract [simp]: "quot_to_fract (quot_of_fract x) = x"
  unfolding quot_to_fract_def
proof transfer
  fix x :: "'a \<times> 'a" assume rel: "fractrel x x"
  define x' where "x' = normalize_quot x"
  obtain a b where [simp]: "x = (a, b)" by (cases x)
  from rel have "b \<noteq> 0" by simp
  from normalize_quotE[OF this, of a] obtain d
    where
      "a = fst (normalize_quot (a, b)) * d"
      "b = snd (normalize_quot (a, b)) * d"
      "d dvd a"
      "d dvd b"
      "d \<noteq> 0" .
  hence "a = fst x' * d" "b = snd x' * d" "d \<noteq> 0" "snd x' \<noteq> 0" by (simp_all add: x'_def)
  thus "fractrel (case x' of (a, b) \<Rightarrow> if b = 0 then (0, 1) else (a, b)) x"
    by (auto simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract: "quot_of_fract (quot_to_fract x) = normalize_quot x"
proof (cases "snd x = 0")
  case True
  thus ?thesis unfolding quot_to_fract_def
    by transfer (simp add: case_prod_unfold normalize_quot_def)
next
  case False
  thus ?thesis unfolding quot_to_fract_def by transfer (simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract':
  "x \<in> normalized_fracts \<Longrightarrow> quot_of_fract (quot_to_fract x) = x"
  unfolding quot_to_fract_def by transfer (auto simp: normalize_quot_id)

lemma quot_of_fract_in_normalized_fracts [simp]: "quot_of_fract x \<in> normalized_fracts"
  by transfer simp

lemma normalize_quotI:
  assumes "a * d = b * c" "b \<noteq> 0" "(c, d) \<in> normalized_fracts"
  shows   "normalize_quot (a, b) = (c, d)"
proof -
  from assms have "normalize_quot (a, b) = normalize_quot (c, d)"
    by (subst normalize_quot_eq_iff) auto
  also have "\<dots> = (c, d)" by (intro normalize_quot_id) fact
  finally show ?thesis .
qed

lemma td_normalized_fract:
  "type_definition quot_of_fract quot_to_fract normalized_fracts"
  by standard (simp_all add: quot_of_fract_quot_to_fract')

lemma quot_of_fract_add_aux:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "(fst x * snd y + fst y * snd x) * (snd (normalize_quot x) * snd (normalize_quot y)) =
             snd x * snd y * (fst (normalize_quot x) * snd (normalize_quot y) +
             snd (normalize_quot x) * fst (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] obtain d
    where d:
      "fst x = fst (normalize_quot x) * d"
      "snd x = snd (normalize_quot x) * d"
      "d dvd fst x"
      "d dvd snd x"
      "d \<noteq> 0" .
  from normalize_quotE'[OF assms(2)] obtain e
    where e:
      "fst y = fst (normalize_quot y) * e"
      "snd y = snd (normalize_quot y) * e"
      "e dvd fst y"
      "e dvd snd y"
      "e \<noteq> 0" .
  show ?thesis by (simp_all add: d e algebra_simps)
qed

locale fract_as_normalized_quot
begin
setup_lifting td_normalized_fract
end

lemma quot_of_fract_add:
  "quot_of_fract (x + y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d + b * c, b * d))"
  by transfer (insert quot_of_fract_add_aux,
               simp_all add: Let_def case_prod_unfold normalize_quot_eq_iff)

lemma quot_of_fract_uminus:
  "quot_of_fract (-x) = (let (a,b) = quot_of_fract x in (-a, b))"
  by transfer (auto simp: case_prod_unfold Let_def normalize_quot_def dvd_neg_div mult_unit_dvd_iff)

lemma quot_of_fract_diff:
  "quot_of_fract (x - y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d - b * c, b * d))" (is "_ = ?rhs")
proof -
  have "x - y = x + -y" by simp
  also have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_add quot_of_fract_uminus Let_def case_prod_unfold) simp_all
  finally show ?thesis .
qed

lemma normalize_quot_mult_coprime:
  assumes "coprime a b" "coprime c d" "unit_factor b = 1" "unit_factor d = 1"
  defines "e \<equiv> fst (normalize_quot (a, d))" and "f \<equiv> snd (normalize_quot (a, d))"
     and  "g \<equiv> fst (normalize_quot (c, b))" and "h \<equiv> snd (normalize_quot (c, b))"
  shows   "normalize_quot (a * c, b * d) = (e * g, f * h)"
proof (rule normalize_quotI)
  from assms have "gcd a b = 1" "gcd c d = 1"
    by simp_all
  from assms have "b \<noteq> 0" "d \<noteq> 0" by auto
  with assms have "normalize b = b" "normalize d = d"
    by (auto intro: normalize_unit_factor_eqI)
  from normalize_quotE [OF \<open>b \<noteq> 0\<close>, of c] obtain k
    where
      "c = fst (normalize_quot (c, b)) * k"
      "b = snd (normalize_quot (c, b)) * k"
      "k dvd c" "k dvd b" "k \<noteq> 0" .
  note k = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from normalize_quotE [OF \<open>d \<noteq> 0\<close>, of a] obtain l
    where "a = fst (normalize_quot (a, d)) * l"
      "d = snd (normalize_quot (a, d)) * l"
      "l dvd a" "l dvd d" "l \<noteq> 0" .
  note l = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from k l show "a * c * (f * h) = b * d * (e * g)"
    by (metis e_def f_def g_def h_def mult.commute mult.left_commute)
  from assms have [simp]: "unit_factor f = 1" "unit_factor h = 1"
    by simp_all
  from assms have "coprime e f" "coprime g h" by (simp_all add: coprime_normalize_quot)
  with k l assms(1,2) \<open>b \<noteq> 0\<close> \<open>d \<noteq> 0\<close> \<open>unit_factor b = 1\<close> \<open>unit_factor d = 1\<close>
    \<open>normalize b = b\<close> \<open>normalize d = d\<close>
  show "(e * g, f * h) \<in> normalized_fracts"
    by (simp add: normalized_fracts_def unit_factor_mult e_def f_def g_def h_def
      coprime_normalize_quot dvd_unit_factor_div unit_factor_gcd)
      (metis coprime_mult_left_iff coprime_mult_right_iff)
qed (insert assms(3,4), auto)

lemma normalize_quot_mult:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot (fst x * fst y, snd x * snd y) = normalize_quot
             (fst (normalize_quot x) * fst (normalize_quot y),
              snd (normalize_quot x) * snd (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] obtain d where d:
    "fst x = fst (normalize_quot x) * d"
    "snd x = snd (normalize_quot x) * d"
    "d dvd fst x"
    "d dvd snd x"
    "d \<noteq> 0" .
  from normalize_quotE'[OF assms(2)] obtain e where e:
    "fst y = fst (normalize_quot y) * e"
    "snd y = snd (normalize_quot y) * e"
    "e dvd fst y"
    "e dvd snd y"
    "e \<noteq> 0" .
  show ?thesis by (simp_all add: d e algebra_simps normalize_quot_eq_iff)
qed

lemma quot_of_fract_mult:
  "quot_of_fract (x * y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
      in  (e*g, f*h))"
  by transfer
     (simp add: split_def Let_def coprime_normalize_quot normalize_quot_mult normalize_quot_mult_coprime)

lemma normalize_quot_0 [simp]:
    "normalize_quot (0, x) = (0, 1)" "normalize_quot (x, 0) = (0, 1)"
  by (simp_all add: normalize_quot_def)

lemma normalize_quot_eq_0_iff [simp]: "fst (normalize_quot x) = 0 \<longleftrightarrow> fst x = 0 \<or> snd x = 0"
  by (auto simp: normalize_quot_def case_prod_unfold Let_def div_mult_unit2 dvd_div_eq_0_iff)

lemma fst_quot_of_fract_0_imp: "fst (quot_of_fract x) = 0 \<Longrightarrow> snd (quot_of_fract x) = 1"
  by transfer auto

lemma normalize_quot_swap:
  assumes "a \<noteq> 0" "b \<noteq> 0"
  defines "a' \<equiv> fst (normalize_quot (a, b))" and "b' \<equiv> snd (normalize_quot (a, b))"
  shows   "normalize_quot (b, a) = (b' div unit_factor a', a' div unit_factor a')"
proof (rule normalize_quotI)
  from normalize_quotE[OF assms(2), of a] obtain d where
    "a = fst (normalize_quot (a, b)) * d"
    "b = snd (normalize_quot (a, b)) * d"
    "d dvd a" "d dvd b" "d \<noteq> 0" .
  note d = this [folded assms(3,4)]
  show "b * (a' div unit_factor a') = a * (b' div unit_factor a')"
    using assms(1,2) d
    by (simp add: div_unit_factor [symmetric] unit_div_mult_swap mult_ac del: div_unit_factor)
  have "coprime a' b'" by (simp add: a'_def b'_def coprime_normalize_quot)
  thus "(b' div unit_factor a', a' div unit_factor a') \<in> normalized_fracts"
    using assms(1,2) d
    by (auto simp add: normalized_fracts_def ac_simps dvd_div_unit_iff elim: coprime_imp_coprime)
qed fact+

lemma quot_of_fract_inverse:
  "quot_of_fract (inverse x) =
     (let (a,b) = quot_of_fract x; d = unit_factor a
      in  if d = 0 then (0, 1) else (b div d, a div d))"
proof (transfer, goal_cases)
  case (1 x)
  from normalize_quot_swap[of "fst x" "snd x"] show ?case
    by (auto simp: Let_def case_prod_unfold)
qed

lemma normalize_quot_div_unit_left:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x div u, y) = (x' div u, y')"
proof (cases "y = 0")
  case False
  define v where "v = 1 div u"
  with \<open>is_unit u\<close> have "is_unit v" and u: "\<And>a. a div u = a * v"
    by simp_all
  from \<open>is_unit v\<close> have "coprime v = top"
    by (simp add: fun_eq_iff is_unit_left_imp_coprime)
  from normalize_quotE[OF False, of x] obtain d where
    "x = fst (normalize_quot (x, y)) * d"
    "y = snd (normalize_quot (x, y)) * d"
    "d dvd x" "d dvd y" "d \<noteq> 0" .
  note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1"
    by (simp_all add: coprime_normalize_quot)
  with d \<open>coprime v = top\<close> have "normalize_quot (x * v, y) = (x' * v, y')"
    by (auto simp: normalized_fracts_def intro: normalize_quotI)
  then show ?thesis
    by (simp add: u)
qed (simp_all add: assms)

lemma normalize_quot_div_unit_right:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, y div u) = (x' * u, y')"
proof (cases "y = 0")
  case False
  from normalize_quotE[OF this, of x]
  obtain d where d:
    "x = fst (normalize_quot (x, y)) * d"
    "y = snd (normalize_quot (x, y)) * d"
    "d dvd x" "d dvd y" "d \<noteq> 0" .
  note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1" by (simp_all add: coprime_normalize_quot)
  with d \<open>is_unit u\<close> show ?thesis
    by (auto simp add: normalized_fracts_def is_unit_left_imp_coprime unit_div_eq_0_iff intro: normalize_quotI)
qed (simp_all add: assms)

lemma normalize_quot_normalize_left:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (normalize x, y) = (x' div unit_factor x, y')"
  using normalize_quot_div_unit_left[of "unit_factor x" x y]
  by (cases "x = 0") (simp_all add: assms)

lemma normalize_quot_normalize_right:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, normalize y) = (x' * unit_factor y, y')"
  using normalize_quot_div_unit_right[of "unit_factor y" x y]
  by (cases "y = 0") (simp_all add: assms)

lemma quot_of_fract_0 [simp]: "quot_of_fract 0 = (0, 1)"
  by transfer auto

lemma quot_of_fract_1 [simp]: "quot_of_fract 1 = (1, 1)"
  by transfer (rule normalize_quotI, simp_all add: normalized_fracts_def)

lemma quot_of_fract_divide:
  "quot_of_fract (x / y) = (if y = 0 then (0, 1) else
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,c); (g,h) = normalize_quot (d,b)
      in  (e * g, f * h)))" (is "_ = ?rhs")
proof (cases "y = 0")
  case False
  hence A: "fst (quot_of_fract y) \<noteq> 0" by transfer auto
  have "x / y = x * inverse y" by (simp add: divide_inverse)
  also from False A have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_mult quot_of_fract_inverse)
       (simp_all add: Let_def case_prod_unfold fst_quot_of_fract_0_imp
          normalize_quot_div_unit_left normalize_quot_div_unit_right
          normalize_quot_normalize_right normalize_quot_normalize_left)
  finally show ?thesis .
qed simp_all

end


section "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text \<open>The same state more concisely:\<close>
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text \<open>A little syntax magic to write larger states compactly:\<close>

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text \<open>We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:\<close>
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text \<open>In the @{term "<a := b>"} syntax, variables that are not mentioned are 0 by default:\<close>
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text \<open>Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}.\<close>

subsection "Constant Folding"

text \<open>Evaluate constant subexpressions:\<close>

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    )"

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction )
apply (auto)
done

text \<open>Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors:\<close>

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus "

lemma aval_plus [simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply auto
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

text \<open>Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs.\<close>

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply (auto)
done

end


theory Llength_lappend
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec llength :: "'a Llist \<Rightarrow> ENat" where
"llength xs = (if lnull xs then EZ else ESuc (llength (ltl xs)))"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

(*hipster llength lappend eplus*)
lemma lemma_a [thy_expl]: "eplus x EZ = x"
  apply (coinduction  arbitrary: x rule: Llength_lappend.ENat.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "eplus EZ x = x"
apply (coinduction  arbitrary: x rule: Llength_lappend.ENat.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "eplus (ESuc x) y = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(2) eplus.code)

lemma lemma_ac [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by (metis eplus.code)

lemma lemma_ad [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
apply (coinduction  arbitrary: x y z rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by auto

lemma lemma_ae [thy_expl]: "llength (LCons y z) = ESuc (llength z)"
apply (coinduction  arbitrary: y z rule: Llength_lappend.ENat.coinduct_strong)
by simp

lemma lemma_af [thy_expl]: "lappend y LNil = y"
apply (coinduction  arbitrary: y rule: Llength_lappend.Llist.coinduct_strong)
by simp

lemma lemma_ag [thy_expl]: "lappend LNil y = y"
apply (coinduction  arbitrary: y rule: Llength_lappend.Llist.coinduct_strong)
by simp

lemma lemma_ah [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
apply (coinduction  arbitrary: y rule: Llength_lappend.Llist.coinduct_strong)
apply simp
by (smt Llist.collapse(1) Llist.sel(2) lappend.disc_iff(2) lappend.simps(3) lappend.simps(4))

lemma lemma_ai [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Llength_lappend.Llist.coinduct_strong)
by simp

lemma lemma_aj [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Llength_lappend.Llist.coinduct_strong)
apply simp
by blast

lemma lemma_ak [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
apply (coinduction  arbitrary: y rule: Llength_lappend.Llist.coinduct_strong)
apply simp
by (fastforce Llist.collapse(1) lemma_af)

lemma lemma_al [thy_expl]: "eplus (llength y) (llength z) = llength (lappend y z)"
apply (coinduction  arbitrary: y z rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by auto

lemma lemma_am [thy_expl]: "eplus y x = eplus x y"
apply (coinduction  arbitrary: x y rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(1) ENat.collapse(2) lemma_a lemma_ab)

lemma lemma_an [thy_expl]: "llength (lappend z y) = llength (lappend y z)"
apply (coinduction  arbitrary: y z rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by (metis (no_types, lifting) Llength_lappend.lemma_af Llength_lappend.lemma_al Llist.collapse(1) lemma_ab llength.code)

lemma lemma_ao [thy_expl]: "llength (ltl (lappend z y)) = llength (ltl (lappend y z))"
apply (coinduction  arbitrary: y z rule: Llength_lappend.ENat.coinduct_strong)
apply simp
by (smt Llist.case_eq_if lemma_an llength.disc_iff(1) llength.sel ltl_def)

theorem  llength_lappend: "llength (lappend xs ys) = eplus (llength xs) (llength ys)"
by hipster_coinduct_sledgehammer
end