(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_04
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun double :: "Nat => Nat" where
  "double (Z) = Z"
| "double (S z) = S (S (double z))"

theorem property0 :
  "((length (x y y)) = (double (length y)))"
  (*why not "induct y"?*)
  apply(induct rule:length.induct)
   apply auto[1]
  apply clarsimp
  apply(subgoal_tac "\<And>z xs. TIP_prop_04.length (x xs xs) = double (TIP_prop_04.length xs) \<longrightarrow>
            TIP_prop_04.length (x xs (cons2 z xs)) = S (double (TIP_prop_04.length xs))")
   apply fastforce
  apply(thin_tac "TIP_prop_04.length (x xs xs) = double (TIP_prop_04.length xs)")
  apply(subgoal_tac "\<And>z xs za xsa dlenxsa.
       TIP_prop_04.length (x xsa xsa) = dlenxsa \<longrightarrow>
       TIP_prop_04.length (x xsa (cons2 za xsa)) = S dlenxsa")
   apply fastforce
  apply(induct_tac xsaa rule:x.induct)
   apply clarsimp
   apply(induct_tac rule:x.induct)
  oops

end


theory ch62
imports Main
begin

section{* blast *}

text{*
 Most simple proofs in FOL and set theory are automatic.
 Example: if T is total, A is antisymmetric
 and T is a subset of A, then A is a subset of T.
*}

lemma AT:
  "\<lbrakk> \<forall>x y. T x y \<or> T y x;
     \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
     \<forall>x y. T x y \<longrightarrow> A x y \<rbrakk>
   \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
by blast

text{* The proof: *}
prf AT

lemma "(\<Union>i\<in>I. A i \<union> B i) = (\<Union>i\<in>I. A i) \<union> (\<Union>i\<in>I. B i)"
by blast

text{* Beyond blast (for pure logic): metis *}

lemma "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
by metis

lemma "(\<forall>x. \<exists>y. P x y) \<longleftrightarrow> (\<exists>f. \<forall>x. P x (f x))"
by metis

lemma "lives agatha \<and> lives butler \<and> lives charles \<and>
       (killed agatha agatha \<or> killed butler agatha \<or> killed charles agatha) \<and>
       (\<forall>x y. killed x y \<longrightarrow> hates x y \<and> \<not> richer x y) \<and>
       (\<forall>x. hates agatha x \<longrightarrow> \<not> hates charles x) \<and>
       hates agatha agatha \<and> hates agatha charles \<and>
       (\<forall>x. lives x \<and> \<not> richer x agatha \<longrightarrow> hates butler x) \<and>
       (\<forall>x. hates agatha x \<longrightarrow> hates butler x) \<and>
       (\<forall>x. \<not> hates x agatha \<or> \<not> hates x butler \<and> \<not> hates x charles) \<longrightarrow>
       (\<exists>x. killed x agatha)"
by metis

text{* Beyond pure logic: *}

lemma "R^* \<subseteq> (R \<union> S)^*"
oops

section{* Sledgehammer!!! *}

lemma "(i::int) div k = 0  \<longleftrightarrow>  k=0 | 0<=i & i<k | i<=0 & k<i"
 using zdiv_eq_0_iff by blast

section{* Arithmetic *}

lemma "\<forall> (k::nat) > 7. \<exists> i j. k = 3*i + 5*j"
by arith

text{* \<rightarrow> Frobenius number *}

lemma "(x::nat)^2 + y^2 + z^2 = 1 \<Longrightarrow> (x + y + z)^2 \<le> 3"
  sledgehammer
  by (metis (no_types, lifting) One_nat_def Suc_leI add.left_neutral add_cancel_left_right add_right_cancel le_neq_trans le_numeral_extra(4) less_imp_le neq0_conv not_add_less2 numeral_le_one_iff semiring_norm(70) zero_eq_power2)

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Direct Products *}

theory Relation_Algebra_Direct_Products
  imports Relation_Algebra_Functions
begin

text {* This section uses the definition of direct products from Schmidt and
Str\"ohlein's book to prove the well known universal property. *}

context relation_algebra
begin

definition is_direct_product :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "is_direct_product x y \<equiv> x\<^sup>\<smile> ; x = 1' \<and> y\<^sup>\<smile> ; y = 1' \<and> x ; x\<^sup>\<smile> \<cdot> y ; y\<^sup>\<smile> = 1' \<and> x\<^sup>\<smile> ; y = 1"

text {* We collect some basic properties. *}

lemma dp_p_fun1: "is_direct_product x y \<Longrightarrow> is_p_fun x"
by (metis is_direct_product_def eq_refl is_p_fun_def)

lemma dp_sur1: "is_direct_product x y \<Longrightarrow> is_sur x"
by (metis is_direct_product_def eq_refl is_sur_def)

lemma dp_total1: "is_direct_product x y \<Longrightarrow> is_total x"
by (metis is_direct_product_def inf_le1 is_total_def)

lemma dp_map1: "is_direct_product x y \<Longrightarrow> is_map x"
by (metis dp_p_fun1 dp_total1 is_map_def)

lemma dp_p_fun2: "is_direct_product x y \<Longrightarrow> is_p_fun y"
by (metis is_direct_product_def eq_refl is_p_fun_def)

lemma dp_sur2: "is_direct_product x y \<Longrightarrow> is_sur y"
by (metis is_direct_product_def eq_refl is_sur_def)

lemma dp_total2: "is_direct_product x y \<Longrightarrow> is_total y"
by (metis is_direct_product_def inf_le2 is_total_def)

lemma dp_map2: "is_direct_product x y \<Longrightarrow> is_map y"
by (metis dp_p_fun2 dp_total2 is_map_def)

text {*Next we prove four auxiliary lemmas. *}

lemma dp_aux1 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "x\<^sup>\<smile> ; z = 1"
  shows "(w ; x\<^sup>\<smile> \<cdot> y ; z\<^sup>\<smile>) ; z = y"
by (metis assms inf_top_left mult.assoc ss_422iii total_one inf.commute inf_top_right)

lemma dp_aux2 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "z\<^sup>\<smile> ; x = 1"
  shows "(w ; x\<^sup>\<smile> \<cdot> y ; z\<^sup>\<smile>) ; z = y"
by (metis assms conv_contrav conv_invol conv_one inf_top_left mult.assoc ss_422iii total_one)

lemma dp_aux3 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "x\<^sup>\<smile> ; z = 1"
  shows "(y ; z\<^sup>\<smile> \<cdot> w ; x\<^sup>\<smile>) ; z = y"
by (metis assms dp_aux1 inf.commute)

lemma dp_aux4 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "z\<^sup>\<smile> ; x = 1"
  shows "( y ; z\<^sup>\<smile> \<cdot> w ; x\<^sup>\<smile>) ; z = y"
by (metis assms dp_aux2 inf.commute)

text {* Next we define a function which is an isomorphism on projections. *}

definition Phi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Phi>")
  where "\<Phi> \<equiv> (\<lambda>w x y z. w ; y\<^sup>\<smile> \<cdot> x ; z\<^sup>\<smile>)"

lemma Phi_conv: "(\<Phi> w x y z)\<^sup>\<smile> = y ; w\<^sup>\<smile> \<cdot> z ; x\<^sup>\<smile>"
by (simp add: Phi_def)

text {* We prove that @{const Phi} is an isomorphism with respect to the
projections. *}

lemma mono_dp_1:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "\<Phi> w x y z ; y = w"
by (metis assms dp_aux4 is_direct_product_def dp_p_fun1 dp_total2 Phi_def)

lemma mono_dp_2:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "\<Phi> w x y z ; z = x"
by (metis assms dp_aux1 is_direct_product_def dp_p_fun2 dp_total1 Phi_def)

text {* We now show that @{const Phi} is an injective function. *}

lemma Phi_map:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_map (\<Phi> w x y z)"
proof -
  have "\<Phi> w x y z ; -(1') = \<Phi> w x y z ; -(y ; y\<^sup>\<smile> \<cdot> z ; z\<^sup>\<smile>)"
    by (metis assms(2) is_direct_product_def)
  also have "... = \<Phi> w x y z ; y ; -(y\<^sup>\<smile>) + \<Phi> w x y z ; z ; -(z\<^sup>\<smile>)"
   by (metis compl_inf assms(2) ss43iii dp_map1 dp_map2 mult.assoc distrib_left)
 also have "... = w ; -(y\<^sup>\<smile>) + x ; -(z\<^sup>\<smile>)"
   by (metis assms mono_dp_1 mono_dp_2)
 also have "... = -(w ; y\<^sup>\<smile>) + -(x ; z\<^sup>\<smile>)"
   by (metis assms(1) ss43iii dp_map1 dp_map2)
 also have "... = -(\<Phi> w x y z)"
   by (metis compl_inf Phi_def)
 finally show ?thesis
   by (metis is_maprop)
qed

lemma Phi_inj:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_inj (\<Phi> w x y z)"
by (metis Phi_def Phi_conv Phi_map assms inj_p_fun is_map_def)

text {* Next we show that the converse of @{const Phi} is an injective
function. *}

lemma Phi_conv_map:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_map ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_conv Phi_def Phi_map assms)

lemma Phi_conv_inj:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_inj ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_inj Phi_conv Phi_def assms)

lemma Phi_sur:
  assumes "is_direct_product w x"
  and "is_direct_product y z"
  shows "is_sur (\<Phi> w x y z)"
by (metis assms Phi_conv Phi_def Phi_map is_map_def sur_total)

lemma Phi_conv_sur:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_sur ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis assms Phi_conv Phi_def Phi_sur)

lemma Phi_bij:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_bij (\<Phi> w x y z)"
by (metis assms Phi_inj Phi_map Phi_sur is_bij_def)

lemma Phi_conv_bij:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_bij ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_bij Phi_def Phi_conv assms)

text {* Next we construct, for given functions~@{term f} and~@{term g}, a
function~@{term F} which makes the standard product diagram commute, and we
verify these commutation properties. *}

definition F :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "F \<equiv> (\<lambda>f x g y. f ; x\<^sup>\<smile> \<cdot> g ; y\<^sup>\<smile>)"

lemma f_proj:
  assumes "is_direct_product x y"
  and "is_map g"
  shows "F f x g y ; x = f"
by (metis assms dp_aux4 F_def is_map_def is_direct_product_def dp_p_fun1)

lemma g_proj:
  assumes "is_direct_product x y"
  and "is_map f"
  shows "F f x g y ; y = g"
