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

(*
Copyright 2010 Christian Sternagel and René Thiemann

This file is part of IsaFoR/CeTA.

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

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

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

header {* Carriers of Strongly Normalizing Orders *}

theory SN_Order_Carrier
imports SN_Orders Rat
begin

text {*
  This theory shows that standard semirings can be used
  in combination with polynomials, e.g. the naturals, integers,
  and arbitrary Archemedean fields by using delta-orders.

  It also contains the arctic integers and arctic delta-orders where
  0 is -infty, 1 is zero, + is max and * is plus.
*}

subsection {* The standard semiring over the naturals *}

instantiation nat :: large_ordered_semiring_1
begin
instance by (intro_classes, auto)
end

definition nat_mono :: "nat \<Rightarrow> bool" where "nat_mono x \<equiv> x \<noteq> 0"

interpretation nat_SN: SN_strict_mono_ordered_semiring_1 1 "op > :: nat \<Rightarrow> nat \<Rightarrow> bool" nat_mono
  by (unfold_locales, insert SN_nat_gt, auto simp: nat_mono_def)

interpretation nat_poly: poly_order_carrier 1 "op > :: nat \<Rightarrow> nat \<Rightarrow> bool" True discrete
proof (unfold_locales)
  fix x y :: nat
  assume ge: "x \<ge> y"
  obtain k where k: "x - y = k" by auto
  show "\<exists> k. x = (op + 1 ^^ k) y"
  proof (rule exI[of _ k])
    from ge k have "x = k + y" by simp
    also have "\<dots> = (op + 1 ^^ k) y"
      by (induct k, auto)
    finally show "x = (op + 1 ^^ k) y" .
  qed
qed (auto simp: field_simps power_strict_mono)

subsection {* The standard semiring over the Archimedean fields using delta-orderings *}

definition delta_gt :: "'a :: floor_ceiling \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "delta_gt \<delta> \<equiv> (\<lambda> x y. x - y \<ge> \<delta>)"

lemma non_inf_delta_gt: assumes delta: "\<delta> > 0"
  shows "non_inf {(a,b) . delta_gt \<delta> a b}" (is "non_inf ?r")
proof
  let ?gt = "delta_gt \<delta>"
  fix a :: 'a and f
  assume "\<And> i. (f i, f (Suc i)) \<in> ?r"
  hence gt: "\<And> i. ?gt (f i) (f (Suc i))" by simp
  {
    fix i
    have "f i \<le> f 0 - \<delta> * of_nat i"
    proof (induct i)
      case (Suc i)
      thus ?case using gt[of i, unfolded delta_gt_def] by (auto simp: field_simps)
    qed simp
  } note fi = this
  {
    fix r :: 'a
    have "of_nat (nat (ceiling r)) \<ge> r"
      by (metis ceiling_le_zero le_of_int_ceiling less_le_not_le nat_0_iff not_less of_nat_0 of_nat_nat)
  } note ceil_elim = this
  def i \<equiv> "nat (ceiling ((f 0 - a) / \<delta>))"
  from fi[of i] have "f i - f 0 \<le> - \<delta> * of_nat (nat (ceiling ((f 0 - a) / \<delta>)))" unfolding i_def by simp
  also have "\<dots> \<le> - \<delta> * ((f 0 - a) / \<delta>)" using ceil_elim[of "(f 0 - a) / \<delta>"] delta
    by (metis le_imp_neg_le minus_mult_commute mult_le_cancel_left_pos)
  also have "\<dots> = - f 0 + a" using delta by auto
  also have "\<dots> < - f 0 + a + \<delta>" using delta by auto
  finally have "\<not> ?gt (f i) a" unfolding delta_gt_def by arith
  thus "\<exists> i. (f i, a) \<notin> ?r" by blast
qed

lemma delta_gt_SN: assumes dpos: "\<delta> > 0" shows "SN {(x,y). 0 \<le> y \<and> delta_gt \<delta> x y}"
proof -
  from non_inf_imp_SN_bound[OF non_inf_delta_gt[OF dpos], of "- \<delta>"]
  show ?thesis unfolding delta_gt_def by auto
qed

definition delta_mono :: "'a :: floor_ceiling \<Rightarrow> bool" where "delta_mono x \<equiv> x \<ge> 1"

subclass (in floor_ceiling) large_ordered_semiring_1
proof
  fix x :: 'a
  from ex_le_of_int[of x] obtain z where x: "x \<le> of_int z" by auto
  have "z \<le> int (nat z)" by auto
  with x have "x \<le> of_int (int (nat z))"
    by (metis (full_types) le_cases of_int_0_le_iff of_int_of_nat_eq of_nat_0_le_iff of_nat_nat order_trans)
  also have "\<dots> = of_nat (nat z)" unfolding of_int_of_nat_eq ..
  finally
  show "\<exists> y. x \<le> of_nat y" by blast
qed (auto simp: mult_right_mono mult_left_mono mult_right_mono_neg max_def)

lemma delta_interpretation: assumes dpos: "\<delta> > 0" and default: "\<delta> \<le> def"
  shows "SN_strict_mono_ordered_semiring_1 def (delta_gt \<delta>) delta_mono"
proof -
  from dpos default have defz: "0 \<le> def" by auto
  show ?thesis
  proof (unfold_locales)
    show "SN {(x,y). y \<ge> 0 \<and> delta_gt \<delta> x y}" by (rule delta_gt_SN[OF dpos])
  next
    fix x y z :: 'a
    assume "delta_mono x" and yz: "delta_gt \<delta> y z"
    hence x: "1 \<le> x" unfolding delta_mono_def by simp
    have "\<exists> d > 0. delta_gt \<delta> = (\<lambda> x y. d \<le> x - y)"
      by (rule exI[of _ \<delta>], auto simp: dpos delta_gt_def)
    from this obtain d where d: "0 < d" and rat: "delta_gt \<delta> = (\<lambda> x y. d \<le> x - y)" by auto
    from yz have yzd: "d \<le> y - z" by (simp add: rat)
    show "delta_gt \<delta> (x * y) (x * z)"
    proof (simp only: rat)
      let ?p = "(x - 1) * (y - z)"
      from x have x1: "0 \<le> x - 1" by auto
      from yzd d have yz0: "0 \<le> y - z" by auto
      have "0 \<le> ?p"
        by (rule mult_nonneg_nonneg[OF x1 yz0])
      have "x * y - x * z = x * (y - z)" using right_diff_distrib[of x y z] by auto
      also have "\<dots> = ((x - 1) + 1) * (y - z)" by auto
      also have "\<dots> = ?p + 1 * ( y - z)" by (rule ring_distribs(2))
      also have "\<dots> = ?p + (y - z)" by simp
      also have "\<dots> \<ge> (0 + d)" using yzd `0 \<le> ?p` by auto
      finally
      show "d \<le> x * y - x * z" by auto
    qed
  qed (insert dpos, auto simp: delta_gt_def default defz)
qed

lemma delta_poly: assumes dpos: "\<delta> > 0" and default: "\<delta> \<le> def"
  shows "poly_order_carrier def (delta_gt \<delta>) (1 \<le> \<delta>) False"
proof -
  from delta_interpretation[OF dpos default]
  interpret SN_strict_mono_ordered_semiring_1 "def" "delta_gt \<delta>" delta_mono .
  interpret poly_order_carrier "def" "delta_gt \<delta>" False False
  proof(unfold_locales)
    fix y z x :: 'a
    assume gt: "delta_gt \<delta> y z" and ge: "x \<ge> 1"
    from ge have ge: "x \<ge> 0" and m: "delta_mono x" unfolding delta_mono_def by auto
    show "delta_gt \<delta> (y * x) (z * x)"
      using mono[OF m gt ge] by (auto simp: field_simps)
  next
    fix x y :: 'a and n :: nat
    assume False thus "delta_gt \<delta> (x ^ n) (y ^ n)" ..
  next
    fix x y :: 'a
    assume False
    thus "\<exists> k. x = (op + 1 ^^ k) y" by simp
  qed
  show ?thesis
  proof(unfold_locales)
    fix x y :: 'a and n :: nat
    assume one: "1 \<le> \<delta>" and gt: "delta_gt \<delta> x y" and y: "y \<ge> 0" and n: "1 \<le> n"
    then obtain p where n: "n = Suc p" and x: "x \<ge> 1" and y2: "0 \<le> y" and xy: "x \<ge> y" by (cases n, auto simp: delta_gt_def)
    show "delta_gt \<delta> (x ^ n) (y ^ n)"
    proof (simp only: n, induct p, simp add: gt)
      case (Suc p)
      from times_gt_mono[OF this x]
      have one: "delta_gt \<delta> (x ^ Suc (Suc p)) (x * y ^ Suc p)" by (auto simp: field_simps)
      also have "\<dots> \<ge> y * y ^ Suc p"
        by (rule times_left_mono[OF _ xy], auto simp: zero_le_power[OF y2, of "Suc p", simplified])
      finally show ?case by auto
    qed
  next
    fix x y :: 'a
    assume False
    thus "\<exists> k. x = (op + 1 ^^ k) y" by simp
  qed (rule times_gt_mono, auto)
qed

lemma delta_minimal_delta: assumes "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> x > y"
  shows "\<exists> \<delta> > 0. \<forall> x y. (x,y) \<in> set xys \<longrightarrow> delta_gt \<delta> x y"
using assms
proof (induct xys)
  case Nil
  show ?case by (rule exI[of _ 1], auto)
next
  case (Cons xy xys)
  show ?case
  proof (cases xy)
    case (Pair x y)
    with Cons have "x > y" by auto
    then obtain d1 where "d1 = x - y" and d1pos: "d1 > 0" and "d1 \<le> x - y" by auto
    hence xy: "delta_gt d1 x y" unfolding delta_gt_def by auto
    from Cons obtain d2 where d2pos: "d2 > 0" and xys: "\<forall> x y. (x, y) \<in> set xys \<longrightarrow> delta_gt d2 x y" by auto
    obtain d where d: "d = min d1 d2" by auto
    with d1pos d2pos xy have dpos: "d > 0" and "delta_gt d x y" unfolding delta_gt_def by auto
    with xys d Pair have "\<forall> x y. (x,y) \<in> set (xy # xys) \<longrightarrow> delta_gt d x y" unfolding delta_gt_def by force
    with dpos show ?thesis by auto
  qed
qed

interpretation weak_delta_SN: weak_SN_strict_mono_ordered_semiring_1 "op >" 1 delta_mono
proof
  fix xysp :: "('a \<times> 'a) list"
  assume orient: "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> x > y"
  obtain xys where xsy: "xys = (1,0) # xysp" by auto
  with orient have "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> x > y" by auto
  with delta_minimal_delta have "\<exists> \<delta> > 0. \<forall> x y. (x,y) \<in> set xys \<longrightarrow> delta_gt \<delta> x y" by auto
  then obtain \<delta> where dpos: "\<delta> > 0" and orient: "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> delta_gt \<delta> x y" by auto
  from orient have orient1: "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> delta_gt \<delta> x y" and orient2: "delta_gt \<delta> 1 0" unfolding xsy by auto
  from orient2 have oned: "\<delta> \<le> 1" unfolding delta_gt_def by auto
  show " \<exists>gt. SN_strict_mono_ordered_semiring_1 1 gt delta_mono \<and> (\<forall>x y. (x, y) \<in> set xysp \<longrightarrow> gt x y)"
    by (intro exI conjI, rule delta_interpretation[OF dpos oned], rule orient1)
qed

subsection {* The standard semiring over the integers *}

definition int_mono :: "int \<Rightarrow> bool" where "int_mono x \<equiv> x \<ge> 1"

instantiation int :: large_ordered_semiring_1
begin
instance
proof
  fix y :: int
  show "\<exists> x. of_nat x \<ge> y"
    by (rule exI[of _ "nat y"], simp)
qed (auto simp: mult_right_mono mult_left_mono mult_right_mono_neg)
end

lemma non_inf_int_gt: "non_inf {(a,b :: int) . a > b}" (is "non_inf ?r")
  by (rule non_inf_image[OF non_inf_delta_gt, of 1 _ rat_of_int], auto simp: delta_gt_def)

interpretation int_SN: SN_strict_mono_ordered_semiring_1 1 "op > :: int \<Rightarrow> int \<Rightarrow> bool" int_mono
proof (unfold_locales)
  have [simp]: "\<And> x :: int . (-1 < x) = (0 \<le> x)" by auto
  show "SN {(x,y). y \<ge> 0 \<and> (y :: int) < x}"
    using non_inf_imp_SN_bound[OF non_inf_int_gt, of "-1"] by auto
qed (auto simp: mult_strict_left_mono int_mono_def)

interpretation int_poly: poly_order_carrier 1 "op > :: int \<Rightarrow> int \<Rightarrow> bool" True discrete
proof (unfold_locales)
  fix x y :: int
  assume ge: "x \<ge> y"
  then obtain k where k: "x - y = k" and kp: "0 \<le> k" by auto
  then obtain nk where nk: "nk = nat k" and k: "x - y = int nk" by auto
  show "\<exists> k. x = (op + 1 ^^ k) y"
  proof (rule exI[of _ nk])
    from k have "x = int nk + y" by simp
    also have "\<dots> = (op + 1 ^^ nk) y"
      by (induct nk, auto)
    finally show "x = (op + 1 ^^ nk) y" .
  qed
qed (auto simp: field_simps power_strict_mono)

subsection {* The arctic semiring over the integers *}
text {* plus is interpreted as max, times is interpreted as plus, 0 is -infinity, 1 is 0 *}

datatype arctic = MinInfty | Num_arc int

instantiation arctic :: ord
begin
fun less_eq_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> bool" where
  "less_eq_arctic MinInfty x = True"
| "less_eq_arctic (Num_arc _) MinInfty = False"
| "less_eq_arctic (Num_arc y) (Num_arc x) = (y \<le> x)"

fun less_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> bool" where
  "less_arctic MinInfty x = True"
| "less_arctic (Num_arc _) MinInfty = False"
| "less_arctic (Num_arc y) (Num_arc x) = (y < x)"

instance ..
end

instantiation arctic :: ordered_semiring_1
begin
fun plus_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> arctic" where
  "plus_arctic MinInfty y = y"
| "plus_arctic x MinInfty = x"
| "plus_arctic (Num_arc x) (Num_arc y) = (Num_arc (max x y))"

fun times_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> arctic" where
  "times_arctic MinInfty y = MinInfty"
| "times_arctic x MinInfty = MinInfty"
| "times_arctic (Num_arc x) (Num_arc y) = (Num_arc (x + y))"

definition zero_arctic :: arctic where
  "zero_arctic = MinInfty"

definition one_arctic :: arctic where
  "one_arctic = Num_arc 0"

instance
proof
  fix x y z :: arctic
  show "x + y = y + x"
    by (cases x, cases y, auto, cases y, auto)
  show "(x + y) + z = x + (y + z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x * y) * z = x * (y * z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "x * 0 = 0"
    by (cases x, auto simp: zero_arctic_def)
  show "x * (y + z) = x * y + x * z"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x + y) * z = x * z + y * z"
    by (cases x, auto, cases y, cases z, auto, cases z, auto)
  show "1 * x = x"
    by (cases x, simp_all add: one_arctic_def)
  show "x * 1 = x"
    by (cases x, simp_all add: one_arctic_def)
  show "0 + x = x"
    by (simp add: zero_arctic_def)
  show "0 * x = 0"
    by (simp add: zero_arctic_def)
  show "(0 :: arctic) \<noteq> 1"
    by (simp add: zero_arctic_def one_arctic_def)
  show "x + 0 = x" by (cases x, auto simp: zero_arctic_def)
  show "x \<ge> x"
    by (cases x, auto)
  show "(1 :: arctic) \<ge> 0"
    by (simp add: zero_arctic_def one_arctic_def)
  show "max x y = max y x" unfolding max_def
    by (cases x, (cases y, auto)+)
  show "max x y \<ge> x" unfolding max_def
    by (cases x, (cases y, auto)+)
  assume ge: "x \<ge> y"
  from ge show "x + z \<ge> y + z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "x * z \<ge> y * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "max x y = x" unfolding max_def
    by (cases x, (cases y, auto)+)
  from ge show "max z x \<ge> max z y" unfolding max_def
    by (cases z, cases x, auto, cases x, (cases y, auto)+)