by (metis assms dp_aux1 F_def is_map_def is_direct_product_def dp_p_fun2)

text {* Finally we show uniqueness of~@{const F}, hence universality of the
construction. *}

lemma
  assumes "is_direct_product x y"
  and "is_map f"
  and "is_map g"
  and "is_map G"
  and "f = G ; x"
  and "g = G ; y"
  shows "G = F f x g y"
proof -
  have "F f x g y = G ; (x ; x\<^sup>\<smile>) \<cdot> G ; (y ; y\<^sup>\<smile>)"
    by (metis assms(5) assms(6) F_def mult.assoc)
  also have "\<dots> = G ; (x ; x\<^sup>\<smile> \<cdot> y ; y\<^sup>\<smile>)"
    by (metis assms(4) map_distl)
  thus ?thesis
    by (metis assms(1) is_direct_product_def calculation mult.right_neutral)
qed

end (* relation_algebra *)

end


theory E2_5
  imports Main
begin

fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto n = n + (sum_upto (n - 1))"

value "sum_upto 10"

lemma sum_upto_su : "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
  done

end


theory ElGamal
  imports "CryptHOL.CryptHOL" "CryptHOL.Cyclic_Group" "Sigma_Commit_Crypto.Commitment_Schemes" "Berlekamp_Zassenhaus.Finite_Field_Factorization"
  "HOL-Number_Theory.Cong"   "Sigma_Commit_Crypto.Cyclic_Group_Ext"
  "Sigma_Commit_Crypto.Number_Theory_Aux"
  "Sigma_Commit_Crypto.Uniform_Sampling"
  "HOL-Algebra.Coset"
begin

text \<open>I formalize the ElGamal Commitment Scheme and show its correctness and soundness wrt.
it's hiding and binding property.
Sigma_Commit_Crypto.Commitment_Schemes gives the basis which outlines how commitment
schemes are formalized in Isabelle. On top of this template I define the relevant functions and show
the game-based proofs of interest, namely correctness and the hiding and the binding property.\<close>

section \<open>Assumptions\<close>

subsection \<open>Decisional Diffie Hellmann Assumption (DDH)\<close>

locale DDH = G : Cyclic_Group.cyclic_group G
for G (structure)
begin

type_synonym 'grp adversary = "'grp * 'grp * 'grp \<Rightarrow> bool spmf"

definition game :: "'a adversary \<Rightarrow> bool spmf" where
  "game \ = TRY do {
    s \<leftarrow> sample_uniform (order G);
    y \<leftarrow> sample_uniform (order G);
    r \<leftarrow> sample_uniform (order G);
    b \<leftarrow> coin_spmf;
    b' \<leftarrow> \ (if b then (\<^bold>g [^] s, \<^bold>g [^] y, \<^bold>g [^] (s*y)) else (\<^bold>g [^] s,\<^bold>g [^] y,\<^bold>g [^] r));
    return_spmf (b=b')
  } ELSE return_spmf False"

definition advantage :: "'a adversary \<Rightarrow> real"
  where "advantage \ = spmf (game \) True - 1/2" \<comment>\<open>subtract Pr random pick\<close>

(* adapted proof from Sigma_Commit_Crypto.Commitment_Schemes bind_game_alt_def  *)
lemma game_alt_def:
  "game \ =  TRY do {
    s \<leftarrow> sample_uniform (order G);
    y \<leftarrow> sample_uniform (order G);
    r \<leftarrow> sample_uniform (order G);
    b \<leftarrow> coin_spmf;
    b' \<leftarrow> \ (if b then (\<^bold>g [^] s, \<^bold>g [^] y, \<^bold>g [^] (s*y)) else (\<^bold>g [^] s,\<^bold>g [^] y,\<^bold>g [^] r));
    _::unit \<leftarrow> assert_spmf (b=b');
    return_spmf True
  } ELSE return_spmf False"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = TRY do {
    s \<leftarrow> sample_uniform (order G);
      TRY do {
      y \<leftarrow> sample_uniform (order G);
        TRY do {
        r \<leftarrow> sample_uniform (order G);
          TRY do {
          b \<leftarrow> coin_spmf;
            TRY do {
            b' \<leftarrow> \ (if b then (\<^bold>g [^] s, \<^bold>g [^] y, \<^bold>g [^] (s*y)) else (\<^bold>g [^] s,\<^bold>g [^] y,\<^bold>g [^] r));
            TRY do {
            return_spmf (b=b')
            } ELSE return_spmf False
          } ELSE return_spmf False
        } ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False
  } ELSE return_spmf False"
    unfolding split_def game_def
    by(fold try_bind_spmf_lossless2[OF lossless_return_spmf]) simp
  also have "\<dots> = TRY do {
    s \<leftarrow> sample_uniform (order G);
      TRY do {
      y \<leftarrow> sample_uniform (order G);
        TRY do {
        r \<leftarrow> sample_uniform (order G);
          TRY do {
          b \<leftarrow> coin_spmf;
            TRY do {
            b' \<leftarrow> \ (if b then (\<^bold>g [^] s, \<^bold>g [^] y, \<^bold>g [^] (s*y)) else (\<^bold>g [^] s,\<^bold>g [^] y,\<^bold>g [^] r));
            TRY do {
            _ :: unit \<leftarrow>assert_spmf (b=b');
            return_spmf True
            } ELSE return_spmf False
          } ELSE return_spmf False
        } ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False
  } ELSE return_spmf False"
    by(auto simp add: try_bind_assert_spmf try_spmf_return_spmf1 intro!: try_spmf_cong bind_spmf_cong)
  also have "\<dots> = ?rhs"
    unfolding split_def Let_def
    by(fold try_bind_spmf_lossless2[OF lossless_return_spmf]) simp
  finally show ?thesis .
qed

end

section \<open>Commitment Functions\<close>

locale ElGamal_Commit_base =
  fixes G :: "'grp Cyclic_Group.cyclic_group" (structure)
assumes prime_order: "prime (order G)"
and G_cyclic: "Cyclic_Group.cyclic_group G"
begin

type_synonym ck = "nat" (*s is Zp*)
type_synonym 'grp' vk = "'grp'"
type_synonym 'grp' plain = "'grp'"
type_synonym 'grp' commit = "'grp' * 'grp'"
type_synonym "opening" = "nat * nat" (*s and y is Zp*)

definition key_gen :: "(ck \<times> 'grp vk) spmf"
where
  "key_gen = do {
    s :: nat \<leftarrow> sample_uniform (order G);
    return_spmf (s, \<^bold>g [^] s)
  }"

definition commit :: "ck \<Rightarrow> 'grp plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit ck m = do {
    y :: nat \<leftarrow> sample_uniform (order G);
    return_spmf ((\<^bold>g [^] y, m \<otimes> (\<^bold>g [^] (ck*y))), (ck,y))
  }"

definition verify :: "'grp vk \<Rightarrow> 'grp plain \<Rightarrow> 'grp commit \<Rightarrow> opening \<Rightarrow> bool"
where
  "verify v_key m c d = (let (gy, gsy) = c; (s,y) = d in
  (\<^bold>g [^] s = v_key \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s*y) = gsy)
)"

definition valid_msg :: "'grp plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> msg \<in> carrier G" (* m \<in> carrier G*)

sublocale elgamal_commit: abstract_commitment key_gen commit verify valid_msg .

sublocale DDH_asm: DDH G
  unfolding DDH_def using G_cyclic .

end

section \<open>Commitment Proofs\<close>

locale ElGamal_Commit = ElGamal_Commit_base + cyclic_group G
begin

subsection \<open>Correctness\<close>

lemma correct:
  shows "spmf (elgamal_commit.correct_game m) True = 1"
  apply (simp add: abstract_commitment.correct_game_def commit_def verify_def key_gen_def)
  apply(simp add: Let_def bind_spmf_const lossless_weight_spmfD cong: bind_spmf_cong_simp)
  apply (simp add: DDH_asm.G.order_gt_0)
  done

theorem abstract_correct:
  shows "elgamal_commit.correct"
  unfolding abstract_commitment.correct_def using correct by blast

subsection \<open>Soundness wrt. binding (i.e. a commitment cannot be resolved to two different messages)\<close>

lemma g_pow_i_eq_i_eq: "\<^bold>g [^] (s'::nat) = \<^bold>g [^] s \<longleftrightarrow> s' mod order G = s mod order G"
proof -
  have "\<^bold>g [^] (s'::nat) = \<^bold>g [^] s \<longleftrightarrow> [s'=s] (mod order G)"
    by (rule  DDH_asm.G.pow_generator_eq_iff_cong) (simp add: DDH_asm.G.finite_carrier)
  then show ?thesis using cong_def by blast
qed

lemma assert_anding: "TRY do {
          _ :: unit \<leftarrow> assert_spmf (a);
            _ :: unit \<leftarrow> assert_spmf (b);
            return_spmf True
        } ELSE return_spmf False
    = TRY do {
          _ :: unit \<leftarrow> assert_spmf (a \<and> b);
          return_spmf True
      } ELSE return_spmf False"
  by (simp add: try_bind_assert_spmf)

lemma helping_1: "( s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
      \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy)
= ( s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                             \<and> y mod order G =y' mod order G)"
  by (auto simp: g_pow_i_eq_i_eq)

lemma helping_2: "(s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                 \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                 \<and> y mod order G =y' mod order G)
                 = (s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                  \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                  \<and> y mod order G =y' mod order G \<and>  s' mod order G = s'' mod order G)"
  by linarith

lemma helping_3 : "(m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                             \<and> y mod order G =y' mod order G \<and>  s' mod order G = s'' mod order G) = False"
proof -
  have "(m \<noteq> m' \<and> valid_msg m \<and> valid_msg m'
                \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                \<and> y mod order G =y' mod order G \<and>  s' mod order G = s'' mod order G)
                = False"
    by (metis (no_types, lifting) DDH_asm.G.generator_closed DDH_asm.G.nat_pow_closed DDH_asm.G.right_cancel g_pow_i_eq_i_eq mod_mult_cong valid_msg_def)
  then show ?thesis by blast
qed

theorem elgamal_bind: "elgamal_commit.bind_advantage \ = 0"
  including monad_normalisation
  unfolding abstract_commitment.bind_advantage_def
proof -
  have "elgamal_commit.bind_game \ = TRY do {
    (ck, vk) \<leftarrow> key_gen;
    (c, m, d, m', d') \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    let b = verify vk m c d;
    let b' = verify vk m' c d';
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False
    "
    by (simp add: elgamal_commit.bind_game_alt_def)
  also have "\<dots>= TRY do {
    (ck, vk) \<leftarrow> key_gen;
    ((gy,gsy), m, (s,y), m', (s',y')) \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    let b = verify vk m (gy,gsy) (s,y);
    let b' = verify vk m' (gy,gsy) (s',y');
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False
    "
    by (simp add: split_def)
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    ((gy,gsy), m, (s',y), m', (s'',y')) \<leftarrow> \ s;
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (\<^bold>g [^] s' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> \<^bold>g [^] s'' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy);
    return_spmf True} ELSE return_spmf False
    "
    by (simp add: verify_def key_gen_def)
  also have "\<dots> = TRY do {
     s :: nat \<leftarrow> sample_uniform (order G);
    TRY do {
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
      TRY do {
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
       _ :: unit \<leftarrow> assert_spmf (\<^bold>g [^] s' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> \<^bold>g [^] s'' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy);
        return_spmf True} ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False
    "
  unfolding split_def
  by(fold try_bind_spmf_lossless2[OF lossless_return_spmf])simp
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    TRY do {
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
      TRY do {
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                (\<^bold>g [^] s' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> \<^bold>g [^] s'' = (\<^bold>g [^] s) \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy));
        return_spmf True} ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False
    "
    using assert_anding by presburger
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                (\<^bold>g [^] s' = \<^bold>g [^] s \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> \<^bold>g [^] s'' = \<^bold>g [^] s \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy));
        return_spmf True} ELSE return_spmf False
    "
   unfolding split_def Let_def
    by(fold try_bind_spmf_lossless2[OF lossless_return_spmf]) simp
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy);
        return_spmf True} ELSE return_spmf False
    "
    using g_pow_i_eq_i_eq by simp
   also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                             \<and> y mod order G =y' mod order G);
        return_spmf True} ELSE return_spmf False
    "
     using helping_1 by algebra
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m' \<and>
                                s' mod order G = s mod order G \<and> gy = \<^bold>g [^] y \<and> m \<otimes> \<^bold>g [^] (s'*y) = gsy
                             \<and> s'' mod order G = s mod order G \<and> gy = \<^bold>g [^] y' \<and> m' \<otimes> \<^bold>g [^] (s''*y') = gsy
                             \<and> y mod order G =y' mod order G \<and>  s' mod order G = s'' mod order G);
        return_spmf True} ELSE return_spmf False
    "
    using helping_2 by algebra
  also have "\<dots> = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        _ :: unit \<leftarrow> assert_spmf (False);
        return_spmf True} ELSE return_spmf False
    "
    by (simp add: helping_3)
  also have "\<dots>= TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
      ((gy,gsy), m, (s', y), m', (s'', y')) \<leftarrow> \ s;
        return_pmf None} ELSE return_spmf False
    "
    by simp
 also have "\<dots>= return_spmf False
    "
   by (simp add: split_def)
  finally show "spmf (elgamal_commit.bind_game \) True = 0" by fastforce
qed

subsection \<open>Soundness wrt. hiding (i.e. the adversary can propose two messages, of which one will be
committed to, and the adversary cannot determine to which one the commitment belongs with more than
a 50/50 chance (coin flip))\<close>

thm  spmf.map_comp[symmetric]
thm o_def

(*
Helping Lemma for hiding.
What I would need for this lemma is that ck (which is s) is also
from sample_uniform. This is the case for the hiding game, however since first the
Adversary has to work on an input that depends on s, although s cannot change in that, I don't know
how to lift the sample_uniform bind from s into a map_spmf for s...*)
lemma sample_uniform_one_time_pad_ext:
  "map_spmf (\<lambda>y. (c', \<^bold>g [^] y, c \<otimes> (\<^bold>g [^] (ck*y)))) (sample_uniform (order G))
  = map_spmf (\<lambda>y. (c',\<^bold>g [^] y, (\<^bold>g [^] (ck*y)))) (sample_uniform (order G))"
  (is "?lhs = ?rhs")
proof -
  have triple_eq: "(\<lambda>y. (c', \<^bold>g [^] y, (\<^bold>g [^] y) [^] ck)) ` {..<order G} = {(c', x, x [^] ck) |x. x \<in> ([^]) \<^bold>g ` {..<order G}}"
    by blast
  have "?lhs = map_spmf (\<lambda>x. let (c',gy, gy') = x in (c',gy, c \<otimes> gy')) ?rhs"
    by (simp add: pmf.map_comp o_def option.map_comp DDH_asm.G.nat_pow_pow)
  also have "?rhs = spmf_of_set ((\<lambda>y. (c', \<^bold>g [^] y, \<^bold>g [^] (ck*y))) ` {..<order G})"
    apply (simp add: DDH_asm.G.carrier_conv_generator DDH_asm.G.inj_on_generator sample_uniform_def)
    apply (rule map_spmf_of_set_inj_on[of "(\<lambda>y. (c', \<^bold>g [^] y, \<^bold>g [^] (ck*y)))" "{..<order G}"])
    apply (simp add: inj_on_def)
    apply (metis inj_on_def DDH_asm.G.inj_on_generator)
    done
  also have "\<dots>= spmf_of_set ((\<lambda>y. (c', \<^bold>g [^] y, (\<^bold>g [^] y) [^] ck)) ` {..<order G})"
     by (simp add: DDH_asm.G.nat_pow_pow mult.commute)
  also have rhs: "\<dots>= spmf_of_set ({(c',x, x [^] ck) | x. x \<in> carrier G})"
    by (simp add: DDH_asm.G.carrier_conv_generator triple_eq)
  also have "map_spmf (\<lambda>x. let (c',gy, gy') = x in (c',gy, c \<otimes> gy' [^] ck)) \<dots>
  = spmf_of_set ((\<lambda>x. let (c',gy, gy') = x in (c',gy, c \<otimes> gy' [^] ck)) ` {(c',x, x [^] ck) | x. x \<in> carrier G})"
    apply(rule map_spmf_of_set_inj_on)
    apply (simp add: inj_on_def)
    done
  moreover have "(\<lambda>x. let (c',gy, gy') = x in (c',gy, c \<otimes> gy' [^] ck)) ` {(c',x, x [^] ck) | x. x \<in> carrier G}
    = {(c',x, x [^] ck) | x. x \<in> carrier G}"
    apply (rule endo_inj_surj)
      apply (simp add: DDH_asm.G.finite_carrier)
     prefer 2
     apply (simp add: inj_on_def)
    apply (simp add: subset_eq)
    sorry
  ultimately show ?thesis sorry
qed

lemma if_in_carrier: "x \<in> carrier G \<Longrightarrow> y \<in> carrier G \<Longrightarrow> (if b then x else y) \<in> carrier G"
  by presburger

lemma sample_uniform_one_time_pad_preop:
  "map_spmf (\<lambda>y. (\<^bold>g [^] y, c \<otimes> (\<^bold>g [^] (ck*y)))) (sample_uniform (order G))
  = map_spmf (\<lambda>y. (\<^bold>g [^] y, (\<^bold>g [^] (y)))) (sample_uniform (order G))"
  using DDH_asm.G.sample_uniform_one_time_pad
  sorry

lemma perfect_hiding:
  shows "spmf (elgamal_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
  including monad_normalisation
proof -
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  note [simp] = Let_def split_def
  have "elgamal_commit.hiding_game_ind_cpa (\1, \2) = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (c,d) \<leftarrow> commit ck (if b then m0 else m1);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: abstract_commitment.hiding_game_ind_cpa_def valid_msg_def)
  also have "... = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    let (ck,vk) = (s, \<^bold>g [^] s);
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
     b \<leftarrow> coin_spmf;
    y :: nat \<leftarrow> sample_uniform (order G);
    let c =(\<^bold>g [^] y, (if b then m0 else m1) \<otimes> (\<^bold>g [^] (ck*y)));
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: commit_def key_gen_def)
  also have "... = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    let (ck,vk) = (s, \<^bold>g [^] s);
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>y. (\<^bold>g [^] y, (if b then m0 else m1) \<otimes> (\<^bold>g [^] (ck*y)))) (sample_uniform (order G));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by(simp add: bind_map_spmf o_def)
  also have "... = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    ((m0, m1), \<sigma>) \<leftarrow> \1 (\<^bold>g [^] s);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>y. (\<^bold>g [^] y, (if b then m0 else m1) \<otimes> (\<^bold>g [^] (s*y)))) (sample_uniform (order G));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by simp
  also have "... = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    ((m0, m1), \<sigma>) \<leftarrow> \1 (\<^bold>g [^] s);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>y. (\<^bold>g [^] y ,(\<^bold>g [^] (y)))) (sample_uniform (order G));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    unfolding valid_msg_def
    by (simp add: sample_uniform_one_time_pad_preop)
  also have "... = TRY do {
    s :: nat \<leftarrow> sample_uniform (order G);
    ((m0, m1), \<sigma>) \<leftarrow> \1 (\<^bold>g [^] s);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    z \<leftarrow> map_spmf (\<lambda>y. (\<^bold>g [^] y, \<^bold>g [^] y)) (sample_uniform (order G));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    map_spmf((=) guess) coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
     by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis by(simp add: spmf_of_set)
qed

theorem abstract_perfect_hiding:
  shows "elgamal_commit.perfect_hiding_ind_cpa \"
proof-
  have "spmf (elgamal_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
    using perfect_hiding by fastforce
  thus ?thesis
    by(simp add: abstract_commitment.perfect_hiding_ind_cpa_def abstract_commitment.hiding_advantage_ind_cpa_def)
qed

end

end


theory ishu_examples
  imports Main
begin

(*
proof step:

A A\<rightarrow>B
---- (modus ponens)
B

(?P \<Longrightarrow> ?Q) \<Longrightarrow> ?P \<longrightarrow> ?Q

P \<Longrightarrow> Q
----
P\<rightarrow>Q

tactic applies rules to some goal (or goals) and
produces new goals (that hopefully help you finish the proof)

Once you have an empty list you showed your theorem!

Common way is reasoning backwards using tatics and facts/premises.
*)

lemma "(A \<and> B) \<longrightarrow> (B \<and> A)"
  thm impI
  apply (rule impI)
  thm conjI
  apply (rule conjI)
   apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

lemma "(A \<and> B) \<longrightarrow> (B \<and> A)"
  apply simp
done

(* sum (0 to n) = n(n+1)/2 *)
lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
  apply (induction n)
   apply simp
  apply simp
  done

end


theory Refinement
imports Setup
begin

section \<open>Program and datatype refinement \label{sec:refinement}\<close>

text \<open>
  Code generation by shallow embedding (cf.~\secref{sec:principle})
  allows to choose code equations and datatype constructors freely,
  given that some very basic syntactic properties are met; this
  flexibility opens up mechanisms for refinement which allow to extend
  the scope and quality of generated code dramatically.
\<close>

subsection \<open>Program refinement\<close>

text \<open>
  Program refinement works by choosing appropriate code equations
  explicitly (cf.~\secref{sec:equations}); as example, we use Fibonacci
  numbers:
\<close>

fun %quote fib :: "nat \<Rightarrow> nat" where
    "fib 0 = 0"
  | "fib (Suc 0) = Suc 0"
  | "fib (Suc (Suc n)) = fib n + fib (Suc n)"

text \<open>
  \noindent The runtime of the corresponding code grows exponential due
  to two recursive calls:
\<close>

text %quotetypewriter \<open>
  @{code_stmts fib (consts) fib (Haskell)}
\<close>

text \<open>
  \noindent A more efficient implementation would use dynamic
  programming, e.g.~sharing of common intermediate results between
  recursive calls.  This idea is expressed by an auxiliary operation
  which computes a Fibonacci number and its successor simultaneously:
\<close>

definition %quote fib_step :: "nat \<Rightarrow> nat \<times> nat" where
  "fib_step n = (fib (Suc n), fib n)"

text \<open>
  \noindent This operation can be implemented by recursion using
  dynamic programming:
\<close>

lemma %quote [code]:
  "fib_step 0 = (Suc 0, 0)"
  "fib_step (Suc n) = (let (m, q) = fib_step n in (m + q, m))"
  by (simp_all add: fib_step_def)

text \<open>
  \noindent What remains is to implement @{const fib} by @{const
  fib_step} as follows:
\<close>

lemma %quote [code]:
  "fib 0 = 0"
  "fib (Suc n) = fst (fib_step n)"
  by (simp_all add: fib_step_def)

text \<open>
  \noindent The resulting code shows only linear growth of runtime:
\<close>

text %quotetypewriter \<open>
  @{code_stmts fib (consts) fib fib_step (Haskell)}
\<close>

subsection \<open>Datatype refinement\<close>

text \<open>
  Selecting specific code equations \emph{and} datatype constructors
  leads to datatype refinement.  As an example, we will develop an
  alternative representation of the queue example given in
  \secref{sec:queue_example}.  The amortised representation is
  convenient for generating code but exposes its \qt{implementation}
  details, which may be cumbersome when proving theorems about it.
  Therefore, here is a simple, straightforward representation of
  queues:
\<close>

datatype %quote 'a queue = Queue "'a list"

definition %quote empty :: "'a queue" where
  "empty = Queue []"

primrec %quote enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "enqueue x (Queue xs) = Queue (xs @ [x])"

fun %quote dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
    "dequeue (Queue []) = (None, Queue [])"
  | "dequeue (Queue (x # xs)) = (Some x, Queue xs)"

text \<open>
  \noindent This we can use directly for proving;  for executing,
  we provide an alternative characterisation:
\<close>

definition %quote AQueue :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a queue" where
  "AQueue xs ys = Queue (ys @ rev xs)"

code_datatype %quote AQueue

text \<open>
  \noindent Here we define a \qt{constructor} @{const "AQueue"} which
  is defined in terms of @{text "Queue"} and interprets its arguments
  according to what the \emph{content} of an amortised queue is supposed
  to be.

  The prerequisite for datatype constructors is only syntactical: a
  constructor must be of type @{text "\<tau> = \<dots> \<Rightarrow> \<kappa> \<alpha>\<^sub>1 \<dots> \<alpha>\<^sub>n"} where @{text
  "{\<alpha>\<^sub>1, \<dots>, \<alpha>\<^sub>n}"} is exactly the set of \emph{all} type variables in
  @{text "\<tau>"}; then @{text "\<kappa>"} is its corresponding datatype.  The
  HOL datatype package by default registers any new datatype with its
  constructors, but this may be changed using @{command_def
  code_datatype}; the currently chosen constructors can be inspected
  using the @{command print_codesetup} command.

  Equipped with this, we are able to prove the following equations
  for our primitive queue operations which \qt{implement} the simple
  queues in an amortised fashion:
\<close>

lemma %quote empty_AQueue [code]:
  "empty = AQueue [] []"
  by (simp add: AQueue_def empty_def)

lemma %quote enqueue_AQueue [code]:
  "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"
  by (simp add: AQueue_def)

lemma %quote dequeue_AQueue [code]:
  "dequeue (AQueue xs []) =
    (if xs = [] then (None, AQueue [] [])
    else dequeue (AQueue [] (rev xs)))"
  "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
  by (simp_all add: AQueue_def)

text \<open>
  \noindent It is good style, although no absolute requirement, to
  provide code equations for the original artefacts of the implemented
  type, if possible; in our case, these are the datatype constructor
  @{const Queue} and the case combinator @{const case_queue}:
\<close>

lemma %quote Queue_AQueue [code]:
  "Queue = AQueue []"
  by (simp add: AQueue_def fun_eq_iff)

lemma %quote case_queue_AQueue [code]:
  "case_queue f (AQueue xs ys) = f (ys @ rev xs)"
  by (simp add: AQueue_def)

text \<open>
  \noindent The resulting code looks as expected:
\<close>

text %quotetypewriter \<open>
  @{code_stmts empty enqueue dequeue Queue case_queue (SML)}
\<close>

text \<open>
  The same techniques can also be applied to types which are not
  specified as datatypes, e.g.~type @{typ int} is originally specified
  as quotient type by means of @{command_def typedef}, but for code
  generation constants allowing construction of binary numeral values
  are used as constructors for @{typ int}.

  This approach however fails if the representation of a type demands
  invariants; this issue is discussed in the next section.
\<close>

subsection \<open>Datatype refinement involving invariants \label{sec:invariant}\<close>

text \<open>
  Datatype representation involving invariants require a dedicated
  setup for the type and its primitive operations.  As a running
  example, we implement a type @{text "'a dlist"} of list consisting
  of distinct elements.

  The first step is to decide on which representation the abstract
  type (in our example @{text "'a dlist"}) should be implemented.
  Here we choose @{text "'a list"}.  Then a conversion from the concrete
  type to the abstract type must be specified, here:
\<close>

text %quote \<open>
  @{term_type Dlist}
\<close>

text \<open>
  \noindent Next follows the specification of a suitable \emph{projection},
  i.e.~a conversion from abstract to concrete type:
\<close>

text %quote \<open>
  @{term_type list_of_dlist}
\<close>

text \<open>
  \noindent This projection must be specified such that the following
  \emph{abstract datatype certificate} can be proven:
\<close>

lemma %quote [code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (fact Dlist_list_of_dlist)

text \<open>
  \noindent Note that so far the invariant on representations
  (@{term_type distinct}) has never been mentioned explicitly:
  the invariant is only referred to implicitly: all values in
  set @{term "{xs. list_of_dlist (Dlist xs) = xs}"} are invariant,
  and in our example this is exactly @{term "{xs. distinct xs}"}.

  The primitive operations on @{typ "'a dlist"} are specified
  indirectly using the projection @{const list_of_dlist}.  For
  the empty @{text "dlist"}, @{const Dlist.empty}, we finally want
  the code equation
\<close>

text %quote \<open>
  @{term "Dlist.empty = Dlist []"}
\<close>

text \<open>
  \noindent This we have to prove indirectly as follows:
\<close>

lemma %quote [code]:
  "list_of_dlist Dlist.empty = []"
  by (fact list_of_dlist_empty)

text \<open>
  \noindent This equation logically encodes both the desired code
  equation and that the expression @{const Dlist} is applied to obeys
  the implicit invariant.  Equations for insertion and removal are
  similar:
\<close>

lemma %quote [code]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (fact list_of_dlist_insert)

lemma %quote [code]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (fact list_of_dlist_remove)

text \<open>
  \noindent Then the corresponding code is as follows:
\<close>

text %quotetypewriter \<open>
  @{code_stmts Dlist.empty Dlist.insert Dlist.remove list_of_dlist (Haskell)}
\<close>

text \<open>
  See further @{cite "Haftmann-Kraus-Kuncar-Nipkow:2013:data_refinement"}
  for the meta theory of datatype refinement involving invariants.

  Typical data structures implemented by representations involving
  invariants are available in the library, theory @{theory Mapping}
  specifies key-value-mappings (type @{typ "('a, 'b) mapping"});
  these can be implemented by red-black-trees (theory @{theory RBT}).
\<close>

end


(* Author: Tobias Nipkow *)

section \<open>2-3 Trees\<close>

theory Tree23
imports Main
begin

class height =
fixes height :: "'a \<Rightarrow> nat"

datatype 'a tree23 =
  Leaf ("\<langle>\<rangle>") |
  Node2 "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _\<rangle>") |
  Node3 "'a tree23" 'a "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _, _, _\<rangle>")

fun inorder :: "'a tree23 \<Rightarrow> 'a list" where
"inorder Leaf = []" |
"inorder(Node2 l a r) = inorder l @ a # inorder r" |
"inorder(Node3 l a m b r) = inorder l @ a # inorder m @ b # inorder r"

instantiation tree23 :: (type)height
begin

fun height_tree23 :: "'a tree23 \<Rightarrow> nat" where
"height Leaf = 0" |
"height (Node2 l _ r) = Suc(max (height l) (height r))" |
"height (Node3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

instance ..

end

text \<open>Completeness:\<close>

fun complete :: "'a tree23 \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node2 l _ r) = (height l = height r \<and> complete l & complete r)" |
"complete (Node3 l _ m _ r) =
  (height l = height m & height m = height r & complete l & complete m & complete r)"

lemma ht_sz_if_complete: "complete t \<Longrightarrow> 2 ^ height t \<le> size t + 1"
by (induction t) auto

end


(*  Title:      HOL/Conditionally_Complete_Lattices.thy
    Author:     Amine Chaieb and L C Paulson, University of Cambridge
    Author:     Johannes Hölzl, TU München
    Author:     Luke S. Serafin, Carnegie Mellon University
*)

section {* Conditionally-complete Lattices *}

theory Conditionally_Complete_Lattices
imports Main
begin

lemma (in linorder) Sup_fin_eq_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup_fin X = Max X"
  by (induct X rule: finite_ne_induct) (simp_all add: sup_max)

lemma (in linorder) Inf_fin_eq_Min: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf_fin X = Min X"
  by (induct X rule: finite_ne_induct) (simp_all add: inf_min)

context preorder
begin

definition "bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)"
definition "bdd_below A \<longleftrightarrow> (\<exists>m. \<forall>x \<in> A. m \<le> x)"

lemma bdd_aboveI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
  by (auto simp: bdd_above_def)

lemma bdd_belowI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
  by (auto simp: bdd_below_def)

lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
  by force

lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
  by force

lemma bdd_above_empty [simp, intro]: "bdd_above {}"
  unfolding bdd_above_def by auto

lemma bdd_below_empty [simp, intro]: "bdd_below {}"
  unfolding bdd_below_def by auto

lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
  by (metis (full_types) bdd_above_def order_class.le_neq_trans psubsetD)

lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
  by (metis bdd_below_def order_class.le_neq_trans psubsetD)

lemma bdd_above_Int1 [simp]: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
  using bdd_above_mono by auto

lemma bdd_above_Int2 [simp]: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
  using bdd_above_mono by auto

lemma bdd_below_Int1 [simp]: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
  using bdd_below_mono by auto

lemma bdd_below_Int2 [simp]: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
  using bdd_below_mono by auto

lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

end

lemma (in order_top) bdd_above_top[simp, intro!]: "bdd_above A"
  by (rule bdd_aboveI[of _ top]) simp

lemma (in order_bot) bdd_above_bot[simp, intro!]: "bdd_below A"
  by (rule bdd_belowI[of _ bot]) simp

lemma bdd_above_uminus[simp]:
  fixes X :: "'a::ordered_ab_group_add set"
  shows "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
  by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)

lemma bdd_below_uminus[simp]:
  fixes X :: "'a::ordered_ab_group_add set"
  shows"bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
  by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)

context lattice
begin

lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
  by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)

lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
  by (auto simp: bdd_below_def intro: le_infI2 inf_le1)

lemma bdd_finite [simp]:
  assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
  using assms by (induct rule: finite_induct, auto)

lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
proof
  assume "bdd_above (A \<union> B)"
  thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
next
  assume "bdd_above A \<and> bdd_above B"
  then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
  hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
  thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
qed

lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
proof
  assume "bdd_below (A \<union> B)"
  thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
next
  assume "bdd_below A \<and> bdd_below B"
  then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
  hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
  thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
qed

lemma bdd_above_sup[simp]: "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
  by (auto simp: bdd_above_def intro: le_supI1 le_supI2)

lemma bdd_below_inf[simp]: "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
  by (auto simp: bdd_below_def intro: le_infI1 le_infI2)

end

text {*

To avoid name classes with the @{class complete_lattice}-class we prefix @{const Sup} and
@{const Inf} in theorem names with c.

*}

class conditionally_complete_lattice = lattice + Sup + Inf +
  assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
    and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
  assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
    and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
begin

lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
  by (metis cSup_upper order_trans)

lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
  by (metis cInf_lower order_trans)

lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
  by (metis cSup_least cSup_upper2)

lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
  by (metis cInf_greatest cInf_lower2)

lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
  by (metis cSup_least cSup_upper subsetD)

lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
  by (metis cInf_greatest cInf_lower subsetD)

lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
  by (intro antisym cSup_upper[of z X] cSup_least[of X z]) auto

lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
  by (intro antisym cInf_lower[of z X] cInf_greatest[of X z]) auto

lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
  by (metis order_trans cSup_upper cSup_least)

lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
  by (metis order_trans cInf_lower cInf_greatest)

lemma cSup_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
  by (intro 3 1 antisym cSup_least) (auto intro: 2 1 cSup_upper)

lemma cInf_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
  by (intro 3 1 antisym cInf_greatest) (auto intro: 2 1 cInf_lower)

lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
  by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)

lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
  by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)

lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
  by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)

lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
  by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)

lemma cSup_singleton [simp]: "Sup {x} = x"
  by (intro cSup_eq_maximum) auto

lemma cInf_singleton [simp]: "Inf {x} = x"
  by (intro cInf_eq_minimum) auto

lemma cSup_insert_If:  "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
  using cSup_insert[of X] by simp

lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
  using cInf_insert[of X] by simp

lemma le_cSup_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le> Sup X"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cSup_insert intro: le_supI2)
qed simp

lemma cInf_le_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> Inf X \<le> x"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cInf_insert intro: le_infI2)
qed simp

lemma cSup_eq_Sup_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Sup_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cSup_insert)

lemma cInf_eq_Inf_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Inf_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cInf_insert)