next
  fix x y z :: arctic
  assume "x \<ge> y" and "y \<ge> z"
  thus "x \<ge> z"
    by (cases x, cases y, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: arctic
  assume "y \<ge> z"
  thus "x * y \<ge> x * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: arctic
  show "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"
    by (cases z, cases x, auto simp: zero_arctic_def)
qed
end

fun get_arctic_num :: "arctic \<Rightarrow> int"
where "get_arctic_num (Num_arc n) = n"

fun pos_arctic :: "arctic \<Rightarrow> bool"
where "pos_arctic MinInfty = False"
    | "pos_arctic (Num_arc n) = (0 <= n)"

interpretation arctic_SN: SN_both_mono_ordered_semiring_1 1 "op >" pos_arctic
proof
  fix x y z :: arctic
  assume "x \<ge> y" and "y > z"
  thus "x > z"
    by (cases z, simp, cases y, simp, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y" and "y \<ge> z"
  thus "x > z"
    by (cases z, simp, cases y, simp, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y"
  thus "x \<ge> y"
    by (cases x, (cases y, auto)+)
next
  fix x y z u :: arctic
  assume "x > y" and "z > u"
  thus "x + z > y + u"
    by (cases y, cases u, simp, cases z, auto, cases x, auto, cases u, auto, cases z, auto, cases x, auto, cases x, auto, cases z, auto, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y"
  thus "x * z > y * z"
    by (cases y, simp, cases z, simp, cases x, auto)
next
  fix x :: arctic
  assume "0 > x"
  thus "x = 0"
    by (cases x, auto simp: zero_arctic_def)
next
  fix x :: arctic
  show "pos_arctic 1" unfolding one_arctic_def by simp
  show "x > 0" unfolding zero_arctic_def by simp
  show "(1 :: arctic) \<ge> 0" unfolding zero_arctic_def by simp
  show "x \<ge> 0" unfolding zero_arctic_def by simp
  show "\<not> pos_arctic 0" unfolding zero_arctic_def by simp
next
  fix x y
  assume "pos_arctic x"
  thus "pos_arctic (x + y)" by (cases x, simp, cases y, auto)
next
  fix x y
  assume "pos_arctic x" and "pos_arctic y"
  thus "pos_arctic (x * y)" by (cases x, simp, cases y, auto)
next
  show "SN {(x,y). pos_arctic y \<and> x > y}" (is "SN ?rel")
  proof - {
    fix x
    assume "\<exists> f . f 0 = x \<and> (\<forall> i. (f i, f (Suc i)) \<in> ?rel)"
    from this obtain f where "f 0 = x" and seq: "\<forall> i. (f i, f (Suc i)) \<in> ?rel" by auto
    from seq have steps: "\<forall> i. f i > f (Suc i) \<and> pos_arctic (f (Suc i)) " by auto
    let ?g = "\<lambda> i. get_arctic_num (f i)"
    have "\<forall> i. ?g (Suc i) \<ge> 0 \<and> ?g i  > ?g (Suc i)"
    proof
      fix i
      from steps have i: "f i > f (Suc i) \<and> pos_arctic (f (Suc i))" by auto
      from i obtain n where fi: "f i = Num_arc n" by (cases "f (Suc i)", simp, cases "f i", auto)
      from i obtain m where fsi: "f (Suc i) = Num_arc m" by (cases "f (Suc i)", auto)
      with i have gz: "0 \<le> m" by simp
      from i fi fsi have "n > m" by auto
      with fi fsi gz
      show "?g (Suc i) \<ge> 0 \<and> ?g i > ?g (Suc i)" by auto
    qed
    from this obtain g where "\<forall> i. g (Suc i) \<ge> 0 \<and> (op > :: int \<Rightarrow> int \<Rightarrow> bool) (g i) (g (Suc i))" by auto
    hence "\<exists> f. f 0 = g 0 \<and> (\<forall> i. (f i, f (Suc i)) \<in> {(x,y). y \<ge> 0 \<and> x > y})" by auto
    with int_SN.SN have False unfolding SN_defs by auto
  }
  thus ?thesis unfolding SN_defs by auto
  qed
next
  fix y z x :: arctic
  assume "y > z"
  thus "x * y > x * z"
    by (cases x, simp, cases z, simp, cases y, auto)
next
  fix c d
  assume "pos_arctic d"
  then obtain n where d: "d = Num_arc n" and n: "0 \<le> n"
    by (cases d, auto)
  show "\<exists> e. e \<ge> 0 \<and> pos_arctic e \<and> \<not> c \<ge> d * e"
  proof (cases c)
    case MinInfty
    show ?thesis
      by (rule exI[of _ "Num_arc 0"],
        unfold d MinInfty zero_arctic_def, simp)
  next
    case (Num_arc m)
    show ?thesis
      by (rule exI[of _ "Num_arc (abs m  + 1)"], insert n,
        unfold d Num_arc zero_arctic_def, simp)
  qed
qed

subsection {* The arctic semiring over an arbitrary archimedean field *}

text {* completely analogous to the integers, where one has to use delta-orderings *}

datatype 'a arctic_delta = MinInfty_delta | Num_arc_delta 'a

instantiation arctic_delta :: (ord) ord
begin
fun less_eq_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool" where
  "less_eq_arctic_delta MinInfty_delta x = True"
| "less_eq_arctic_delta (Num_arc_delta _) MinInfty_delta = False"
| "less_eq_arctic_delta (Num_arc_delta y) (Num_arc_delta x) = (y \<le> x)"

fun less_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool" where
  "less_arctic_delta MinInfty_delta x = True"
| "less_arctic_delta (Num_arc_delta _) MinInfty_delta = False"
| "less_arctic_delta (Num_arc_delta y) (Num_arc_delta x) = (y < x)"

instance ..
end

instantiation arctic_delta :: (linordered_field) ordered_semiring_1
begin
fun plus_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta" where
  "plus_arctic_delta MinInfty_delta y = y"
| "plus_arctic_delta x MinInfty_delta = x"
| "plus_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (Num_arc_delta (max x y))"

fun times_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta" where
  "times_arctic_delta MinInfty_delta y = MinInfty_delta"
| "times_arctic_delta x MinInfty_delta = MinInfty_delta"
| "times_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (Num_arc_delta (x + y))"

definition zero_arctic_delta :: "'a arctic_delta" where
  "zero_arctic_delta = MinInfty_delta"

definition one_arctic_delta :: "'a arctic_delta" where
  "one_arctic_delta = Num_arc_delta 0"

instance
proof
  fix x y z :: "'a arctic_delta"
  show "x + y = y + x"
    by (cases x, cases y, auto, cases y, auto)
  show "(x + y) + z = x + (y + z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x * y) * z = x * (y * z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "x * 0 = 0"
    by (cases x, auto simp: zero_arctic_delta_def)
  show "x * (y + z) = x * y + x * z"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x + y) * z = x * z + y * z"
    by (cases x, auto, cases y, cases z, auto, cases z, auto)
  show "1 * x = x"
    by (cases x, simp_all add: one_arctic_delta_def)
  show "x * 1 = x"
    by (cases x, simp_all add: one_arctic_delta_def)
  show "0 + x = x"
    by (simp add: zero_arctic_delta_def)
  show "0 * x = 0"
    by (simp add: zero_arctic_delta_def)
  show "(0 :: 'a arctic_delta) \<noteq> 1"
    by (simp add: zero_arctic_delta_def one_arctic_delta_def)
  show "x + 0 = x" by (cases x, auto simp: zero_arctic_delta_def)
  show "x \<ge> x"
    by (cases x, auto)
  show "(1 :: 'a arctic_delta) \<ge> 0"
    by (simp add: zero_arctic_delta_def one_arctic_delta_def)
  show "max x y = max y x" unfolding max_def
    by (cases x, (cases y, auto)+)
  show "max x y \<ge> x" unfolding max_def
    by (cases x, (cases y, auto)+)
  assume ge: "x \<ge> y"
  from ge show "x + z \<ge> y + z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "x * z \<ge> y * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "max x y = x" unfolding max_def
    by (cases x, (cases y, auto)+)
  from ge show "max z x \<ge> max z y" unfolding max_def
    by (cases z, cases x, auto, cases x, (cases y, auto)+)
next
  fix x y z :: "'a arctic_delta"
  assume "x \<ge> y" and "y \<ge> z"
  thus "x \<ge> z"
    by (cases x, cases y, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: "'a arctic_delta"
  assume "y \<ge> z"
  thus "x * y \<ge> x * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: "'a arctic_delta"
  show "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"
    by (cases z, cases x, auto simp: zero_arctic_delta_def)
qed
end

text {* x >d y is interpreted as y = -inf or (x,y != -inf and x >d y) *}
fun gt_arctic_delta :: "'a :: floor_ceiling \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool"
where "gt_arctic_delta \<delta> _ MinInfty_delta = True"
   |  "gt_arctic_delta \<delta> MinInfty_delta (Num_arc_delta _) = False"
   |  "gt_arctic_delta \<delta> (Num_arc_delta x) (Num_arc_delta y) = delta_gt \<delta> x y"

fun get_arctic_delta_num :: "'a arctic_delta \<Rightarrow> 'a"
where "get_arctic_delta_num (Num_arc_delta n) = n"

fun pos_arctic_delta :: "('a :: floor_ceiling) arctic_delta \<Rightarrow> bool"
where "pos_arctic_delta MinInfty_delta = False"
    | "pos_arctic_delta (Num_arc_delta n) = (0 \<le> n)"

lemma arctic_delta_interpretation: assumes dpos: "\<delta> > 0" shows "SN_both_mono_ordered_semiring_1 1 (gt_arctic_delta \<delta>) pos_arctic_delta"
proof -
  from delta_interpretation[OF dpos] interpret SN_strict_mono_ordered_semiring_1 \<delta> "delta_gt \<delta>" delta_mono by simp
  show ?thesis
  proof
    fix x y z :: "'a arctic_delta"
    assume "x \<ge> y" and "gt_arctic_delta \<delta> y z"
    thus "gt_arctic_delta \<delta> x z"
      by (cases z, simp, cases y, simp, cases x, simp, simp add: compat)
  next
    fix x y z :: "'a arctic_delta"
    assume "gt_arctic_delta \<delta> x y" and "y \<ge> z"
    thus "gt_arctic_delta \<delta> x z"
      by (cases z, simp, cases y, simp, cases x, simp, simp add: compat2)
  next
    fix x y :: "'a arctic_delta"
    assume "gt_arctic_delta \<delta> x y"
    thus "x \<ge> y"
      by (cases x, insert dpos, (cases y, auto simp: delta_gt_def)+)
  next
    fix x y z u
    assume "gt_arctic_delta \<delta> x y" and "gt_arctic_delta \<delta> z u"
    thus "gt_arctic_delta \<delta> (x + z) (y + u)"
      by (cases y, cases u, simp, cases z, simp, cases x, simp, simp add: delta_gt_def,
        cases z, cases x, simp, cases u, simp, simp, cases x, simp, cases z, simp, cases u, simp add: delta_gt_def, simp add: delta_gt_def)
  next
    fix x y z
    assume "gt_arctic_delta \<delta> x y"
    thus "gt_arctic_delta \<delta> (x * z) (y * z)"
      by (cases y, simp, cases z, simp, cases x, simp, simp add: plus_gt_left_mono)
  next
    fix x
    assume "gt_arctic_delta \<delta> 0 x"
    thus "x = 0"
      by (cases x, auto simp: zero_arctic_delta_def)
  next
    fix x
    show "pos_arctic_delta 1" unfolding one_arctic_delta_def by simp
    show "gt_arctic_delta \<delta> x 0" unfolding zero_arctic_delta_def by simp
    show "(1 :: 'a arctic_delta) \<ge> 0" unfolding zero_arctic_delta_def by simp
    show "x \<ge> 0" unfolding zero_arctic_delta_def by simp
    show "\<not> pos_arctic_delta 0" unfolding zero_arctic_delta_def by simp
  next
    fix x y :: "'a arctic_delta"
    assume "pos_arctic_delta x"
    thus "pos_arctic_delta (x + y)" by (cases x, simp, cases y, auto)
  next
    fix x y :: "'a arctic_delta"
    assume "pos_arctic_delta x" and "pos_arctic_delta y"
    thus "pos_arctic_delta (x * y)" by (cases x, simp, cases y, auto)
  next
    show "SN {(x,y). pos_arctic_delta y \<and> gt_arctic_delta \<delta> x y}" (is "SN ?rel")
    proof - {
      fix x
      assume "\<exists> f . f 0 = x \<and> (\<forall> i. (f i, f (Suc i)) \<in> ?rel)"
      from this obtain f where "f 0 = x" and seq: "\<forall> i. (f i, f (Suc i)) \<in> ?rel" by auto
      from seq have steps: "\<forall> i. gt_arctic_delta \<delta> (f i) (f (Suc i)) \<and> pos_arctic_delta (f (Suc i)) " by auto
      let ?g = "\<lambda> i. get_arctic_delta_num (f i)"
      have "\<forall> i. ?g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (?g i) (?g (Suc i))"
      proof
        fix i
        from steps have i: "gt_arctic_delta \<delta> (f i) (f (Suc i)) \<and> pos_arctic_delta (f (Suc i))" by auto
        from i obtain n where fi: "f i = Num_arc_delta n" by (cases "f (Suc i)", simp, cases "f i", auto)
        from i obtain m where fsi: "f (Suc i) = Num_arc_delta m" by (cases "f (Suc i)", auto)
        with i have gz: "0 \<le> m" by simp
        from i fi fsi have "delta_gt \<delta> n m" by auto
        with fi fsi gz
        show "?g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (?g i) (?g (Suc i))" by auto
      qed
      from this obtain g where "\<forall> i. g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (g i) (g (Suc i))" by auto
      hence "\<exists> f. f 0 = g 0 \<and> (\<forall> i. (f i, f (Suc i)) \<in> {(x,y). y \<ge> 0 \<and> delta_gt \<delta> x y})" by auto
      with SN have False unfolding SN_defs by auto
    }
    thus ?thesis unfolding SN_defs by auto
    qed
  next
    fix c d :: "'a arctic_delta"
    assume "pos_arctic_delta d"
    then obtain n where d: "d = Num_arc_delta n" and n: "0 \<le> n"
      by (cases d, auto)
    show "\<exists> e. e \<ge> 0 \<and> pos_arctic_delta e \<and> \<not> c \<ge> d * e"
    proof (cases c)
      case MinInfty_delta
      show ?thesis
        by (rule exI[of _ "Num_arc_delta 0"],
          unfold d MinInfty_delta zero_arctic_delta_def, simp)
    next
      case (Num_arc_delta m)
      show ?thesis
        by (rule exI[of _ "Num_arc_delta (abs m  + 1)"], insert n,
          unfold d Num_arc_delta zero_arctic_delta_def, simp)
    qed
  next
    fix x y z
    assume gt: "gt_arctic_delta \<delta> y z"
    {
      fix x y z
      assume gt: "delta_gt \<delta> y z"
      have "delta_gt \<delta> (x + y) (x + z)"
        using plus_gt_left_mono[OF gt] by (auto simp: field_simps)
    }
    with gt show "gt_arctic_delta \<delta> (x * y) (x * z)"
      by (cases x, simp, cases z, simp, cases y, simp_all)
  qed
qed

fun weak_gt_arctic_delta :: "('a :: floor_ceiling) arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool"
where "weak_gt_arctic_delta _ MinInfty_delta = True"
   |  "weak_gt_arctic_delta MinInfty_delta (Num_arc_delta _) = False"
   |  "weak_gt_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (x > y)"

interpretation weak_arctic_delta_SN: weak_SN_both_mono_ordered_semiring_1 weak_gt_arctic_delta 1 pos_arctic_delta
proof
  fix xys
  assume orient: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt_arctic_delta x y"
  obtain xysp where xysp: "xysp = map (\<lambda> (ax, ay). (case ax of Num_arc_delta x \<Rightarrow> x , case ay of Num_arc_delta y \<Rightarrow> y)) (filter (\<lambda> (ax,ay). ax \<noteq> MinInfty_delta \<and> ay \<noteq> MinInfty_delta) xys)"
    (is "_ = map ?f _")
    by auto
  have "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> x > y"
  proof (intro allI impI)
    fix x y
    assume "(x,y) \<in> set xysp"
    with xysp obtain ax ay where "(ax,ay) \<in> set xys" and "ax \<noteq> MinInfty_delta" and "ay \<noteq> MinInfty_delta" and "(x,y) = ?f (ax,ay)" by auto
    hence "(Num_arc_delta x, Num_arc_delta y) \<in> set xys" by (cases ax, simp, cases ay, auto)
    with orient show "x > y" by force
  qed
  with delta_minimal_delta[of xysp] obtain \<delta> where dpos: "\<delta> > 0" and orient2: "\<And> x y. (x, y) \<in> set xysp \<Longrightarrow> delta_gt \<delta> x y" by auto
  have orient: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt_arctic_delta \<delta> x y"
  proof(intro allI impI)
    fix ax ay
    assume axay: "(ax,ay) \<in> set xys"
    with orient have orient: "weak_gt_arctic_delta ax ay" by auto
    show "gt_arctic_delta \<delta> ax ay"
    proof (cases ay, simp)
      case (Num_arc_delta y) note ay = this
      show ?thesis
      proof (cases ax)
        case MinInfty_delta
        with ay orient show ?thesis by auto
      next
        case (Num_arc_delta x) note ax = this
        from ax ay axay have "(x,y) \<in> set xysp" unfolding xysp by force
        from ax ay orient2[OF this] show ?thesis by simp
      qed
    qed
  qed
  show "\<exists>gt. SN_both_mono_ordered_semiring_1 1 gt pos_arctic_delta \<and> (\<forall>x y. (x, y) \<in> set xys \<longrightarrow> gt x y)"
    by (intro exI conjI, rule arctic_delta_interpretation[OF dpos], rule orient)
qed

end


section \<open>\<open>One_Dimensional_Spaces\<close> -- One dimensional complex vector spaces\<close>

theory One_Dimensional_Spaces
  imports
    Complex_Inner_Product
    "Complex_Bounded_Operators-Extra.Extra_Operator_Norm"
begin

text \<open>The class \<open>one_dim\<close> applies to one-dimensional vector spaces.
     Those are additionally interpreted as \<^class>\<open>complex_algebra_1\<close>s
     via the canonical isomorphism between a one-dimensional vector space and
     \<^typ>\<open>complex\<close>.\<close>
class one_dim = onb_enum + one + times + complex_inner + inverse +
  assumes one_dim_canonical_basis[simp]: "canonical_basis = [1]"
  assumes one_dim_prod_scale1: "(a *\<^sub>C 1) * (b *\<^sub>C 1) = (a*b) *\<^sub>C 1"
  assumes divide_inverse: "x / y = x * inverse y"
  assumes one_dim_inverse: "inverse (a *\<^sub>C 1) = inverse a *\<^sub>C 1"

hide_fact (open) divide_inverse (* divide_inverse from field_class, instantiated below, subsumed this one *)

instance complex :: one_dim
  apply intro_classes
  unfolding canonical_basis_complex_def is_ortho_set_def
  by (auto simp: divide_complex_def)

lemma one_cinner_one[simp]: \<open>\<langle>(1::('a::one_dim)), 1\<rangle> = 1\<close>
proof-
  include notation_norm
  have \<open>(canonical_basis::'a list) = [1::('a::one_dim)]\<close>
    by (simp add: one_dim_canonical_basis)
  hence \<open>\<parallel>1::'a::one_dim\<parallel> = 1\<close>
    by (metis is_normal list.set_intros(1))
  hence \<open>\<parallel>1::'a::one_dim\<parallel>^2 = 1\<close>
    by simp
  moreover have  \<open>\<parallel>(1::('a::one_dim))\<parallel>^2 = \<langle>(1::('a::one_dim)), 1\<rangle>\<close>
    by (metis cnorm_eq_square)
  ultimately show ?thesis by simp
qed

lemma one_cinner_a_scaleC_one[simp]: \<open>\<langle>1::('a::one_dim), a\<rangle> *\<^sub>C 1 = a\<close>
proof-
  have \<open>(canonical_basis::'a list) = [1]\<close>
    by (simp add: one_dim_canonical_basis)
  hence r2: \<open>a \<in> complex_vector.span ({1::'a})\<close>
    using  iso_tuple_UNIV_I empty_set is_generator_set list.simps(15)
    by metis
  have "(1::'a) \<notin> {}"
    by (metis equals0D)
  hence r1: \<open>\<exists> s. a = s *\<^sub>C 1\<close>
    by (metis Diff_insert_absorb r2 complex_vector.span_breakdown
        complex_vector.span_empty eq_iff_diff_eq_0 singleton_iff)
  then obtain s where s_def: \<open>a = s *\<^sub>C 1\<close>
    by blast
  have  \<open>\<langle>(1::'a), a\<rangle> = \<langle>(1::'a), s *\<^sub>C 1\<rangle>\<close>
    using \<open>a = s *\<^sub>C 1\<close>
    by simp
  also have \<open>\<dots> = s * \<langle>(1::'a), 1\<rangle>\<close>
    by simp
  also have \<open>\<dots> = s\<close>
    using one_cinner_one by auto
  finally show ?thesis
    by (simp add: s_def)
qed

lemma one_dim_apply_is_times_def:
  "\<psi> * \<phi> = (\<langle>1, \<psi>\<rangle> * \<langle>1, \<phi>\<rangle>) *\<^sub>C 1" for \<psi> :: \<open>'a::one_dim\<close>
  by (metis one_cinner_a_scaleC_one one_dim_prod_scale1)

instance one_dim \<subseteq> complex_algebra_1
proof
  fix x y z :: \<open>'a::one_dim\<close> and c :: complex
  show "(x * y) * z = x * (y * z)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "(x + y) * z = x * z + y * z"
    by (metis (no_types, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) complex_vector.vector_space_assms(3) one_dim_apply_is_times_def)
  show "x * (y + z) = x * y + x * z"
    by (metis (mono_tags, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) distrib_left one_dim_apply_is_times_def)
  show "(c *\<^sub>C x) * y = c *\<^sub>C (x * y)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "x * (c *\<^sub>C y) = c *\<^sub>C (x * y)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "1 * x = x"
    by (metis mult.left_neutral one_cinner_a_scaleC_one one_cinner_one one_dim_apply_is_times_def)
  show "x * 1 = x"
    by (simp add: one_dim_apply_is_times_def [where ?'a = 'a])
  show "(0::'a) \<noteq> 1"
    by (metis cinner_eq_zero_iff one_cinner_one zero_neq_one)
qed

instance one_dim \<subseteq> complex_normed_algebra
proof
  fix x y :: \<open>'a::one_dim\<close>
  show "norm (x * y) \<le> norm x * norm y"
  proof-
    have r1:  "cmod (\<langle>1::'a, x\<rangle>) \<le> norm (1::'a) * norm x"
      by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
    have r2: "cmod (\<langle>1::'a, y\<rangle>) \<le> norm (1::'a) * norm y"
      by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)

    have q1: "\<langle>(1::'a), 1\<rangle> = 1"
      by (simp add: )
    hence "(norm (1::'a))^2 = 1"
      by (simp add: cnorm_eq_1 power2_eq_1_iff)
    hence "norm (1::'a) = 1"
      by (smt abs_norm_cancel power2_eq_1_iff)
    hence "cmod (\<langle>1::'a, x\<rangle> * \<langle>1::'a, y\<rangle>) * norm (1::'a) = cmod (\<langle>1::'a, x\<rangle> * \<langle>1::'a, y\<rangle>)"
      by simp
    also have "\<dots> = cmod (\<langle>1::'a, x\<rangle>) * cmod (\<langle>1::'a, y\<rangle>)"
      by (simp add: norm_mult)
    also have "\<dots> \<le> norm (1::'a) * norm x * norm (1::'a) * norm y"
      by (smt \<open>norm 1 = 1\<close> mult.commute mult_cancel_right1 norm_scaleC one_cinner_a_scaleC_one)
    also have "\<dots> = norm x * norm y"
      by (simp add: \<open>norm 1 = 1\<close>)
    finally show ?thesis
      by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  qed
qed

instance one_dim \<subseteq> complex_normed_algebra_1
proof intro_classes
  show "norm (1::'a) = 1"
    by (metis complex_inner_1_left norm_eq_sqrt_cinner norm_one one_cinner_one)
qed

text \<open>This is the canonical isomorphism between any two one dimensional spaces. Specifically,
  if 1 denotes the element of the canonical basis (which is specified by type class \<^class>\<open>basis_enum\<close>,
  then \<^term>\<open>one_dim_iso\<close> is the unique isomorphism that maps 1 to 1.\<close>
definition one_dim_iso :: "'a::one_dim \<Rightarrow> 'b::one_dim"
  where "one_dim_iso a = of_complex (\<langle>1, a\<rangle>)"

lemma one_dim_iso_idem[simp]: "one_dim_iso (one_dim_iso x) = one_dim_iso x"
  by (simp add: one_dim_iso_def)

lemma one_dim_iso_id[simp]: "one_dim_iso = id"
  unfolding one_dim_iso_def
  by (auto simp add: of_complex_def)

lemma one_dim_iso_adjoint[simp]: \<open>cadjoint one_dim_iso = one_dim_iso\<close>
  apply (rule cadjoint_eqI)
  by (simp add: one_dim_iso_def of_complex_def)

lemma one_dim_iso_is_of_complex[simp]: "one_dim_iso = of_complex"
  unfolding one_dim_iso_def by auto

lemma of_complex_one_dim_iso[simp]: "of_complex (one_dim_iso \<psi>) = one_dim_iso \<psi>"
  by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

lemma one_dim_iso_of_complex[simp]: "one_dim_iso (of_complex c) = of_complex c"
  by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

lemma one_dim_iso_add[simp]:
  \<open>one_dim_iso (a + b) = one_dim_iso a + one_dim_iso b\<close>
  by (simp add: cinner_simps(2) one_dim_iso_def)

lemma one_dim_iso_minus[simp]:
  \<open>one_dim_iso (a - b) = one_dim_iso a - one_dim_iso b\<close>
  by (simp add: cinner_simps(3) one_dim_iso_def)

lemma one_dim_iso_scaleC[simp]: "one_dim_iso (c *\<^sub>C \<psi>) = c *\<^sub>C one_dim_iso \<psi>"
  by (metis cinner_scaleC_right of_complex_mult one_dim_iso_def scaleC_conv_of_complex)

lemma clinear_one_dim_iso[simp]: "clinear one_dim_iso"
  by (rule clinearI, auto)

lemma bounded_clinear_one_dim_iso[simp]: "bounded_clinear one_dim_iso"
proof (rule bounded_clinear_intro [where K = 1] , auto)
  fix x :: \<open>'a::one_dim\<close>
  show "norm (one_dim_iso x) \<le> norm x"
    by (metis (full_types) norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def
        order_refl)
qed

lemma one_dim_iso_of_one[simp]: "one_dim_iso 1 = 1"
  by (simp add: one_dim_iso_def)

lemma onorm_one_dim_iso[simp]: "onorm one_dim_iso = 1"
proof (rule onormI [where b = 1 and x = 1])
  fix x :: \<open>'a::one_dim\<close>
  have "norm (one_dim_iso x ::'b) \<le> norm x"
    by (metis eq_iff norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def)
  thus "norm (one_dim_iso (x::'a)::'b) \<le> 1 * norm x"
    by auto
  show "(1::'a) \<noteq> 0"
    by simp
  show "norm (one_dim_iso (1::'a)::'b) = 1 * norm (1::'a)"
    by auto
qed

lemma one_dim_iso_times[simp]: "one_dim_iso (\<psi> * \<phi>) = one_dim_iso \<psi> * one_dim_iso \<phi>"
  by (metis mult.left_neutral mult_scaleC_left of_complex_def one_cinner_a_scaleC_one one_dim_iso_def one_dim_iso_scaleC)

lemma one_dim_iso_of_zero[simp]: "one_dim_iso 0 = 0"
  by (simp add: complex_vector.linear_0)

lemma one_dim_iso_of_zero': "one_dim_iso x = 0 \<Longrightarrow> x = 0"
  by (metis of_complex_def of_complex_eq_0_iff one_cinner_a_scaleC_one one_dim_iso_def)

lemma one_dim_scaleC_1[simp]: "one_dim_iso x *\<^sub>C 1 = x"
  by (simp add: one_dim_iso_def)

lemma one_dim_clinear_eqI:
  assumes "(x::'a::one_dim) \<noteq> 0" and "clinear f" and "clinear g" and "f x = g x"
  shows "f = g"
proof (rule ext)
  fix y :: 'a
  from \<open>f x = g x\<close>
  have \<open>one_dim_iso x *\<^sub>C f 1 = one_dim_iso x *\<^sub>C g 1\<close>
    by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
  hence "f 1 = g 1"
    using assms(1) one_dim_iso_of_zero' by auto
  then show "f y = g y"
    by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
qed

lemma one_dim_norm: "norm x = cmod (one_dim_iso x)"
proof (subst one_dim_scaleC_1 [symmetric])
  show "norm (one_dim_iso x *\<^sub>C (1::'a)) = cmod (one_dim_iso x)"
    by (metis norm_of_complex of_complex_def)
qed

lemma one_dim_onorm:
  fixes f :: "'a::one_dim \<Rightarrow> 'b::complex_normed_vector"
  assumes "clinear f"
  shows "onorm f = norm (f 1)"
proof (rule onormI[where x=1])
  fix x :: 'a
  have "norm x * norm (f 1) \<le> norm (f 1) * norm x"
    by simp
  hence "norm (f (one_dim_iso x *\<^sub>C 1)) \<le> norm (f 1) * norm x"
    by (metis (mono_tags, lifting) assms complex_vector.linear_scale norm_scaleC one_dim_norm)
  thus "norm (f x) \<le> norm (f 1) * norm x"
    by (subst one_dim_scaleC_1 [symmetric])
qed auto

lemma one_dim_onorm':
  fixes f :: "'a::one_dim \<Rightarrow> 'b::one_dim"
  assumes "clinear f"
  shows "onorm f = cmod (one_dim_iso (f 1))"
  using assms one_dim_norm one_dim_onorm by fastforce

instance one_dim \<subseteq> zero_neq_one ..

lemma one_dim_iso_inj: "one_dim_iso x = one_dim_iso y \<Longrightarrow> x = y"
  by (metis one_dim_iso_idem one_dim_scaleC_1)

instance one_dim \<subseteq> comm_ring
proof intro_classes
  fix x y z :: 'a
  show "x * y = y * x"
    by (metis one_dim_apply_is_times_def ordered_field_class.sign_simps(5))
  show "(x + y) * z = x * z + y * z"
    by (simp add: ring_class.ring_distribs(2))
qed

instance one_dim \<subseteq> field
proof intro_classes
  fix x y z :: \<open>'a::one_dim\<close>
  show "1 * x = x"
    by simp

  have "(inverse \<langle>1, x\<rangle> * \<langle>1, x\<rangle>) *\<^sub>C (1::'a) = 1" if "x \<noteq> 0"
    by (metis left_inverse of_complex_def one_cinner_a_scaleC_one one_dim_iso_of_zero
        one_dim_iso_is_of_complex one_dim_iso_of_one that)
  hence "inverse (\<langle>1, x\<rangle> *\<^sub>C 1) * \<langle>1, x\<rangle> *\<^sub>C 1 = (1::'a)" if "x \<noteq> 0"
    by (metis one_dim_inverse one_dim_prod_scale1 that)
  hence "inverse (\<langle>1, x\<rangle> *\<^sub>C 1) * x = 1" if "x \<noteq> 0"
    using one_cinner_a_scaleC_one[of x, symmetric] that by auto
  thus "inverse x * x = 1" if "x \<noteq> 0"
    by (simp add: that)
  show "x / y = x * inverse y"
    by (simp add: one_dim_class.divide_inverse)
  show "inverse (0::'a) = 0"
    by (subst complex_vector.scale_zero_left[symmetric], subst one_dim_inverse, simp)
qed

instance one_dim \<subseteq> complex_normed_field
proof intro_classes
  fix x y :: 'a
  show "norm (x * y) = norm x * norm y"
    by (metis norm_mult one_dim_iso_times one_dim_norm)
qed

instance one_dim \<subseteq> chilbert_space..

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Representing Intensional Logic\<close>

theory Intensional
imports Main
begin

text\<open>
  In higher-order logic, every proof rule has a corresponding tautology, i.e.
  the \emph{deduction theorem} holds. Isabelle/HOL implements this since object-level
  implication ($\longrightarrow$) and meta-level entailment ($\Longrightarrow$)
  commute, viz. the proof rule \<open>impI:\<close> @{thm impI}.
  However, the deduction theorem does not hold for
  most modal and temporal logics \<^cite>\<open>\<open>page 95\<close> in "Lamport02"\<close>\<^cite>\<open>"Merz98"\<close>.
  For example $A \vdash \Box A$ holds, meaning that if $A$ holds in any world, then
  it always holds. However, $\vdash A \longrightarrow \Box A$, stating that
  $A$ always holds if it initially holds, is not valid.

  Merz  \<^cite>\<open>"Merz98"\<close> overcame this problem by creating an
  @{term Intensional} logic. It exploits Isabelle's
  axiomatic type class feature  \<^cite>\<open>"Wenzel00b"\<close> by creating a type
  class @{term world}, which provides Skolem constants to associate formulas
  with the world they hold in. The class is trivial, not requiring any axioms.
\<close>

class world
text \<open>
  @{term world} is a type class of possible worlds. It is a subclass
  of all HOL types @{term type}. No axioms are provided, since its only
  purpose is to avoid silly use of the @{term Intensional} syntax.
\<close>

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

type_synonym ('w,'a) expr = "'w \<Rightarrow> 'a"
type_synonym  'w form = "('w, bool) expr"

text \<open>The intention is that @{typ 'a} will be used for unlifted
types (class @{term type}), while @{typ 'w} is lifted (class @{term world}).
\<close>

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

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

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

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

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

definition lift4 :: "['a \<Rightarrow> 'b => 'c \<Rightarrow> 'd \<Rightarrow> 'e, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr,('w,'d) expr] \<Rightarrow> ('w,'e) expr"
  where unl_lift4: "lift4 f x y z zz w \<equiv> f (x w) (y w) (z w) (zz w)"

text \<open>
  @{term "Valid F"} asserts that the lifted formula @{term F} holds everywhere.
  @{term const} allows lifting of a constant, while @{term lift} through
  @{term lift4} allow functions with arity 1--4 to be lifted. (Note that there
  is no way to define a generic lifting operator for functions of arbitrary arity.)
\<close>

definition RAll :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rall " 10)
  where unl_Rall: "(Rall x. A x) w \<equiv> \<forall>x. A x w"

definition REx :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex " 10)
  where unl_Rex: "(Rex x. A x) w \<equiv> \<exists>x. A x w"

definition REx1 :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex! " 10)
  where unl_Rex1: "(Rex! x. A x) w \<equiv> \<exists>!x. A x w"

text \<open>
  @{term RAll}, @{term REx} and @{term REx1} introduces ``rigid'' quantification
  over values (of non-world types) within ``intensional'' formulas. @{term RAll}
  is universal quantification, @{term REx} is existential quantifcation.
  @{term REx1} requires unique existence.
\<close>

text \<open>
  We declare the ``unlifting rules'' as rewrite rules that will be applied
  automatically.
\<close>

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

subsection\<open>Concrete Syntax\<close>

nonterminal
  lift and liftargs

text\<open>
  The non-terminal @{term lift} represents lifted expressions. The idea is to use
  Isabelle's macro mechanism to convert between the concrete and abstract syntax.
\<close>

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

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

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

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

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

translations
  "_const"        \<rightleftharpoons>  "CONST const"

translations
  "_lift"         \<rightleftharpoons> "CONST lift"
  "_lift2"        \<rightleftharpoons> "CONST lift2"
  "_lift3"        \<rightleftharpoons> "CONST lift3"
  "_lift4"        \<rightleftharpoons> "CONST lift4"
  "_Valid"        \<rightleftharpoons> "CONST Valid"

translations
  "_RAll x A"     \<rightleftharpoons> "Rall x. A"
  "_REx x A"      \<rightleftharpoons> "Rex x. A"
  "_REx1 x A"     \<rightleftharpoons> "Rex! x. A"

translations
  "_ARAll"        \<rightharpoonup>  "_RAll"
  "_AREx"         \<rightharpoonup> "_REx"
  "_AREx1"        \<rightharpoonup> "_REx1"

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

translations
  "_liftEqu"      \<rightleftharpoons> "_lift2 (=)"
  "_liftNeq u v"  \<rightleftharpoons> "_liftNot (_liftEqu u v)"
  "_liftNot"      \<rightleftharpoons> "_lift (CONST Not)"
  "_liftAnd"      \<rightleftharpoons> "_lift2 (&)"
  "_liftOr"       \<rightleftharpoons> "_lift2 ((|) )"
  "_liftImp"      \<rightleftharpoons> "_lift2 (-->)"
  "_liftIf"       \<rightleftharpoons> "_lift3 (CONST If)"
  "_liftPlus"     \<rightleftharpoons> "_lift2 (+)"
  "_liftMinus"    \<rightleftharpoons> "_lift2 (-)"
  "_liftTimes"    \<rightleftharpoons> "_lift2 (*)"
  "_liftDiv"      \<rightleftharpoons> "_lift2 (div)"
 "_liftMod"      \<rightleftharpoons> "_lift2 (mod)"
  "_liftLess"     \<rightleftharpoons> "_lift2 (<)"
  "_liftLeq"      \<rightleftharpoons> "_lift2 (<=)"
  "_liftMem"      \<rightleftharpoons> "_lift2 (:)"
  "_liftNotMem x xs"             \<rightleftharpoons> "_liftNot (_liftMem x xs)"

translations
  "_liftFinset (_liftargs x xs)" \<rightleftharpoons> "_lift2 (CONST insert) x (_liftFinset xs)"
  "_liftFinset x"                \<rightleftharpoons> "_lift2 (CONST insert) x (_const (CONST Set.empty))"
  "_liftPair x (_liftargs y z)"  \<rightleftharpoons> "_liftPair x (_liftPair y z)"
  "_liftPair"                    \<rightleftharpoons> "_lift2 (CONST Pair)"
  "_liftCons"                    \<rightleftharpoons> "_lift2 (CONST Cons)"
  "_liftApp"                     \<rightleftharpoons> "_lift2 (@)"
  "_liftList (_liftargs x xs)"   \<rightleftharpoons> "_liftCons x (_liftList xs)"
  "_liftList x"                  \<rightleftharpoons> "_liftCons x (_const [])"

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

syntax (ASCII)
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(|- _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ |= _)" [100,10] 10)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ ~=/ _)" [50,51] 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("(~ _)" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ &/ _)" [36,35] 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                ("(_ |/ _)" [31,30] 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ -->/ _)" [26,25] 25)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ <= _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ : _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ ~: _)" [50, 51] 50)
  "_RAll" :: "[idts, lift] \<Rightarrow> lift"                      ("(3ALL _./ _)" [0, 10] 10)
  "_REx"  :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX _./ _)" [0, 10] 10)
  "_REx1" :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX! _./ _)" [0, 10] 10)

subsection \<open>Lemmas and Tactics\<close>

lemma intD[dest]: "\<turnstile> A \<Longrightarrow> w \<Turnstile> A"
proof -
  assume a:"\<turnstile> A"
  from a have "\<forall>w. w \<Turnstile> A" by (auto simp add: Valid_def)
  thus ?thesis ..
qed

lemma intI [intro!]: assumes P1:"(\<And> w. w \<Turnstile> A)" shows "\<turnstile> A"
  using assms by (auto simp: Valid_def)

text\<open>
  Basic unlifting introduces a parameter @{term w} and applies basic rewrites, e.g
  @{term "\<turnstile> F = G"} becomes @{term "F w = G w"} and @{term "\<turnstile> F \<longrightarrow> G"} becomes
  @{term "F w \<longrightarrow> G w"}.
\<close>

method_setup int_unlift = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (resolve_tac ctxt @{thms intI} THEN' rewrite_goal_tac ctxt @{thms intensional_rews}))
\<close> "method to unlift and followed by intensional rewrites"

lemma inteq_reflection: assumes P1: "\<turnstile> x=y" shows  "(x \<equiv> y)"
proof -
  from P1 have P2: "\<forall>w. x w = y w" by (unfold Valid_def unl_lift2)
  hence P3:"x=y" by blast
  thus "x \<equiv> y" by (rule "eq_reflection")
qed

lemma int_simps:
  "\<turnstile> (x=x) = #True"
  "\<turnstile> (\<not> #True) = #False"
  "\<turnstile> (\<not> #False) = #True"
  "\<turnstile> (\<not>\<not> P) = P"
  "\<turnstile> ((\<not> P) = P) = #False"
  "\<turnstile> (P = (\<not>P)) = #False"
  "\<turnstile> (P \<noteq> Q) = (P = (\<not> Q))"
  "\<turnstile> (#True=P) = P"
  "\<turnstile> (P=#True) = P"
  "\<turnstile> (#True \<longrightarrow> P) = P"
  "\<turnstile> (#False \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #True) = #True"
  "\<turnstile> (P \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #False) = (\<not>P)"
  "\<turnstile> (P \<longrightarrow> ~P) = (\<not>P)"
  "\<turnstile> (P \<and> #True) = P"
  "\<turnstile> (#True \<and> P) = P"
  "\<turnstile> (P \<and> #False) = #False"
  "\<turnstile> (#False \<and> P) = #False"
  "\<turnstile> (P \<and> P) = P"
  "\<turnstile> (P \<and> ~P) = #False"
  "\<turnstile> (\<not>P \<and> P) = #False"
  "\<turnstile> (P \<or> #True) = #True"
  "\<turnstile> (#True \<or> P) = #True"
  "\<turnstile> (P \<or> #False) = P"
  "\<turnstile> (#False \<or> P) = P"
  "\<turnstile> (P \<or> P) = P"
  "\<turnstile> (P \<or> \<not>P) = #True"
  "\<turnstile> (\<not>P \<or> P) = #True"
  "\<turnstile> (\<forall> x. P) = P"
  "\<turnstile> (\<exists> x. P) = P"
  by auto

lemmas intensional_simps[simp] = int_simps[THEN inteq_reflection]

method_setup int_rewrite = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (rewrite_goal_tac ctxt @{thms intensional_simps}))
\<close> "rewrite method at intensional level"

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

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

lemma TrueW [simp]: "\<turnstile> #True"
  by auto

lemma int_eq: "\<turnstile> X = Y \<Longrightarrow> X = Y"
  by (auto simp: inteq_reflection)

lemma int_iffI:
  assumes "\<turnstile> F \<longrightarrow> G" and "\<turnstile> G \<longrightarrow> F"
  shows "\<turnstile> F = G"
  using assms by force

lemma int_iffD1: assumes h: "\<turnstile> F = G" shows "\<turnstile> F \<longrightarrow> G"
  using h by auto

lemma int_iffD2: assumes h: "\<turnstile> F = G" shows "\<turnstile> G \<longrightarrow> F"
  using h by auto

lemma lift_imp_trans:
  assumes "\<turnstile> A \<longrightarrow> B" and "\<turnstile> B \<longrightarrow> C"
  shows "\<turnstile> A \<longrightarrow> C"
  using assms by force

lemma lift_imp_neg: assumes "\<turnstile> A \<longrightarrow> B" shows "\<turnstile> \<not>B \<longrightarrow> \<not>A"
  using assms by auto

lemma lift_and_com:  "\<turnstile> (A \<and> B) = (B \<and> A)"
  by auto

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Miscellaneous library definitions and lemmas.
*)

header "Distinct Proposition"

theory DistinctProp
imports
  "../lib/Lib"
  "~~/src/HOL/Library/Sublist"
begin

text {* distinct\_prop *}

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs)
    = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  apply (induct xs)
   apply simp
  apply simp
  done

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  apply (induct xs arbitrary: ys)
   apply simp
  apply (simp add: conj_ac ball_Un)
  done

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk>
     \<Longrightarrow> distinct_prop P xs"
  apply (induct xs)
   apply simp
  apply clarsimp
  apply blast
  done

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

end