lemma cSup_atMost[simp]: "Sup {..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Sup {y<..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Sup {y..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cInf_atLeast[simp]: "Inf {x..} = x"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastLessThan[simp]: "y < x \<Longrightarrow> Inf {y..<x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Inf {y..x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cINF_lower: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> INFIMUM A f \<le> f x"
  using cInf_lower [of _ "f ` A"] by simp

lemma cINF_greatest: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> m \<le> INFIMUM A f"
  using cInf_greatest [of "f ` A"] by auto

lemma cSUP_upper: "x \<in> A \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> f x \<le> SUPREMUM A f"
  using cSup_upper [of _ "f ` A"] by simp

lemma cSUP_least: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> SUPREMUM A f \<le> M"
  using cSup_least [of "f ` A"] by auto

lemma cINF_lower2: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<le> u \<Longrightarrow> INFIMUM A f \<le> u"
  by (auto intro: cINF_lower assms order_trans)

lemma cSUP_upper2: "bdd_above (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> u \<le> f x \<Longrightarrow> u \<le> SUPREMUM A f"
  by (auto intro: cSUP_upper assms order_trans)

lemma cSUP_const: "A \<noteq> {} \<Longrightarrow> (SUP x:A. c) = c"
  by (intro antisym cSUP_least) (auto intro: cSUP_upper)

lemma cINF_const: "A \<noteq> {} \<Longrightarrow> (INF x:A. c) = c"
  by (intro antisym cINF_greatest) (auto intro: cINF_lower)

lemma le_cINF_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> u \<le> INFIMUM A f \<longleftrightarrow> (\<forall>x\<in>A. u \<le> f x)"
  by (metis cINF_greatest cINF_lower assms order_trans)

lemma cSUP_le_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> SUPREMUM A f \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)"
  by (metis cSUP_least cSUP_upper assms order_trans)

lemma less_cINF_D: "bdd_below (f`A) \<Longrightarrow> y < (INF i:A. f i) \<Longrightarrow> i \<in> A \<Longrightarrow> y < f i"
  by (metis cINF_lower less_le_trans)

lemma cSUP_lessD: "bdd_above (f`A) \<Longrightarrow> (SUP i:A. f i) < y \<Longrightarrow> i \<in> A \<Longrightarrow> f i < y"
  by (metis cSUP_upper le_less_trans)

lemma cINF_insert: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> INFIMUM (insert a A) f = inf (f a) (INFIMUM A f)"
  by (metis cInf_insert Inf_image_eq image_insert image_is_empty)

lemma cSUP_insert: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> SUPREMUM (insert a A) f = sup (f a) (SUPREMUM A f)"
  by (metis cSup_insert Sup_image_eq image_insert image_is_empty)

lemma cINF_mono: "B \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> (\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> INFIMUM A f \<le> INFIMUM B g"
  using cInf_mono [of "g ` B" "f ` A"] by auto

lemma cSUP_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> (\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> SUPREMUM A f \<le> SUPREMUM B g"
  using cSup_mono [of "f ` A" "g ` B"] by auto

lemma cINF_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> g x \<le> f x) \<Longrightarrow> INFIMUM B g \<le> INFIMUM A f"
  by (rule cINF_mono) auto

lemma cSUP_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> f x \<le> g x) \<Longrightarrow> SUPREMUM A f \<le> SUPREMUM B g"
  by (rule cSUP_mono) auto

lemma less_eq_cInf_inter: "bdd_below A \<Longrightarrow> bdd_below B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> inf (Inf A) (Inf B) \<le> Inf (A \<inter> B)"
  by (metis cInf_superset_mono lattice_class.inf_sup_ord(1) le_infI1)

lemma cSup_inter_less_eq: "bdd_above A \<Longrightarrow> bdd_above B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> Sup (A \<inter> B) \<le> sup (Sup A) (Sup B) "
  by (metis cSup_subset_mono lattice_class.inf_sup_ord(1) le_supI1)

lemma cInf_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> Inf (A \<union> B) = inf (Inf A) (Inf B)"
  by (intro antisym le_infI cInf_greatest cInf_lower) (auto intro: le_infI1 le_infI2 cInf_lower)

lemma cINF_union: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below (f`B) \<Longrightarrow> INFIMUM (A \<union> B) f = inf (INFIMUM A f) (INFIMUM B f)"
  using cInf_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un [symmetric])

lemma cSup_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> Sup (A \<union> B) = sup (Sup A) (Sup B)"
  by (intro antisym le_supI cSup_least cSup_upper) (auto intro: le_supI1 le_supI2 cSup_upper)

lemma cSUP_union: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above (f`B) \<Longrightarrow> SUPREMUM (A \<union> B) f = sup (SUPREMUM A f) (SUPREMUM B f)"
  using cSup_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un [symmetric])

lemma cINF_inf_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> bdd_below (g`A) \<Longrightarrow> inf (INFIMUM A f) (INFIMUM A g) = (INF a:A. inf (f a) (g a))"
  by (intro antisym le_infI cINF_greatest cINF_lower2)
     (auto intro: le_infI1 le_infI2 cINF_greatest cINF_lower le_infI)

lemma SUP_sup_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> bdd_above (g`A) \<Longrightarrow> sup (SUPREMUM A f) (SUPREMUM A g) = (SUP a:A. sup (f a) (g a))"
  by (intro antisym le_supI cSUP_least cSUP_upper2)
     (auto intro: le_supI1 le_supI2 cSUP_least cSUP_upper le_supI)

lemma cInf_le_cSup:
  "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below A \<Longrightarrow> Inf A \<le> Sup A"
  by (auto intro!: cSup_upper2[of "SOME a. a \<in> A"] intro: someI cInf_lower)

end

instance complete_lattice \<subseteq> conditionally_complete_lattice
  by default (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)

lemma cSup_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_bot}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
proof cases
  assume "X = {}" with lt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cSup_eq_non_empty assms)

lemma cInf_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_top}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
proof cases
  assume "X = {}" with gt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cInf_eq_non_empty assms)

class conditionally_complete_linorder = conditionally_complete_lattice + linorder
begin

lemma less_cSup_iff : (*REAL_SUP_LE in HOL4*)
  "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
  by (rule iffI) (metis cSup_least not_less, metis cSup_upper less_le_trans)

lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
  by (rule iffI) (metis cInf_greatest not_less, metis cInf_lower le_less_trans)

lemma cINF_less_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> (INF i:A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
  using cInf_less_iff[of "f`A"] by auto

lemma less_cSUP_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> a < (SUP i:A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
  using less_cSup_iff[of "f`A"] by auto

lemma less_cSupE:
  assumes "y < Sup X" "X \<noteq> {}" obtains x where "x \<in> X" "y < x"
  by (metis cSup_least assms not_le that)

lemma less_cSupD:
  "X \<noteq> {} \<Longrightarrow> z < Sup X \<Longrightarrow> \<exists>x\<in>X. z < x"
  by (metis less_cSup_iff not_leE bdd_above_def)

lemma cInf_lessD:
  "X \<noteq> {} \<Longrightarrow> Inf X < z \<Longrightarrow> \<exists>x\<in>X. x < z"
  by (metis cInf_less_iff not_leE bdd_below_def)

lemma complete_interval:
  assumes "a < b" and "P a" and "\<not> P b"
  shows "\<exists>c. a \<le> c \<and> c \<le> b \<and> (\<forall>x. a \<le> x \<and> x < c \<longrightarrow> P x) \<and>
             (\<forall>d. (\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x) \<longrightarrow> d \<le> c)"
proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x & x < d --> P x}"], auto)
  show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    by (rule cSup_upper, auto simp: bdd_above_def)
       (metis `a < b` `\<not> P b` linear less_le)
next
  show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
    apply (rule cSup_least)
    apply auto
    apply (metis less_le_not_le)
    apply (metis `a<b` `~ P b` linear less_le)
    done
next
  fix x
  assume x: "a \<le> x" and lt: "x < Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
  show "P x"
    apply (rule less_cSupE [OF lt], auto)
    apply (metis less_le_not_le)
    apply (metis x)
    done
next
  fix d
    assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
    thus "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
      by (rule_tac cSup_upper, auto simp: bdd_above_def)
         (metis `a<b` `~ P b` linear less_le)
qed

end

lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
  using cSup_eq_Sup_fin[of X] Sup_fin_eq_Max[of X] by simp

lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
  using cInf_eq_Inf_fin[of X] Inf_fin_eq_Min[of X] by simp

lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le)

lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, no_top, dense_linorder} <..} = x"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge)

lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

class linear_continuum = conditionally_complete_linorder + dense_linorder +
  assumes UNIV_not_singleton: "\<exists>a b::'a. a \<noteq> b"
begin

lemma ex_gt_or_lt: "\<exists>b. a < b \<or> b < a"
  by (metis UNIV_not_singleton neq_iff)

end

instantiation nat :: conditionally_complete_linorder
begin

definition "Sup (X::nat set) = Max X"
definition "Inf (X::nat set) = (LEAST n. n \<in> X)"

lemma bdd_above_nat: "bdd_above X \<longleftrightarrow> finite (X::nat set)"
proof
  assume "bdd_above X"
  then obtain z where "X \<subseteq> {.. z}"
    by (auto simp: bdd_above_def)
  then show "finite X"
    by (rule finite_subset) simp
qed simp

instance
proof
  fix x :: nat and X :: "nat set"
  { assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
      by (simp add: Inf_nat_def Least_le) }
  { assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
      unfolding Inf_nat_def ex_in_conv[symmetric] by (rule LeastI2_ex) }
  { assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
      by (simp add: Sup_nat_def bdd_above_nat) }
  { assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x"
    moreover then have "bdd_above X"
      by (auto simp: bdd_above_def)
    ultimately show "Sup X \<le> x"
      by (simp add: Sup_nat_def bdd_above_nat) }
qed
end

instantiation int :: conditionally_complete_linorder
begin

definition "Sup (X::int set) = (THE x. x \<in> X \<and> (\<forall>y\<in>X. y \<le> x))"
definition "Inf (X::int set) = - (Sup (uminus ` X))"

instance
proof
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "bdd_above X"
    then obtain x y where "X \<subseteq> {..y}" "x \<in> X"
      by (auto simp: bdd_above_def)
    then have *: "finite (X \<inter> {x..y})" "X \<inter> {x..y} \<noteq> {}" and "x \<le> y"
      by (auto simp: subset_eq)
    have "\<exists>!x\<in>X. (\<forall>y\<in>X. y \<le> x)"
    proof
      { fix z assume "z \<in> X"
        have "z \<le> Max (X \<inter> {x..y})"
        proof cases
          assume "x \<le> z" with `z \<in> X` `X \<subseteq> {..y}` *(1) show ?thesis
            by (auto intro!: Max_ge)
        next
          assume "\<not> x \<le> z"
          then have "z < x" by simp
          also have "x \<le> Max (X \<inter> {x..y})"
            using `x \<in> X` *(1) `x \<le> y` by (intro Max_ge) auto
          finally show ?thesis by simp
        qed }
      note le = this
      with Max_in[OF *] show ex: "Max (X \<inter> {x..y}) \<in> X \<and> (\<forall>z\<in>X. z \<le> Max (X \<inter> {x..y}))" by auto

      fix z assume *: "z \<in> X \<and> (\<forall>y\<in>X. y \<le> z)"
      with le have "z \<le> Max (X \<inter> {x..y})"
        by auto
      moreover have "Max (X \<inter> {x..y}) \<le> z"
        using * ex by auto
      ultimately show "z = Max (X \<inter> {x..y})"
        by auto
    qed
    then have "Sup X \<in> X \<and> (\<forall>y\<in>X. y \<le> Sup X)"
      unfolding Sup_int_def by (rule theI') }
  note Sup_int = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
      using Sup_int[of X] by auto }
  note le_Sup = this
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x" then show "Sup X \<le> x"
      using Sup_int[of X] by (auto simp: bdd_above_def) }
  note Sup_le = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
      using le_Sup[of "-x" "uminus ` X"] by (auto simp: Inf_int_def) }
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
      using Sup_le[of "uminus ` X" "-x"] by (force simp: Inf_int_def) }
qed
end

lemma interval_cases:
  fixes S :: "'a :: conditionally_complete_linorder set"
  assumes ivl: "\<And>a b x. a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<in> S"
  shows "\<exists>a b. S = {} \<or>
    S = UNIV \<or>
    S = {..<b} \<or>
    S = {..b} \<or>
    S = {a<..} \<or>
    S = {a..} \<or>
    S = {a<..<b} \<or>
    S = {a<..b} \<or>
    S = {a..<b} \<or>
    S = {a..b}"
proof -
  def lower \<equiv> "{x. \<exists>s\<in>S. s \<le> x}" and upper \<equiv> "{x. \<exists>s\<in>S. x \<le> s}"
  with ivl have "S = lower \<inter> upper"
    by auto
  moreover
  have "\<exists>a. upper = UNIV \<or> upper = {} \<or> upper = {.. a} \<or> upper = {..< a}"
  proof cases
    assume *: "bdd_above S \<and> S \<noteq> {}"
    from * have "upper \<subseteq> {.. Sup S}"
      by (auto simp: upper_def intro: cSup_upper2)
    moreover from * have "{..< Sup S} \<subseteq> upper"
      by (force simp add: less_cSup_iff upper_def subset_eq Ball_def)
    ultimately have "upper = {.. Sup S} \<or> upper = {..< Sup S}"
      unfolding ivl_disj_un(2)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_above S \<and> S \<noteq> {})"
    then have "upper = UNIV \<or> upper = {}"
      by (auto simp: upper_def bdd_above_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  moreover
  have "\<exists>b. lower = UNIV \<or> lower = {} \<or> lower = {b ..} \<or> lower = {b <..}"
  proof cases
    assume *: "bdd_below S \<and> S \<noteq> {}"
    from * have "lower \<subseteq> {Inf S ..}"
      by (auto simp: lower_def intro: cInf_lower2)
    moreover from * have "{Inf S <..} \<subseteq> lower"
      by (force simp add: cInf_less_iff lower_def subset_eq Ball_def)
    ultimately have "lower = {Inf S ..} \<or> lower = {Inf S <..}"
      unfolding ivl_disj_un(1)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_below S \<and> S \<noteq> {})"
    then have "lower = UNIV \<or> lower = {}"
      by (auto simp: lower_def bdd_below_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  ultimately show ?thesis
    unfolding greaterThanAtMost_def greaterThanLessThan_def atLeastAtMost_def atLeastLessThan_def
    by (elim exE disjE) auto
qed

end


(*  Title:      HOL/Library/Product_plus.thy
    Author:     Brian Huffman
*)

section {* Additive group operations on product types *}

theory Product_plus
imports Main
begin

subsection {* Operations *}

instantiation prod :: (zero, zero) zero
begin

definition zero_prod_def: "0 = (0, 0)"

instance ..
end

instantiation prod :: (plus, plus) plus
begin

definition plus_prod_def:
  "x + y = (fst x + fst y, snd x + snd y)"

instance ..
end

instantiation prod :: (minus, minus) minus
begin

definition minus_prod_def:
  "x - y = (fst x - fst y, snd x - snd y)"

instance ..
end

instantiation prod :: (uminus, uminus) uminus
begin

definition uminus_prod_def:
  "- x = (- fst x, - snd x)"

instance ..
end

lemma fst_zero [simp]: "fst 0 = 0"
  unfolding zero_prod_def by simp

lemma snd_zero [simp]: "snd 0 = 0"
  unfolding zero_prod_def by simp

lemma fst_add [simp]: "fst (x + y) = fst x + fst y"
  unfolding plus_prod_def by simp

lemma snd_add [simp]: "snd (x + y) = snd x + snd y"
  unfolding plus_prod_def by simp

lemma fst_diff [simp]: "fst (x - y) = fst x - fst y"
  unfolding minus_prod_def by simp

lemma snd_diff [simp]: "snd (x - y) = snd x - snd y"
  unfolding minus_prod_def by simp

lemma fst_uminus [simp]: "fst (- x) = - fst x"
  unfolding uminus_prod_def by simp

lemma snd_uminus [simp]: "snd (- x) = - snd x"
  unfolding uminus_prod_def by simp

lemma add_Pair [simp]: "(a, b) + (c, d) = (a + c, b + d)"
  unfolding plus_prod_def by simp

lemma diff_Pair [simp]: "(a, b) - (c, d) = (a - c, b - d)"
  unfolding minus_prod_def by simp

lemma uminus_Pair [simp, code]: "- (a, b) = (- a, - b)"
  unfolding uminus_prod_def by simp

subsection {* Class instances *}

instance prod :: (semigroup_add, semigroup_add) semigroup_add
  by default (simp add: prod_eq_iff add.assoc)

instance prod :: (ab_semigroup_add, ab_semigroup_add) ab_semigroup_add
  by default (simp add: prod_eq_iff add.commute)

instance prod :: (monoid_add, monoid_add) monoid_add
  by default (simp_all add: prod_eq_iff)

instance prod :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
  by default (simp add: prod_eq_iff)

instance prod ::
  (cancel_semigroup_add, cancel_semigroup_add) cancel_semigroup_add
    by default (simp_all add: prod_eq_iff)

instance prod ::
  (cancel_ab_semigroup_add, cancel_ab_semigroup_add) cancel_ab_semigroup_add
    by default (simp add: prod_eq_iff)

instance prod ::
  (cancel_comm_monoid_add, cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance prod :: (group_add, group_add) group_add
  by default (simp_all add: prod_eq_iff)

instance prod :: (ab_group_add, ab_group_add) ab_group_add
  by default (simp_all add: prod_eq_iff)

lemma fst_setsum: "fst (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. fst (f x))"
by (cases "finite A", induct set: finite, simp_all)

lemma snd_setsum: "snd (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. snd (f x))"
by (cases "finite A", induct set: finite, simp_all)

lemma setsum_prod: "(\<Sum>x\<in>A. (f x, g x)) = (\<Sum>x\<in>A. f x, \<Sum>x\<in>A. g x)"
by (cases "finite A", induct set: finite) (simp_all add: zero_prod_def)

end


section \<open>Lens Algebraic Operators\<close>

theory Lens_Algebra
imports Lens_Laws
begin

subsection \<open>Lens Composition, Plus, Unit, and Identity\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Composition}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Composition}
  \label{fig:Comp}
  \end{figure}
  We introduce the algebraic lens operators; for more information please see our paper~\cite{Foster16a}.
  Lens composition, illustrated in Figure~\ref{fig:Comp}, constructs a lens by composing the source
  of one lens with the view of another.\<close>

definition lens_comp :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> ('a \<Longrightarrow> 'c)" (infixl ";\<^sub>L" 80) where
[lens_defs]: "lens_comp Y X = \<lparr> lens_get = get\<^bsub>Y\<^esub> \<circ> lens_get X
                              , lens_put = (\<lambda> \<sigma> v. lens_put X \<sigma> (lens_put Y (lens_get X \<sigma>) v)) \<rparr>"

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Sum}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Sum}
  \label{fig:Sum}
  \end{figure}
  Lens plus, as illustrated in Figure~\ref{fig:Sum} parallel composes two independent lenses,
  resulting in a lens whose view is the product of the two underlying lens views.\<close>

definition lens_plus :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Longrightarrow> 'c" (infixr "+\<^sub>L" 75) where
[lens_defs]: "X +\<^sub>L Y = \<lparr> lens_get = (\<lambda> \<sigma>. (lens_get X \<sigma>, lens_get Y \<sigma>))
                       , lens_put = (\<lambda> \<sigma> (u, v). lens_put X (lens_put Y \<sigma> v) u) \<rparr>"

text \<open>The product functor lens similarly parallel composes two lenses, but in this case the lenses
  have different sources and so the resulting source is also a product.\<close>

definition lens_prod :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'd) \<Rightarrow> ('a \<times> 'b \<Longrightarrow> 'c \<times> 'd)" (infixr "\<times>\<^sub>L" 85) where
[lens_defs]: "lens_prod X Y = \<lparr> lens_get = map_prod get\<^bsub>X\<^esub> get\<^bsub>Y\<^esub>
                              , lens_put = \<lambda> (u, v) (x, y). (put\<^bsub>X\<^esub> u x, put\<^bsub>Y\<^esub> v y) \<rparr>"

text \<open>The $\lfst$ and $\lsnd$ lenses project the first and second elements, respectively, of a
  product source type.\<close>

definition fst_lens :: "'a \<Longrightarrow> 'a \<times> 'b" ("fst\<^sub>L") where
[lens_defs]: "fst\<^sub>L = \<lparr> lens_get = fst, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (u, \<rho>)) \<rparr>"

definition snd_lens :: "'b \<Longrightarrow> 'a \<times> 'b" ("snd\<^sub>L") where
[lens_defs]: "snd\<^sub>L = \<lparr> lens_get = snd, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (\<sigma>, u)) \<rparr>"

lemma get_fst_lens [simp]: "get\<^bsub>fst\<^sub>L\<^esub> (x, y) = x"
  by (simp add: fst_lens_def)

lemma get_snd_lens [simp]: "get\<^bsub>snd\<^sub>L\<^esub> (x, y) = y"
  by (simp add: snd_lens_def)

text \<open>The swap lens is a bijective lens which swaps over the elements of the product source type.\<close>

abbreviation swap_lens :: "'a \<times> 'b \<Longrightarrow> 'b \<times> 'a" ("swap\<^sub>L") where
"swap\<^sub>L \<equiv> snd\<^sub>L +\<^sub>L fst\<^sub>L"

text \<open>The zero lens is an ineffectual lens whose view is a unit type. This means the zero lens
  cannot distinguish or change the source type.\<close>

definition zero_lens :: "unit \<Longrightarrow> 'a" ("0\<^sub>L") where
[lens_defs]: "0\<^sub>L = \<lparr> lens_get = (\<lambda> _. ()), lens_put = (\<lambda> \<sigma> x. \<sigma>) \<rparr>"

text \<open>The identity lens is a bijective lens where the source and view type are the same.\<close>

definition id_lens :: "'a \<Longrightarrow> 'a" ("1\<^sub>L") where
[lens_defs]: "1\<^sub>L = \<lparr> lens_get = id, lens_put = (\<lambda> _. id) \<rparr>"

text \<open>The quotient operator $X \lquot Y$ shortens lens $X$ by cutting off $Y$ from the end. It is
  thus the dual of the composition operator.\<close>

definition lens_quotient :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<Longrightarrow> 'b" (infixr "'/\<^sub>L" 90) where
[lens_defs]: "X /\<^sub>L Y = \<lparr> lens_get = \<lambda> \<sigma>. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>)
                       , lens_put = \<lambda> \<sigma> v. get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>) v) \<rparr>"

text \<open>Lens inverse take a bijective lens and swaps the source and view types.\<close>

definition lens_inv :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'a)" ("inv\<^sub>L") where
[lens_defs]: "lens_inv x = \<lparr> lens_get = create\<^bsub>x\<^esub>, lens_put = \<lambda> \<sigma>. get\<^bsub>x\<^esub> \<rparr>"

subsection \<open>Closure Poperties\<close>

text \<open>We show that the core lenses combinators defined above are closed under the key lens classes.\<close>

lemma id_wb_lens: "wb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma source_id_lens: "\<S>\<^bsub>1\<^sub>L\<^esub> = UNIV"
  by (simp add: id_lens_def lens_source_def)

lemma unit_wb_lens: "wb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma source_zero_lens: "\<S>\<^bsub>0\<^sub>L\<^esub> = UNIV"
  by (simp_all add: zero_lens_def lens_source_def)

lemma comp_weak_lens: "\<lbrakk> weak_lens x; weak_lens y \<rbrakk> \<Longrightarrow> weak_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma comp_wb_lens: "\<lbrakk> wb_lens x; wb_lens y \<rbrakk> \<Longrightarrow> wb_lens (x ;\<^sub>L y)"
  by (unfold_locales, auto simp add: lens_comp_def wb_lens_def weak_lens.put_closure)

lemma comp_mwb_lens: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> mwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, auto simp add: lens_comp_def mwb_lens_def weak_lens.put_closure)

lemma source_lens_comp: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> \<S>\<^bsub>x ;\<^sub>L y\<^esub> = {s \<in> \<S>\<^bsub>y\<^esub>. get\<^bsub>y\<^esub> s \<in> \<S>\<^bsub>x\<^esub>}"
  by (auto simp add: lens_comp_def lens_source_def, blast, metis mwb_lens.put_put mwb_lens_def weak_lens.put_get)

lemma id_vwb_lens [simp]: "vwb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_vwb_lens [simp]: "vwb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_vwb_lens: "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> vwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def weak_lens.put_closure)

lemma unit_ief_lens: "ief_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

text \<open>Lens plus requires that the lenses be independent to show closure.\<close>

lemma plus_mwb_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "mwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales)
   apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym)
  apply (simp add: lens_indep_comm)
done

lemma plus_wb_lens:
  assumes "wb_lens x" "wb_lens y" "x \<bowtie> y"
  shows "wb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
done

lemma plus_vwb_lens [simp]:
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "vwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
   apply (simp add: lens_indep_sym prod.case_eq_if)
  apply (simp add: lens_indep_comm prod.case_eq_if)
done

lemma source_plus_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "\<S>\<^bsub>x +\<^sub>L y\<^esub> = \<S>\<^bsub>x\<^esub> \<inter> \<S>\<^bsub>y\<^esub>"
  apply (auto simp add: lens_source_def lens_plus_def)
  apply (meson assms(3) lens_indep_comm)
  apply (metis assms(1) mwb_lens.weak_get_put mwb_lens_weak weak_lens.put_closure)
done

lemma prod_mwb_lens:
  "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_wb_lens:
  "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_vwb_lens:
  "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_bij_lens:
  "\<lbrakk> bij_lens X; bij_lens Y \<rbrakk> \<Longrightarrow> bij_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma fst_vwb_lens: "vwb_lens fst\<^sub>L"
  by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

lemma snd_vwb_lens: "vwb_lens snd\<^sub>L"
  by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if)

lemma id_bij_lens: "bij_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma inv_id_lens: "inv\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_inv_def id_lens_def lens_create_def)

lemma inv_inv_lens: "bij_lens X \<Longrightarrow> inv\<^sub>L (inv\<^sub>L X) = X"
  apply (cases X)
  apply (auto simp add: lens_defs fun_eq_iff)
  apply (metis (no_types) bij_lens.strong_get_put bij_lens_def select_convs(2) weak_lens.put_get)
  done

lemma lens_inv_bij: "bij_lens X \<Longrightarrow> bij_lens (inv\<^sub>L X)"
  by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swap\<^sub>L"
  by (unfold_locales, simp_all add: lens_plus_def prod.case_eq_if fst_lens_def snd_lens_def)

subsection \<open>Composition Laws\<close>

text \<open>Lens composition is monoidal, with unit @{term "1\<^sub>L"}, as the following theorems demonstrate.
  It also has @{term "0\<^sub>L"} as a right annihilator. \<close>

lemma lens_comp_assoc: "X ;\<^sub>L (Y ;\<^sub>L Z) = (X ;\<^sub>L Y) ;\<^sub>L Z"
  by (auto simp add: lens_comp_def)

lemma lens_comp_left_id [simp]: "1\<^sub>L ;\<^sub>L X = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_right_id [simp]: "X ;\<^sub>L 1\<^sub>L = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_anhil [simp]: "wb_lens X \<Longrightarrow> 0\<^sub>L ;\<^sub>L X = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

lemma lens_comp_anhil_right [simp]: "wb_lens X \<Longrightarrow> X ;\<^sub>L 0\<^sub>L = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

subsection \<open>Independence Laws\<close>

text \<open>The zero lens @{term "0\<^sub>L"} is independent of any lens. This is because nothing can be observed
  or changed using @{term "0\<^sub>L"}. \<close>

lemma zero_lens_indep [simp]: "0\<^sub>L \<bowtie> X"
  by (auto simp add: zero_lens_def lens_indep_def)

lemma zero_lens_indep' [simp]: "X \<bowtie> 0\<^sub>L"
  by (auto simp add: zero_lens_def lens_indep_def)

text \<open>Lens independence is irreflexive, but only for effectual lenses as otherwise nothing can
  be observed.\<close>

lemma lens_indep_quasi_irrefl: "\<lbrakk> wb_lens x; eff_lens x \<rbrakk> \<Longrightarrow> \<not> (x \<bowtie> x)"
  by (auto simp add: lens_indep_def ief_lens_def ief_lens_axioms_def, metis (full_types) wb_lens.get_put)

text \<open>Lens independence is a congruence with respect to composition, as the following properties demonstrate.\<close>

lemma lens_indep_left_comp [simp]:
  "\<lbrakk> mwb_lens z; x \<bowtie> y \<rbrakk> \<Longrightarrow> (x ;\<^sub>L z) \<bowtie> (y ;\<^sub>L z)"
  apply (rule lens_indepI)
    apply (auto simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_comp:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> (x ;\<^sub>L z)"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
    using lens_indep_comm lens_indep_sym apply fastforce
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_left_ext [intro]:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> z"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_ext [intro]:
  "x \<bowtie> z \<Longrightarrow> x \<bowtie> (y ;\<^sub>L z)"
  by (simp add: lens_indep_left_ext lens_indep_sym)

lemma lens_comp_indep_cong_left:
  "\<lbrakk> mwb_lens Z; X ;\<^sub>L Z \<bowtie> Y ;\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y"
  apply (rule lens_indepI)
    apply (rename_tac u v \<sigma>)
    apply (drule_tac u=u and v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_comm)
    apply (simp add: lens_comp_def)
    apply (meson mwb_lens_weak weak_lens.view_determination)
   apply (rename_tac v \<sigma>)
   apply (drule_tac v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
   apply (simp add: lens_comp_def)
  apply (drule lens_indep_sym)
  apply (rename_tac u \<sigma>)
  apply (drule_tac v=u and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
  apply (simp add: lens_comp_def)
done

lemma lens_comp_indep_cong:
  "mwb_lens Z \<Longrightarrow> (X ;\<^sub>L Z) \<bowtie> (Y ;\<^sub>L Z) \<longleftrightarrow> X \<bowtie> Y"
  using lens_comp_indep_cong_left lens_indep_left_comp by blast

text \<open>The first and second lenses are independent since the view different parts of a product source.\<close>

lemma fst_snd_lens_indep [simp]:
  "fst\<^sub>L \<bowtie> snd\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma snd_fst_lens_indep [simp]:
  "snd\<^sub>L \<bowtie> fst\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
  assumes "mwb_lens X"
  shows "(fst\<^sub>L ;\<^sub>L X) \<bowtie> (snd\<^sub>L ;\<^sub>L X)"
  using assms fst_snd_lens_indep lens_indep_left_comp vwb_lens_mwb by blast

text \<open>Lens independence is preserved by summation.\<close>

lemma plus_pres_lens_indep [simp]: "\<lbrakk> X \<bowtie> Z; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<bowtie> Z"
  apply (rule lens_indepI)
    apply (simp_all add: lens_plus_def prod.case_eq_if)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma plus_pres_lens_indep' [simp]:
  "\<lbrakk> X \<bowtie> Y; X \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y +\<^sub>L Z"
  by (auto intro: lens_indep_sym plus_pres_lens_indep)

text \<open>Lens independence is preserved by product.\<close>

lemma lens_indep_prod:
  "\<lbrakk> X\<^sub>1 \<bowtie> X\<^sub>2; Y\<^sub>1 \<bowtie> Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 \<times>\<^sub>L Y\<^sub>1 \<bowtie> X\<^sub>2 \<times>\<^sub>L Y\<^sub>2"
  apply (rule lens_indepI)
    apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
   apply (simp_all add: lens_indep_sym)
  done

subsection \<open> Compatibility Laws \<close>

lemma zero_lens_compat [simp]: "0\<^sub>L ##\<^sub>L X"
  by (auto simp add: zero_lens_def lens_override_def lens_compat_def)

lemma id_lens_compat [simp]: "vwb_lens X \<Longrightarrow> 1\<^sub>L ##\<^sub>L X"
  by (auto simp add: id_lens_def lens_override_def lens_compat_def)

subsection \<open>Algebraic Laws\<close>

text \<open>Lens plus distributes to the right through composition.\<close>

lemma plus_lens_distr: "mwb_lens Z \<Longrightarrow> (X +\<^sub>L Y) ;\<^sub>L Z = (X ;\<^sub>L Z) +\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def lens_plus_def comp_def)

text \<open>The first lens projects the first part of a summation.\<close>

lemma fst_lens_plus:
  "wb_lens y \<Longrightarrow> fst\<^sub>L ;\<^sub>L (x +\<^sub>L y) = x"
  by (simp add: fst_lens_def lens_plus_def lens_comp_def comp_def)

text \<open>The second law requires independence as we have to apply x first, before y\<close>

lemma snd_lens_plus:
  "\<lbrakk> wb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> snd\<^sub>L ;\<^sub>L (x +\<^sub>L y) = y"
  apply (simp add: snd_lens_def lens_plus_def lens_comp_def comp_def)
  apply (subst lens_indep_comm)
   apply (simp_all)
done

text \<open>The swap lens switches over a summation.\<close>

lemma lens_plus_swap:
  "X \<bowtie> Y \<Longrightarrow> swap\<^sub>L ;\<^sub>L (X +\<^sub>L Y) = (Y +\<^sub>L X)"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def lens_comp_def lens_indep_comm)

text \<open>The first, second, and swap lenses are all closely related.\<close>

lemma fst_snd_id_lens: "fst\<^sub>L +\<^sub>L snd\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

lemma swap_lens_idem: "swap\<^sub>L ;\<^sub>L swap\<^sub>L = 1\<^sub>L"
  by (simp add: fst_snd_id_lens lens_indep_sym lens_plus_swap)

lemma swap_lens_fst: "fst\<^sub>L ;\<^sub>L swap\<^sub>L = snd\<^sub>L"
  by (simp add: fst_lens_plus fst_vwb_lens)

lemma swap_lens_snd: "snd\<^sub>L ;\<^sub>L swap\<^sub>L = fst\<^sub>L"
  by (simp add: lens_indep_sym snd_lens_plus snd_vwb_lens)

text \<open>The product lens can be rewritten as a sum lens.\<close>

lemma prod_as_plus: "X \<times>\<^sub>L Y = X ;\<^sub>L fst\<^sub>L +\<^sub>L Y ;\<^sub>L snd\<^sub>L"
  by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

lemma prod_lens_id_equiv:
  "1\<^sub>L \<times>\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_prod_def id_lens_def)

lemma prod_lens_comp_plus:
  "X\<^sub>2 \<bowtie> Y\<^sub>2 \<Longrightarrow> ((X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) ;\<^sub>L (X\<^sub>2 +\<^sub>L Y\<^sub>2)) = (X\<^sub>1 ;\<^sub>L X\<^sub>2) +\<^sub>L (Y\<^sub>1 ;\<^sub>L Y\<^sub>2)"
  by (auto simp add: lens_comp_def lens_plus_def lens_prod_def prod.case_eq_if fun_eq_iff)

text \<open>The following laws about quotient are similar to their arithmetic analogues. Lens quotient
  reverse the effect of a composition.\<close>

lemma lens_comp_quotient:
  "weak_lens Y \<Longrightarrow> (X ;\<^sub>L Y) /\<^sub>L Y = X"
  by (simp add: lens_quotient_def lens_comp_def)

lemma lens_quotient_id: "weak_lens X \<Longrightarrow> (X /\<^sub>L X) = 1\<^sub>L"
  by (force simp add: lens_quotient_def id_lens_def)

lemma lens_quotient_id_denom: "X /\<^sub>L 1\<^sub>L = X"
  by (simp add: lens_quotient_def id_lens_def lens_create_def)

lemma lens_quotient_unit: "weak_lens X \<Longrightarrow> (0\<^sub>L /\<^sub>L X) = 0\<^sub>L"
  by (simp add: lens_quotient_def zero_lens_def)

lemma lens_obs_eq_zero: "s\<^sub>1 \<simeq>\<^bsub>0\<^sub>L\<^esub> s\<^sub>2 = (s\<^sub>1 = s\<^sub>2)"
  by (simp add: lens_defs)

lemma lens_obs_eq_one: "s\<^sub>1 \<simeq>\<^bsub>1\<^sub>L\<^esub> s\<^sub>2"
  by (simp add: lens_defs)

lemma lens_obs_eq_as_override: "vwb_lens X \<Longrightarrow> s\<^sub>1 \<simeq>\<^bsub>X\<^esub> s\<^sub>2 \<longleftrightarrow> (s\<^sub>2 = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X)"
  by (auto simp add: lens_defs; metis vwb_lens.put_eq)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_SSortPermutes
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

(*fun did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (ssort xs) xs"
  oops

end