section \<open>Integer Arithmetic\<close>
theory Arith
imports
  "../Lib/Chloe_Base"
  Int_Value
  "../Lib/Native_Word/Word_Misc" (* For signed div and signed mod *)
begin

abbreviation assert_repr:: "int \<hookrightarrow> unit" where
  "assert_repr i \<equiv>  assert (representable_int i) (EDynamic EOverflow)"

definition mk_repr :: "int \<hookrightarrow> int_val" where
  "mk_repr i \<equiv> do {
    assert_repr i;
    return (word_of_int i)
  }"

(*definition mk_int_val :: "int \<hookrightarrow> val" where
  "mk_int_val i = do {
    assert_repr i;
    return (val.I (word_of_int i))
  }"*)

text \<open>Integer division with truncation towards zero,
  conforming to the C99 standard, Sec. 6.5.5/6\<close>
definition div_towards_zero :: "int \<Rightarrow> int \<Rightarrow> int" where
  "div_towards_zero a b \<equiv> (\<bar>a\<bar> div \<bar>b\<bar>) * sgn a * sgn b"

text \<open>Integer modulo with truncation towards zero,
  conforming to the C99 standard, Sec. 6.5.5/6\<close>
definition mod_towards_zero :: "int \<Rightarrow> int \<Rightarrow> int" where
  "mod_towards_zero a b \<equiv> a - (div_towards_zero a b) * b "

text \<open>The C99 standard, Sec. 6.5.5/6 states that "If the quotient a/b is representable,
  the expression (a/b)*b + a%b shall equal a"\<close>
lemma div_mod_conform_to_c99_aux1:
  "div_towards_zero a b * b + mod_towards_zero a b = a"
  unfolding mod_towards_zero_def by auto

lemma div_mod_conform_to_c99_aux2:
  "\<lbrakk>representable_int a; representable_int b;
      representable_int (div_towards_zero a b)\<rbrakk> \<Longrightarrow>
    representable_int (div_towards_zero a b * b)
  \<and> representable_int (mod_towards_zero a b)
  \<and> representable_int (div_towards_zero a b * b + mod_towards_zero a b)"
  apply (simp add: div_mod_conform_to_c99_aux1)
  apply (auto simp: mod_towards_zero_def)
  apply (auto simp: representable_int_def div_towards_zero_def
    sgn_if)
  apply (smt Divides.transfer_nat_int_function_closures(1) mult_nonneg_nonneg)
  apply (smt mod_div_equality nonneg_mod_div)
  apply (smt Divides.transfer_nat_int_function_closures(1) mult_nonneg_nonpos)
  apply (smt mod_div_equality mult_minus_right nonneg_mod_div)
  apply (smt mod_div_equality nonneg_mod_div)
  apply (smt Divides.transfer_nat_int_function_closures(1) mult_nonneg_nonneg)
  apply (smt mod_div_equality neg_mod_sign)
  apply (smt mult_nonneg_nonpos neg_imp_zdiv_neg_iff)
  apply (smt mod_div_equality nonneg_mod_div)
  apply (smt Divides.pos_mod_bound dual_order.order_iff_strict zmod_zdiv_equality')
  apply (smt mod_div_equality mult_minus_right nonneg_mod_div)
  apply (smt Divides.transfer_nat_int_function_closures(1) mult_nonneg_nonpos)
  apply (smt Divides.transfer_nat_int_function_closures(1) mult_nonneg_nonneg)
  apply (smt mod_div_equality nonneg_mod_div)
  apply (smt mult_nonneg_nonpos neg_imp_zdiv_neg_iff)
  apply (smt mod_div_equality neg_mod_sign)
  done

subsection \<open>Arithmetic Operations on Integers, with overflow checks\<close>

definition iop_const :: "int \<hookrightarrow> int_val" where "iop_const i \<equiv> mk_repr i"

definition iop_plus :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_plus x1 x2 \<equiv> mk_repr (sint x1 + sint x2)"

definition iop_minus :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_minus x1 x2 \<equiv> mk_repr (sint x1 - sint x2)"

definition iop_uminus :: "int_val \<hookrightarrow> int_val" where
  "iop_uminus x \<equiv> mk_repr (- sint x)"

definition iop_mult :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_mult x1 x2 \<equiv> mk_repr (sint x1 * sint x2)"

definition iop_div :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_div x1 x2 \<equiv> do {
    assert (x2\<noteq>0) (EDynamic EDivZero);
    mk_repr (div_towards_zero (sint x1) (sint x2))
  }"

definition iop_mod :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_mod x1 x2 \<equiv> do {
    assert (x2\<noteq>0) (EDynamic EDivZero);
    mk_repr (mod_towards_zero (sint x1) (sint x2))
  }"

definition b2i :: "bool \<Rightarrow> int_val" where "b2i b \<equiv> if b then 1 else 0"
definition i2b :: "int_val \<Rightarrow> bool" where "i2b i \<equiv> i\<noteq>0"

definition iop_less :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_less x1 x2 \<equiv> return (b2i (x1 <s x2))"

definition iop_le :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_le x1 x2 \<equiv> return (b2i (x1 <=s x2))"

definition iop_eq :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_eq x1 x2 \<equiv> return (b2i (x1 = x2))"

definition iop_Not :: "int_val \<hookrightarrow> int_val" where
  "iop_Not x \<equiv> return (b2i (\<not>i2b x))"

definition iop_And :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_And x1 x2 \<equiv> return (b2i (i2b x1 \<and> i2b x2))"

definition iop_Or :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_Or x1 x2 \<equiv> return (b2i (i2b x1 \<or> i2b x2))"

definition iop_BNot :: "int_val \<hookrightarrow> int_val" where
  "iop_BNot x \<equiv> return (NOT x)"

definition iop_BAnd :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_BAnd x1 x2 \<equiv> return (x1 AND x2)"

definition iop_BOr :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_BOr x1 x2 \<equiv> return (x1 OR x2)"

definition iop_BXor :: "int_val \<Rightarrow> int_val \<hookrightarrow> int_val" where
  "iop_BXor x1 x2 \<equiv> return (x1 XOR x2)"

lemma div_mon_conforming:
  assumes "iop_div a b = return c"
  shows "do {
    v \<leftarrow> iop_mult c b;
    m \<leftarrow> iop_mod a b;
    iop_plus v m
  } = return a"
proof -
  from assms have
    [simp]: "b\<noteq>0"
    and [simp]: "c = word_of_int (div_towards_zero (sint a) (sint b))"
    and [simp]: "representable_int (div_towards_zero (sint a) (sint b))"
    unfolding iop_div_def mk_repr_def
    by (auto simp: pw_eq_iff)

  have "sint c = div_towards_zero (sint a) (sint b)"
    by (simp add: Int_Value.repr1)

  from div_mod_conform_to_c99_aux2[of "sint a" "sint b", simplified] Int_Value.repr2 have
    "representable_int (div_towards_zero (sint a) (sint b) * sint b)"
    "representable_int (mod_towards_zero (sint a) (sint b))"
    "representable_int (div_towards_zero (sint a) (sint b) * sint b +
          mod_towards_zero (sint a) (sint b))"
    by auto
  thus ?thesis
  by (auto simp: Int_Value.repr1 div_mod_conform_to_c99_aux1
    simp: pw_eq_iff iop_div_def iop_mult_def iop_mod_def iop_plus_def mk_repr_def)
qed

end


theory prop_57
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster take minus drop *)
lemma lemma_a [thy_expl]: "minus x2 x2 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_aa [thy_expl]: "minus x3 Z = x3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ab [thy_expl]: "minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_ac [thy_expl]: "minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_ad [thy_expl]: "minus (minus x3 y3) (minus y3 x3) = minus x3 y3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ae [thy_expl]: "minus (minus x3 y3) (S Z) = minus x3 (S y3)"
by (hipster_induct_schemes minus.simps)

lemma lemma_af [thy_expl]: "minus (minus x4 y4) x4 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_ag [thy_expl]: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_ah [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

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

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

(*hipster take*)
lemma lemma_ai [thy_expl]: "take x3 Nil2 = Nil2"
by (hipster_induct_schemes take.simps)

lemma lemma_aj [thy_expl]: "take x3 (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma lemma_ak [thy_expl]: "take (S x3) (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma unknown [thy_expl]: "take x (take y z) = take y (take x z)"
oops
setup\<open>Hip_Tac_Ops.set_metis_to @{context} 600\<close>
  theorem x0 :
    "(drop n (take m xs)) = (take (minus m n) (drop n xs))"
    by (hipster_induct_schemes take.simps drop.simps minus.simps Nat.exhaust)

end


theory TeslDenotationalRelations

imports TeslDenotationalOperators

begin

text \<open>
  Definition of the relations between clocks in TESL.
\<close>

text \<open>
  Sporadic forces a clock to have a tick with a given time stamp (or tag).
\<close>
definition Sporadic :: \<open>('\<AA>,'b)\<H> \<Rightarrow> 'b \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                       (infixl "sporadic" 55)
where \<open>(H sporadic \<tau>) = {r. \<exists> n. (timeof H in r at n) = \<tau> \<and> ticks H (hamlet r n)}\<close>

text \<open>
  When a clock A implies a clock B, B must tick at each instant where A ticks.
\<close>
definition Implies :: \<open>('\<AA>,'b)\<H> \<Rightarrow> ('\<AA>,'c)\<H> \<Rightarrow> ('\<AA>::orderedrank) runs\<close> (infixl "implies" 55)
where \<open>(H\<^sub>1 implies H\<^sub>2) = {r. \<forall>n. ticks H\<^sub>1 (hamlet r n) \<longrightarrow> ticks H\<^sub>2 (hamlet r n)}\<close>

text \<open>
  ImpliesEvery is similar to Implies, but only every k ticks.
\<close>
definition ImpliesEvery :: \<open>('\<AA>,'b)\<H> \<Rightarrow> ('\<AA>,'c)\<H> \<Rightarrow> nat \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                           ( "_ implies _ every _" [70,70,70] 55)
where \<open>H\<^sub>1 implies H\<^sub>2 every k = {r. \<forall>n. ticks H\<^sub>1 (hamlet r n)
                                    \<and> (tick_count H\<^sub>1 (hamlet r) n) mod k = 0
                                          \<longrightarrow> ticks H\<^sub>2 (hamlet r n)
                               }\<close>

text\<open> Tag Relations define the structure of the temporal mesh (fabric, texture) \<close>

definition TagRelation :: \<open>('\<AA>,'a)\<H>
                        \<Rightarrow> ('a \<times> 'b) set
                        \<Rightarrow> ('\<AA>,'b)\<H>
                        \<Rightarrow> ('\<AA>::orderedrank) runs \<close>
where \<open>TagRelation  H\<^sub>1 R H\<^sub>2 = {r. \<forall>n. (timeof H\<^sub>1 in r at n, timeof H\<^sub>2 in r at n) \<in> R}\<close>

text \<open>
  Loose tag relations hold only when events occur.
\<close>
definition LooseTagRelation :: \<open>('\<AA>,'a)\<H>
                             \<Rightarrow> ('a \<times> 'b) set
                             \<Rightarrow> ('\<AA>,'b)\<H>
                             \<Rightarrow> ('\<AA>::orderedrank) runs \<close>
where \<open>LooseTagRelation H\<^sub>1 R H\<^sub>2 = {r. (\<forall>n. tick_occurs (hamlet r n)
                                      \<longrightarrow> (timeof H\<^sub>1 in r at n, timeof H\<^sub>2 in r at n) \<in> R)
                                  }\<close>
text \<open>
  A tag relation is a stricter specification than the equivalent loose tag relation.
\<close>
lemma tagrel_is_loose:
  shows   \<open>TagRelation H\<^sub>1 R H\<^sub>2 \<subseteq> LooseTagRelation H\<^sub>1 R H\<^sub>2\<close>
unfolding TagRelation_def LooseTagRelation_def by blast

text \<open>
  Affine tag relations are a special case of tag relations defined by an affine function.
  The case of integers is complicated by the fact that multiplication and division
  are not reciprocal.
\<close>
fun AffineTagRelation\<^sub>i\<^sub>n\<^sub>t :: \<open>('\<AA>,int)\<H>
                         \<Rightarrow> (int \<times> int)
                         \<Rightarrow> ('\<AA>,int)\<H>
                         \<Rightarrow> ('\<AA>::orderedrank) runs\<close> ("tag relation _ = _  _" [70,70,70] 55)
where \<open>AffineTagRelation\<^sub>i\<^sub>n\<^sub>t  H\<^sub>1 (a,b) H\<^sub>2
        = TagRelation H\<^sub>1 {(m::int,n::int). (m = a * n + b) \<or> (n = (m-b) div a)} H\<^sub>2\<close>

text\<open> The following definition works because in fields, the inverses exist
       and the more complicated case for integers is therefore not necessary, \<close>
definition AffineTagRelation\<^sub>r\<^sub>i\<^sub>n\<^sub>g :: \<open>('\<AA>,'b)\<H>
                                 \<Rightarrow> ('b::field)
                                 \<Rightarrow> ('\<AA>,'b)\<H>
                                 \<Rightarrow> 'b \<Rightarrow> ('\<AA>::orderedrank) runs \<close>
                                  ("tag relation _ = _ * _ + _" [70,70,70,70] 55)
where \<open>AffineTagRelation\<^sub>r\<^sub>i\<^sub>n\<^sub>g H\<^sub>1 a H\<^sub>2 b = TagRelation H\<^sub>1 {(y,x). y = a * x + b} H\<^sub>2\<close>

text \<open>
  The time delayed implication forces a tick to occur on a clock a fixed delay (measured in
  time on another reference clock) after each tick of the master clock.
\<close>
definition TimeDelayed :: \<open>('\<AA>,'b::{semiring,order})\<H>
                        \<Rightarrow> 'c::{semiring,order}
                        \<Rightarrow> ('\<AA>,'c)\<H>
                        \<Rightarrow> ('\<AA>,'d)\<H>
                        \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                        ("'( _ time-delayed by _ on _ implies _')" 56)
where \<open>(master time-delayed by dt on ref implies slave) \<equiv>
        {r. \<forall>n. ticks master (hamlet r n) \<longrightarrow>
                  (\<exists>m > n. ticks slave (hamlet r m)
                        \<and> ((timeof ref in r at m) = (timeof ref in r at n) + dt))
        }\<close>

text \<open>
  The delayed implication forces a tick to occur on a clock after a fixed number of
  ticks has occurred on another clock each time a tick occurs on the master clock.
\<close>
definition Delayed :: \<open>('\<AA>,'b)\<H>
                     \<Rightarrow> nat
                     \<Rightarrow> ('\<AA>,'c)\<H>
                     \<Rightarrow> ('\<AA>,'d)\<H>
                     \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                     ("'( _ delayed by _ on _ implies _')" 56)
where \<open>(m delayed by d on counter implies slave) \<equiv>
         {r. \<forall>n. ticks m (hamlet r n)
                  \<longrightarrow> (\<exists>n\<^sub>f\<^sub>i\<^sub>r\<^sub>e > n. ticks slave (hamlet r n\<^sub>f\<^sub>i\<^sub>r\<^sub>e)
                    \<and> tick_count_between counter (hamlet r) n n\<^sub>f\<^sub>i\<^sub>r\<^sub>e = d)
          }\<close>

text \<open>
  The filtered implication is similar to the regular implication, but is active only
  through a pattern fixed by a regular expression.
  This pattern is defined as s, k (rs, rk)*, which means that s ticks of the master clock
  are skipped, then k ticks are kept, and then, repeatedly, rs ticks are skipped and rk
  ticks are kept. The implication is active only for the kept ticks.
\<close>
definition Filtered :: \<open>('\<AA>,'b)\<H>
                      \<Rightarrow> nat
                      \<Rightarrow> nat
                      \<Rightarrow> nat
                      \<Rightarrow> nat
                      \<Rightarrow> ('\<AA>,'c)\<H>
                      \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                      ("'( _ filtered by _, _ '(_, _')* implies _')" 56)
where \<open>(m filtered by s, k (rs, rk)* implies slave) \<equiv>
           {r. \<forall>n. ticks m (hamlet r n) \<and> filter s k rs rk (tick_count m (hamlet r) n)
                    \<longrightarrow> ticks slave (hamlet r n)
            }\<close>

text \<open>
  The \<^emph>\<open>await\<close> implication.
  await a, b implies c makes c tick each time a and b have both ticked.
\<close>
definition Await :: \<open>('\<AA>,'a)\<H>
                  \<Rightarrow> ('\<AA>,'b)\<H>
                  \<Rightarrow> ('\<AA>,'c)\<H>
                  \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                  ("await _ , _ implies _" 56)
where \<open>await a, b implies slave \<equiv>
        {r. \<forall>n. have_both_ticked a b (hamlet r) n \<longrightarrow> ticks slave (hamlet r n)}\<close>

text \<open>
  This implication is activated when a \<^emph>\<open>begin\<close> clock ticks, and deactivated
  when an \<^emph>\<open>end\<close> clock ticks. It is therefore only active between an occurrence
  of the begin clock and an occurrence of the end clock.
\<close>
definition SustainFromTo ::\<open>('\<AA>,'a)\<H>
                         \<Rightarrow> ('\<AA>,'b)\<H>
                         \<Rightarrow> ('\<AA>,'c)\<H>
                         \<Rightarrow> ('\<AA>,'d)\<H>
                         \<Rightarrow> ('\<AA>::orderedrank) runs\<close>
                        ("_ sustained from _ to _ implies _" 55)
where
  \<open>m sustained from beg to end implies slave \<equiv> {
    r. \<forall>n. between beg end (hamlet r) n \<and> ticks m (hamlet r n)
            \<longrightarrow> ticks slave (hamlet r n)
   }\<close>

end


theory exercise_2_3
  imports Main
begin
(*count the number of different elements*)
fun count::"'a\<Rightarrow>'a list\<Rightarrow>nat"
  where
"count x []=0"|
"count x (y # xs) =If(x=y)(Suc(count x xs))(count x xs)"(*if x==y,then the count++,else count unchange*)
value "count(1::nat) [1,1,2,3,1,3,1]"
lemma count_e :"count x xs \<le> length xs"
apply(induction xs)
apply(auto)
done
end


(*<*)
(*
   Title:  Theory arith_hints.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
header {* Auxiliary arithmetic lemmas *}

theory arith_hints
imports Main
begin

lemma arith_mod_neq:
  assumes "a mod n \<noteq> b mod n"
  shows "a \<noteq> b"
using assms by auto

lemma arith_mod_nzero:
  fixes i::nat
  assumes "i < n"
         and "0 < i"
  shows "0 < (n * t + i) mod n"
using assms
by (metis Divides.mod_less mod_mult_self2 add.commute)

lemma arith_mult_neq_nzero2:
  fixes i::nat
  assumes "i < n"
         and "0 < i"
  shows "n * t + i \<noteq> n * q"
using assms
by (metis arith_mult_neq_nzero1 add.commute)

lemma arith_mult_neq_nzero3:
  fixes i::nat
  assumes "i < n"
         and "0 < i"
  shows "n + n * t + i \<noteq> n * qc"
proof -
   from assms have sg1: "n *(Suc t) + i  \<noteq> n * qc"
     by (rule arith_mult_neq_nzero2)
   have sg2: "n + n * t + i = n *(Suc t) + i" by simp
   from sg1 and sg2  show ?thesis  by arith
qed

lemma arith_modZero1:
  "(t + n * t) mod Suc n = 0"
using assms
by (metis mod_mult_self1_is_0 mult_Suc)

lemma arith_modZero2:
  "Suc (n + (t + n * t)) mod Suc n = 0"
by (metis add_Suc_right add_Suc_shift mod_mult_self1_is_0 mult_Suc mult.commute)

lemma arith1:
  assumes h1:"Suc n * t = Suc n * q"
  shows "t = q"
using assms
by (metis mult_cancel2 mult.commute neq0_conv zero_less_Suc)

lemma arith2:
  fixes t n q :: "nat"
  assumes h1:"t + n * t = q + n * q"
  shows "t = q"
using assms
by (metis arith1 mult_Suc)

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_nat_HSort2Sorts
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort2 xs)"
  oops

end


theory Chapter11_2_Typechecking
imports Chapter11_1_Language
begin

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_zero [simp]: "typecheck gam Zero Nat"
    | tc_suc [simp]: "typecheck gam e Nat ==> typecheck gam (Suc e) Nat"
    | tc_rec [simp]: "typecheck gam et Nat ==> typecheck gam e0 t ==>
                typecheck (extend (extend gam t) Nat) es t ==> typecheck gam (Rec et e0 es) t"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                typecheck gam (Appl e1 e2) t"
    | tc_triv [simp]: "typecheck gam Triv Unit"
    | tc_pair [simp]: "typecheck gam e1 t1 ==> typecheck gam e2 t2 ==>
                typecheck gam (Pair e1 e2) (Prod t1 t2)"
    | tc_projl [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjL e) t1"
    | tc_projr [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjR e) t2"
    | tc_abort [simp]: "typecheck gam e Void ==> typecheck gam (Abort t e) t"
    | tc_case [simp]: "typecheck gam et (Sum t1 t2) ==> typecheck (extend gam t1) el t ==>
                typecheck (extend gam t2) er t ==> typecheck gam (Case et el er) t"
    | tc_inl [simp]: "typecheck gam e t1 ==> typecheck gam (InL t1 t2 e) (Sum t1 t2)"
    | tc_inr [simp]: "typecheck gam e t2 ==> typecheck gam (InR t1 t2 e) (Sum t1 t2)"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam Zero t"
inductive_cases [elim!]: "typecheck gam (Suc e) t"
inductive_cases [elim!]: "typecheck gam (Rec et e0 es) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"
inductive_cases [elim!]: "typecheck gam Triv t"
inductive_cases [elim!]: "typecheck gam (Pair e1 e2) t"
inductive_cases [elim!]: "typecheck gam (ProjL e) t"
inductive_cases [elim!]: "typecheck gam (ProjR e) t"
inductive_cases [elim!]: "typecheck gam (Abort t1 e) t"
inductive_cases [elim!]: "typecheck gam (Case et el er) t"
inductive_cases [elim!]: "typecheck gam (InL t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (InR t1 t2 e) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                  typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct, fastforce+)

end


theory "HOLCF-Join"
imports HOLCF
begin

subsubsection \<open>Binary Joins and compatibility\<close>

context cpo
begin
definition join :: "'a => 'a => 'a" (infixl "\<squnion>" 80) where
  "x \<squnion> y = (if \<exists> z. {x, y} <<| z then lub {x, y} else x)"

definition compatible :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "compatible x y = (\<exists> z. {x, y} <<| z)"

lemma compatibleI:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "compatible x y"
proof-
  from assms
  have "{x,y} <<| z"
    by (auto intro: is_lubI)
  thus ?thesis unfolding compatible_def by (metis)
qed

lemma is_joinI:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "x \<squnion> y = z"
proof-
  from assms
  have "{x,y} <<| z"
    by (auto intro: is_lubI)
  thus ?thesis unfolding join_def by (metis lub_eqI)
qed

lemma is_join_and_compatible:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "compatible x y \<and> x \<squnion> y = z"
by (metis compatibleI is_joinI assms)

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  unfolding compatible_def by (metis insert_commute)

lemma compatible_sym_iff: "compatible x y \<longleftrightarrow> compatible y x"
  unfolding compatible_def by (metis insert_commute)

lemma join_above1: "compatible x y \<Longrightarrow> x \<sqsubseteq> x \<squnion> y"
  unfolding compatible_def join_def
  apply auto
  by (metis is_lubD1 is_ub_insert lub_eqI)

lemma join_above2: "compatible x y \<Longrightarrow> y \<sqsubseteq> x \<squnion> y"
  unfolding compatible_def join_def
  apply auto
  by (metis is_lubD1 is_ub_insert lub_eqI)

lemma larger_is_join1: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  unfolding join_def
  by (metis doubleton_eq_iff lub_bin)

lemma larger_is_join2: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
  unfolding join_def
  by (metis is_lub_bin lub_bin)

lemma join_commute:  "compatible x y \<Longrightarrow> x \<squnion> y = y \<squnion> x"
  unfolding compatible_def unfolding join_def by (metis insert_commute)

lemma lub_is_join:
  "{x, y} <<| z \<Longrightarrow> x \<squnion> y = z"
unfolding join_def by (metis lub_eqI)

lemma compatible_refl[simp]: "compatible x x"
  by (rule compatibleI[OF below_refl below_refl])

lemma join_mono:
  assumes "compatible a b"
  and "compatible c d"
  and "a \<sqsubseteq> c"
  and "b \<sqsubseteq> d"
  shows "a \<squnion> b \<sqsubseteq> c \<squnion> d"
proof-
  from assms obtain x y where "{a, b} <<| x" "{c, d} <<| y" unfolding compatible_def by auto
  with assms have "a \<sqsubseteq> y" "b \<sqsubseteq> y" by (metis below.r_trans is_lubD1 is_ub_insert)+
  with \<open>{a, b} <<| x\<close> have "x \<sqsubseteq> y" by (metis is_lub_below_iff is_lub_singleton is_ub_insert)
  moreover
  from \<open>{a, b} <<| x\<close> \<open>{c, d} <<| y\<close> have "a \<squnion> b = x" "c \<squnion> d = y" by (metis lub_is_join)+
  ultimately
  show ?thesis by simp
qed

lemma
  assumes "compatible x y"
  shows join_above1: "x \<sqsubseteq> x \<squnion> y" and join_above2: "y \<sqsubseteq> x \<squnion> y"
proof-
  from assms obtain z where "{x,y} <<| z" unfolding compatible_def by auto
  hence  "x \<squnion> y = z" and "x \<sqsubseteq> z" and "y \<sqsubseteq> z" apply (auto intro: lub_is_join) by (metis is_lubD1 is_ub_insert)+
  thus "x \<sqsubseteq> x \<squnion> y" and "y \<sqsubseteq> x \<squnion> y" by simp_all
qed

lemma
  assumes "compatible x y"
  shows compatible_above1: "compatible x (x \<squnion> y)" and compatible_above2: "compatible y (x \<squnion> y)"
proof-
  from assms obtain z where "{x,y} <<| z" unfolding compatible_def by auto
  hence  "x \<squnion> y = z" and "x \<sqsubseteq> z" and "y \<sqsubseteq> z" apply (auto intro: lub_is_join) by (metis is_lubD1 is_ub_insert)+
  thus  "compatible x (x \<squnion> y)" and  "compatible y (x \<squnion> y)" by (metis below.r_refl compatibleI)+
qed

lemma join_below:
  assumes "compatible x y"
  and "x \<sqsubseteq> a" and "y \<sqsubseteq> a"
  shows "x \<squnion> y \<sqsubseteq> a"
proof-
  from assms obtain z where z: "{x,y} <<| z" unfolding compatible_def by auto
  with assms have "z \<sqsubseteq> a" by (metis is_lub_below_iff is_ub_empty is_ub_insert)
  moreover
  from z have "x \<squnion> y = z" by (rule lub_is_join)
  ultimately show ?thesis by simp
qed

lemma join_below_iff:
  assumes "compatible x y"
  shows "x \<squnion> y \<sqsubseteq> a \<longleftrightarrow> (x \<sqsubseteq> a \<and> y \<sqsubseteq> a)"
  by (metis assms below_trans cpo_class.join_above1 cpo_class.join_above2 join_below)

lemma join_assoc:
  assumes "compatible x y"
  assumes "compatible x (y \<squnion> z)"
  assumes "compatible y z"
  shows "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  apply (rule is_joinI)
  apply (rule join_mono[OF assms(1) assms(2) below_refl join_above1[OF assms(3)]])
  apply (rule below_trans[OF join_above2[OF assms(3)] join_above2[OF assms(2)]])
  apply (rule join_below[OF assms(2)])
  apply (erule rev_below_trans)
  apply (rule join_above1[OF assms(1)])
  apply (rule join_below[OF assms(3)])
  apply (erule rev_below_trans)
  apply (rule join_above2[OF assms(1)])
  apply assumption
  done

lemma join_idem[simp]: "compatible x y \<Longrightarrow> x \<squnion> (x \<squnion> y) = x \<squnion> y"
  apply (subst join_assoc[symmetric])
  apply (rule compatible_refl)
  apply (erule compatible_above1)
  apply assumption
  apply (subst join_self)
  apply rule
  done

lemma join_bottom[simp]: "x \<squnion> \<bottom> = x" "\<bottom> \<squnion> x = x"
  by (auto intro: is_joinI)

lemma compatible_adm2:
  shows "adm (\<lambda> y. compatible x y)"
proof(rule admI)
  fix Y
  assume c: "chain Y" and "\<forall>i.  compatible x (Y i)"
  hence a: "\<And> i. compatible x (Y i)" by auto
  show "compatible x (\<Squnion> i. Y i)"
  proof(rule compatibleI)
    have c2: "chain (\<lambda>i. x \<squnion> Y i)"
      apply (rule chainI)
      apply (rule join_mono[OF a a below_refl chainE[OF \<open>chain Y\<close>]])
      done
    show "x \<sqsubseteq> (\<Squnion> i. x \<squnion> Y i)"
      by (auto intro: admD[OF _ c2] join_above1[OF a])
    show "(\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. x \<squnion> Y i)"
      by (auto intro: admD[OF _ c] below_lub[OF c2 join_above2[OF a]])
    fix a
    assume "x \<sqsubseteq> a" and "(\<Squnion> i. Y i) \<sqsubseteq> a"
    show "(\<Squnion> i. x \<squnion> Y i) \<sqsubseteq> a"
      apply (rule lub_below[OF c2])
      apply (rule join_below[OF a \<open>x \<sqsubseteq> a\<close>])
      apply (rule below_trans[OF is_ub_thelub[OF c] \<open>(\<Squnion> i. Y i) \<sqsubseteq> a\<close>])
      done
  qed
qed

lemma compatible_adm1: "adm (\<lambda> x. compatible x y)"
  by (subst compatible_sym_iff, rule compatible_adm2)

lemma join_cont1:
  assumes "chain Y"
  assumes compat: "\<And> i. compatible (Y i) y"
  shows "(\<Squnion>i. Y i) \<squnion> y = (\<Squnion> i. Y i \<squnion> y)"
proof-
  have c: "chain (\<lambda>i. Y i \<squnion> y)"
    apply (rule chainI)
    apply (rule join_mono[OF compat compat chainE[OF \<open>chain Y\<close>] below_refl])
    done

  show ?thesis
    apply (rule is_joinI)
    apply (rule lub_mono[OF \<open>chain Y\<close> c join_above1[OF compat]])
    apply (rule below_lub[OF c join_above2[OF compat]])
    apply (rule lub_below[OF c])
    apply (rule join_below[OF compat])
    apply (metis lub_below_iff[OF \<open>chain Y\<close>])
    apply assumption
    done
qed

lemma join_cont2:
  assumes "chain Y"
  assumes compat: "\<And> i. compatible x (Y i)"
  shows "x \<squnion> (\<Squnion>i. Y i) = (\<Squnion> i. x \<squnion> Y i)"
proof-
  have c: "chain (\<lambda>i. x \<squnion> Y i)"
    apply (rule chainI)
    apply (rule join_mono[OF compat compat below_refl chainE[OF \<open>chain Y\<close>]])
    done

  show ?thesis
    apply (rule is_joinI)
    apply (rule below_lub[OF c join_above1[OF compat]])
    apply (rule lub_mono[OF \<open>chain Y\<close> c join_above2[OF compat]])
    apply (rule lub_below[OF c])
    apply (rule join_below[OF compat])
    apply assumption
    apply (metis lub_below_iff[OF \<open>chain Y\<close>])
    done
qed

lemma join_cont12:
  assumes "chain Y" and "chain Z"
  assumes compat: "\<And> i j. compatible (Y i) (Z j)"
  shows "(\<Squnion>i. Y i) \<squnion> (\<Squnion>i. Z i) = (\<Squnion> i. Y i  \<squnion> Z i)"
proof-
  have "(\<Squnion>i. Y i) \<squnion> (\<Squnion>i. Z i) = (\<Squnion>i. Y i \<squnion> (\<Squnion>j. Z j))"
    by (rule join_cont1[OF \<open>chain Y\<close> admD[OF compatible_adm2 \<open>chain Z\<close> compat]])
  also have "... = (\<Squnion>i j. Y i \<squnion> Z j)"
    by (subst join_cont2[OF \<open>chain Z\<close> compat], rule)
  also have "... = (\<Squnion>i. Y i \<squnion> Z i)"
    apply (rule diag_lub)
    apply (rule chainI, rule join_mono[OF compat compat chainE[OF \<open>chain Y\<close>] below_refl])
    apply (rule chainI, rule join_mono[OF compat compat below_refl chainE[OF \<open>chain Z\<close>]])
    done
  finally show ?thesis.
qed

context pcpo
begin
  lemma bot_compatible[simp]:
    "compatible x \<bottom>" "compatible \<bottom> x"
    unfolding compatible_def by (metis insert_commute is_lub_bin minimal)+
end

end


(*  Title:      The Second Isomorphism Theorem for Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SndIsomorphismGrp
imports Coset
begin

section \<open>The Second Isomorphism Theorem for Groups\<close>

text \<open>This theory provides a proof of the second isomorphism theorems for groups.
The theorems consist of several facts about normal subgroups.\<close>

text \<open>The first lemma states that whenever we have a subgroup @{term S} and
a normal subgroup @{term H} of a group @{term G}, their intersection is normal
in @{term G}\<close>

locale second_isomorphism_grp = normal +
  fixes S:: "'a set"
  assumes subgrpS: "subgroup S G"

context second_isomorphism_grp
begin

interpretation groupS: group "G\<lparr>carrier := S\<rparr>"
  using subgrpS
  by (metis subgroup_imp_group)

lemma normal_subgrp_intersection_normal:
  shows "S \<inter> H \<lhd> (G\<lparr>carrier := S\<rparr>)"
proof(auto simp: groupS.normal_inv_iff)
  from subgrpS is_subgroup have "\<And>x. x \<in> {S, H} \<Longrightarrow> subgroup x G" by auto
  hence "subgroup (\<Inter> {S, H}) G" using subgroups_Inter by blast
  hence "subgroup (S \<inter> H) G" by auto
  moreover have "S \<inter> H \<subseteq> S" by simp
  ultimately show "subgroup (S \<inter> H) (G\<lparr>carrier := S\<rparr>)"
    by (simp add: subgroup_incl subgrpS)
next
  fix g h
  assume g: "g \<in> S" and hH: "h \<in> H" and hS: "h \<in> S"
  from g hH subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> H"
    by (metis inv_op_closed2 subgroup.mem_carrier m_inv_consistent)
  from g hS subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> S"
    by (metis subgroup.m_closed subgroup.m_inv_closed m_inv_consistent)
qed

lemma normal_set_mult_subgroup:
  shows "subgroup (H <#> S) G"
proof(rule subgroupI)
  show "H <#> S \<subseteq> carrier G"
    by (metis setmult_subset_G subgroup.subset subgrpS subset)
next
  have "\<one> \<in> H" "\<one> \<in> S"
    using is_subgroup subgrpS subgroup.one_closed by auto
  hence "\<one> \<otimes> \<one> \<in> H <#> S"
    unfolding set_mult_def by blast
  thus "H <#> S \<noteq> {}" by auto
next
  fix g
  assume g: "g \<in> H <#> S"
  then obtain h s where h: "h \<in> H" and s: "s \<in> S" and ghs: "g = h \<otimes> s" unfolding set_mult_def
    by auto
  hence "s \<in> carrier G" by (metis subgroup.mem_carrier subgrpS)
  with h ghs obtain h' where h': "h' \<in> H" and "g = s \<otimes> h'"
    using coset_eq unfolding r_coset_def l_coset_def by auto
  with s have "inv g = (inv h') \<otimes> (inv s)"
    by (metis inv_mult_group mem_carrier subgroup.mem_carrier subgrpS)
  moreover from h' s subgrpS have "inv h' \<in> H" "inv s \<in> S"
    using subgroup.m_inv_closed m_inv_closed by auto
  ultimately show "inv g \<in> H <#> S"
    unfolding set_mult_def by auto
next
  fix g g'
  assume g: "g \<in> H <#> S" and h: "g' \<in> H <#> S"
  then obtain h h' s s' where hh'ss': "h \<in> H" "h' \<in> H" "s \<in> S" "s' \<in> S" and "g = h \<otimes> s" and "g' = h' \<otimes> s'"
    unfolding set_mult_def by auto
  hence "g \<otimes> g' = (h \<otimes> s) \<otimes> (h' \<otimes> s')" by metis
  also from hh'ss' have inG: "h \<in> carrier G" "h' \<in> carrier G" "s \<in> carrier G" "s' \<in> carrier G"
    using subgrpS mem_carrier subgroup.mem_carrier by force+
  hence "(h \<otimes> s) \<otimes> (h' \<otimes> s') = h \<otimes> (s \<otimes> h') \<otimes> s'"
    using m_assoc by auto
  also from hh'ss' inG obtain h'' where h'': "h'' \<in> H" and "s \<otimes> h' = h'' \<otimes> s"
    using coset_eq unfolding r_coset_def l_coset_def
    by fastforce
  hence "h \<otimes> (s \<otimes> h') \<otimes> s' = h \<otimes> (h'' \<otimes> s) \<otimes> s'"
    by simp
  also from h'' inG have "... = (h \<otimes> h'') \<otimes> (s \<otimes> s')"
    using m_assoc mem_carrier by auto
  finally have "g \<otimes> g' = h \<otimes> h'' \<otimes> (s \<otimes> s')".
  moreover have "... \<in> H <#> S"
    unfolding set_mult_def using h'' hh'ss' subgrpS subgroup.m_closed by fastforce
  ultimately show "g \<otimes> g' \<in> H <#> S"
    by simp
qed

lemma H_contained_in_set_mult:
  shows "H \<subseteq> H <#> S"
proof
  fix x
  assume x: "x \<in> H"
  have "x \<otimes> \<one> \<in> H <#> S" unfolding set_mult_def
    using second_isomorphism_grp.subgrpS second_isomorphism_grp_axioms subgroup.one_closed x by force
  with x show "x \<in> H <#> S" by (metis mem_carrier r_one)
qed

lemma S_contained_in_set_mult:
  shows "S \<subseteq> H <#> S"
proof
  fix s
  assume s: "s \<in> S"
  then have "\<one> \<otimes> s \<in> H <#> S" unfolding set_mult_def by force
  with s show "s \<in> H <#> S" using subgrpS subgroup.mem_carrier l_one by force
qed

lemma normal_intersection_hom:
  shows "group_hom (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)"
proof -
  have "group ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
    by (simp add: H_contained_in_set_mult normal.factorgroup_is_group normal_axioms
        normal_restrict_supergroup normal_set_mult_subgroup)
  moreover
  { fix g
    assume g: "g \<in> S"
    with g have "g \<in> H <#> S"
      using S_contained_in_set_mult by blast
    hence "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
      unfolding FactGroup_def RCOSETS_def r_coset_def by auto }
  moreover
  have "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> H #> x \<otimes> y = H #> x <#> (H #> y)"
    using normal.rcos_sum normal_axioms subgroup.mem_carrier subgrpS by fastforce
  ultimately show ?thesis
    by (auto simp: group_hom_def group_hom_axioms_def hom_def)
qed

lemma normal_intersection_hom_kernel:
  shows "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g) = H \<inter> S"
proof -
  have "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)
      = {g \<in> S. H #> g = \<one>\<^bsub>(G\<lparr>carrier := H <#> S\<rparr>) Mod H\<^esub>}"
    unfolding kernel_def by auto
  also have "... = {g \<in> S. H #> g = H}"
    unfolding FactGroup_def by auto
  also have "... = {g \<in> S. g \<in> H}"
    by (meson coset_join1 is_group rcos_const subgroupE(1) subgroup_axioms subgrpS subset_eq)
  also have "... = H \<inter> S" by auto
  finally show ?thesis.
qed

lemma normal_intersection_hom_surj:
  shows "(\<lambda>g. H #> g) ` carrier (G\<lparr>carrier := S\<rparr>) = carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
proof auto
  fix g
  assume "g \<in> S"
  hence "g \<in> H <#> S"
    using S_contained_in_set_mult by auto
  thus "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
    unfolding FactGroup_def RCOSETS_def r_coset_def by auto
next
  fix x
  assume "x \<in> carrier (G\<lparr>carrier := H <#> S\<rparr> Mod H)"
  then obtain h s where h: "h \<in> H" and s: "s \<in> S" and "x = H #> (h \<otimes> s)"
    unfolding FactGroup_def RCOSETS_def r_coset_def set_mult_def by auto
  hence "x = (H #> h) #> s"
    by (metis h s coset_mult_assoc mem_carrier subgroup.mem_carrier subgrpS subset)
  also have "... = H #> s"
    by (metis h is_group rcos_const)
  finally have "x = H #> s".
  with s show "x \<in> (#>) H ` S"
    by simp
qed

text \<open>Finally we can prove the actual isomorphism theorem:\<close>

theorem normal_intersection_quotient_isom:
  shows "(\<lambda>X. the_elem ((\<lambda>g. H #> g) ` X)) \<in> iso ((G\<lparr>carrier := S\<rparr>) Mod (H \<inter> S)) (((G\<lparr>carrier := H <#> S\<rparr>)) Mod H)"
using normal_intersection_hom_kernel[symmetric] normal_intersection_hom normal_intersection_hom_surj
by (metis group_hom.FactGroup_iso_set)

end

corollary (in group) normal_subgroup_set_mult_closed:
  assumes "M \<lhd> G" and "N \<lhd> G"
  shows "M <#> N \<lhd> G"
proof (rule normalI)
  from assms show "subgroup (M <#> N) G"
    using second_isomorphism_grp.normal_set_mult_subgroup normal_imp_subgroup
    unfolding second_isomorphism_grp_def second_isomorphism_grp_axioms_def by force
next
  show "\<forall>x\<in>carrier G. M <#> N #> x = x <# (M <#> N)"
  proof
    fix x
    assume x: "x \<in> carrier G"
    have "M <#> N #> x = M <#> (N #> x)"
      by (metis assms normal_inv_iff setmult_rcos_assoc subgroup.subset x)
    also have "\<dots> = M <#> (x <# N)"
      by (metis assms(2) normal.coset_eq x)
    also have "\<dots> = (M #> x) <#> N"
      by (metis assms normal_imp_subgroup rcos_assoc_lcos subgroup.subset x)
    also have "\<dots> = x <# (M <#> N)"
      by (simp add: assms normal.coset_eq normal_imp_subgroup setmult_lcos_assoc subgroup.subset x)
    finally show "M <#> N #> x = x <# (M <#> N)" .
  qed
qed

end


(*  Title:      HOL/ex/Transfer_Debug.thy
    Author:     Ondřej Kunčar, TU München
*)
theory Transfer_Debug
imports Main "HOL-Library.FSet"
begin

(*
  This file demonstrates some of the typical scenarios
  when transfer or transfer_prover does not produce expected results
  and how the user might handle such cases.
*)

(* As an example, we use finite sets. The following command recreates the environment in which
   the type of finite sets was created and allows us to do transferring on this type. *)
context
includes fset.lifting
begin

subsection \<open>1. A missing transfer rule\<close>

(* We will simulate the situation in which there is not any transfer rules for fmember. *)
declare fmember.transfer[transfer_rule del] fmember_transfer[transfer_rule del]

(* We want to prove the following theorem about |\<subseteq>| by transfer *)
lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer
(*
   Transfer complains that it could not find a transfer rule for |\<subseteq>| with a matching transfer
   relation. An experienced user could notice that |\<in>| was transferred to |\<in>| by a
   a default reflexivity transfer rule (because there was not any genuine transfer rule for |\<in>|)
   and fBall was transferred to Ball using the transfer relation pcr_fset. Therefore transfer
   is looking for a transfer rule for |\<subseteq>| with a transfer relation that mixes (=) and pcr_fset.
   This situation might be confusing because the real problem (a missing transfer rule) propagates
   during the transferring algorithm and manifests later in an obfuscated way. Fortunately,
   we could inspect the behavior of transfer in a more interactive way to pin down the real problem.
*)
oops

lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer_start
(* Setups 6 goals for 6 transfer rules that have to be found and the result as the 7. goal, which
   gets synthesized to the final result of transferring when we find the 6 transfer rules. *)
apply transfer_step
(* We can see that the default reflexivity transfer rule was applied and |\<in>|
  was transferred to |\<in>| \<Longrightarrow> there is no genuine transfer rule for |\<in>|. *)
oops

(* We provide a transfer rule for |\<in>|. *)

lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer_start
apply transfer_step (* The new transfer rule was selected and |\<in>| was transferred to \<in>. *)
apply transfer_step+
apply transfer_end
by blast

(* Of course in the real life, we would use transfer instead of transfer_start, transfer_step+ and
   transfer_end. *)
lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
by transfer blast

subsection \<open>2. Unwanted instantiation of a transfer relation variable\<close>

(* We want to prove the following fact. *)
lemma "finite (UNIV :: 'a::finite fset set)"
apply transfer
(* Transfer does not do anything here. *)
oops

(* Let us inspect interactively what happened. *)
lemma "finite (UNIV :: 'a::finite fset set)"
apply transfer_start
apply transfer_step
(*
   Here we can realize that not an expected transfer rule was chosen.
   We stumbled upon a limitation of Transfer: the tool used the rule Lifting_Set.UNIV_transfer,
   which transfers UNIV to UNIV and assumes that the transfer relation has to be bi-total.
   The problem is that at this point the transfer relation is not known (it is represented by
   a schematic variable ?R) and therefore in order to discharge the assumption "bi_total ?R", ?R is
   instantiated to (=.) If the relation had been known (we wish pcr_fset (=), which is not bi-total),
   the assumption bi_total pcr_fset (=) could not have been discharged and the tool would have
   backtracked and chosen Lifting.right_total_UNIV_transfer, which assumes only right-totalness
   (and pcr_fset is right-total).
*)
back back (* We can force the tool to backtrack and choose the desired transfer rule. *)
apply transfer_step
apply transfer_end
by auto

(* Of course, to use "back" in proofs is not a desired style. But we can prioritize
   the rule Lifting.right_total_UNIV_transfer by redeclaring it LOCALLY as a transfer rule.
 *)
lemma "finite (UNIV :: 'a::finite fset set)"
proof -
  note right_total_UNIV_transfer[transfer_rule]
  show ?thesis by transfer auto
qed

end

(* Let us close the environment of fset transferring and add the rule that we deleted. *)
lifting_forget fset.lifting (* deletes the extra added transfer rule for |\<in>| *)
declare fmember_transfer[transfer_rule] (* we want to keep parametricity of |\<in>| *)

end


theory Chapter10_3
imports
  "HOL-IMP.Live"
  "HOL-IMP.Small_Step"
begin

text\<open>
\exercise
Prove the following termination-insensitive version of the correctness of
@{const L}:
\<close>

theorem "\<lbrakk>(c, s) \<Rightarrow> s'; (c, t) \<Rightarrow> t'; s = t on L c X\<rbrakk> \<Longrightarrow> s' = t' on X"
proof (induct arbitrary: t t' X rule: big_step_induct)
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq(5) obtain ti where HSeqt: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
  from HSeqt(1) Seq(2, 6) have "s\<^sub>2 = ti on (L c\<^sub>2 X)" by auto
  with HSeqt(2) Seq(4) show "s\<^sub>3 = t' on X" by auto
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  from IfTrue(5) have H: "s = t on vars b" "s = t on L c\<^sub>1 X" by auto
  from bval_eq_if_eq_on_vars [OF H(1)] IfTrue(1) have "bval b t" by auto
  with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
  with IfTrue(3) H(2) show "s' = t' on X" by auto
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  from IfFalse(5) have H: "s = t on vars b" "s = t on L c\<^sub>2 X" by auto
  from bval_eq_if_eq_on_vars [OF H(1)] IfFalse(1) have "\<not>bval b t" by auto
  with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
  with IfFalse(3) H(2) show "s' = t' on X" by auto
next
  case (WhileFalse b s c)
  from WhileFalse(3) have H: "s = t on vars b" using L_While_vars by blast
  from bval_eq_if_eq_on_vars [OF H] WhileFalse(1) have "\<not>bval b t" by auto
  with WhileFalse(2) have "t = t'" by auto
  with WhileFalse(3) show ?case using L_While_X by blast
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  from WhileTrue(7) have H1: "s\<^sub>1 = t on vars b" "s\<^sub>1 = t on L c (L (WHILE b DO c) X)"
    using L_While_vars L_While_pfp by blast+
  from bval_eq_if_eq_on_vars [OF H1(1)] WhileTrue(1) have "bval b t" by auto
  with WhileTrue(6) obtain ti where H2: "(c, t) \<Rightarrow> ti" "(WHILE b DO c, ti) \<Rightarrow> t'" by auto
  from WhileTrue(3) H2(1) H1(2) have "s\<^sub>2 = ti on L (WHILE b DO c) X" by simp
  with H2(2) WhileTrue(5) show "s\<^sub>3 = t' on X" by simp
qed auto

text\<open>
Do not derive it as a corollary of the original correctness theorem
but prove it separately. Hint: modify the original proof.
\endexercise

\exercise\label{exe:bury-not-idemp}
Find a command @{text c} such that @{prop"bury (bury c {}) {} \<noteq> bury c {}"}.
For an arbitrary command, can you put a limit on the amount of burying needed
until everything that is dead is also buried?
\<close>

value "bury (''y'' ::= (V ''x'');; ''z'' ::= (V ''y'')) {}"
value "bury (bury (''y'' ::= (V ''x'');; ''z'' ::= (V ''y'')) {}) {}"
(* Amount of burying bounded above by the number of assignment statements,
  since the only transformation that bury does is removing assignment statements
*)

text\<open>
\endexercise

\exercise
Let @{term"lvars c"} / @{term"rvars c"} be the set of variables that
occur on the left-hand / right-hand side of an assignment in @{text c}.
Let @{term "rvars c"} additionally including those variables mentioned in
the conditionals of @{text IF} and @{text WHILE}.
Both functions are predefined in theory @{short_theory "Vars"}.
Show the following two properties of the small-step semantics.
Variables that are not assigned to do not change their value:
\<close>

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
proof (induct rule: star_induct)
  case (step c s c' s' c'' s'')
  from step(1, 4) have "s = s' on X" by (induct rule: small_step_induct) auto
  moreover from step(1, 4) have "lvars c' \<inter> X = {}" by (induct rule: small_step_induct) auto
  with step(3) have "s' = s'' on X" by simp
  ultimately show ?case by simp
qed simp

text\<open>
The reduction behaviour of a command is only influenced by the variables
read by the command:
\<close>

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); s = t on X; rvars c \<subseteq> X\<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<rightarrow>* (c',t') \<and> s' = t' on X"
proof (induct arbitrary: t rule: star_induct)
  case (step c s c' s' c'' s'')
    (* a stronger conclusion than necessary; that a step corresponds to a step,
    not several steps *)
  from step(1, 4, 5) have "\<exists>t'. (c, t) \<rightarrow> (c', t') \<and> s' = t' on X"
  proof (induct arbitrary: t rule: small_step_induct)
    case (Assign x a s)
    have "(x ::= a, t) \<rightarrow> (SKIP, t(x := aval a t))" by auto
    moreover from Assign have "s = t on vars a" by auto
    then have Hav: "aval a s = aval a t" by auto
    with Assign have "s(x := aval a s) = t(x := aval a t) on X" by auto
    ultimately show ?case by blast
  next
    case (Seq2 c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
    from Seq2(2-4) obtain t' where H: "(c\<^sub>1, t) \<rightarrow> (c\<^sub>1', t')" "s' = t' on X" by fastforce
    from H(1) have "(c\<^sub>1;; c\<^sub>2, t) \<rightarrow> (c\<^sub>1';; c\<^sub>2, t')" by auto
    with H(2) show ?case by auto
  next
    case (IfTrue b s c\<^sub>1 c\<^sub>2)
    from IfTrue(2, 3) have "s = t on vars b" by auto
    from IfTrue(1) bval_eq_if_eq_on_vars [OF this] have "bval b t" by auto
    then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<rightarrow> (c\<^sub>1, t)" by auto
    with IfTrue(2) show ?case by auto
  next
    case (IfFalse b s c\<^sub>1 c\<^sub>2)
    from IfFalse(2, 3) have "s = t on vars b" by auto
    from IfFalse(1) bval_eq_if_eq_on_vars [OF this] have "\<not>bval b t" by auto
    then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<rightarrow> (c\<^sub>2, t)" by auto
    with IfFalse(2) show ?case by auto
  qed auto
  then obtain t' where H1: "(c, t) \<rightarrow> (c', t')" "s' = t' on X" by auto
  from step(1, 5) have "rvars c' \<subseteq> X" by (induct rule: small_step_induct) auto
  with H1(2) step(3) obtain t'' where H2: "(c', t') \<rightarrow>* (c'', t'')" "s'' = t'' on X" by fastforce
  from H1(1) H2(1) have "(c, t) \<rightarrow>* (c'', t'')" by (simp add: star.step)
  with H2(2) show ?case by blast
qed auto

text\<open>
Hint: prove single step versions of the lemmas first.
\endexercise

\exercise
An \concept{available definitions} analysis determines which previous
assignments \texttt{x := a} are valid equalities \texttt{x = a} at later
program points.  For example, after \texttt{x := y+1} the equality \texttt{x =
y+1} is available, but after \mbox{\texttt{x := y+1;}} \texttt{y := 2} the equality \texttt{x = y+1} is
no longer available. The motivation for the analysis is that if \texttt{x =
a} is available before \texttt{v := a} then \mbox{\texttt{v := a}} can be replaced by
\texttt{v := x}.

Define an available definitions analysis as a gen/kill analysis,
for suitably defined @{text gen} and @{text kill} (which may need to be
mutually recursive):
\<close>
hide_const (open) gen "kill"
fun gen :: "com \<Rightarrow> (vname * aexp) set" and
  "kill" :: "com \<Rightarrow> (vname * aexp) set" where
  "gen SKIP = {}" |
  "gen (x ::= a) = (if x \<in> vars a then {} else {(x, a)})" |
  "gen (c\<^sub>1;; c\<^sub>2) = (gen c\<^sub>1 - kill c\<^sub>2) \<union> gen c\<^sub>2" |
  "gen (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = gen c\<^sub>1 \<inter> gen c\<^sub>2" |
  "gen (WHILE b DO c) = {}" |
  "kill SKIP = {}" |
  "kill (x ::= a) = {(x', a')| x' a'. x = x' \<or> x \<in> vars a'}" |
  "kill (c\<^sub>1;; c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
  "kill (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
  "kill (WHILE b DO c) = kill c"

definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
"AD A c = gen c \<union> (A - kill c)"

text\<open>
The defining equations for both @{const gen} and @{const kill} follow
the \isacom{where} and are separated by ``@{text "|"}'' as usual.

A call \ @{term"AD A c"} \ should compute the available definitions
after the execution of @{text c} assuming that the definitions in @{text A}
are available before the execution of @{text c}.

Prove correctness of the analysis:
\<close>

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  \<forall> (x,a) \<in> A. s x = aval a s \<rbrakk>
  \<Longrightarrow> \<forall> (x,a) \<in> AD A c. s' x = aval a s'"
proof (induct arbitrary: A rule: big_step_induct)
  case (Skip s)
  then show ?case by (auto simp add: AD_def)
next
  case (Assign x a s)
  show ?case
  proof (intro ballI, unfold AD_def)
    fix p' :: "vname \<times> aexp"
    assume Hin: "p' \<in> gen (x ::= a) \<union> (A - kill (x ::= a))"
    obtain x' a' where HP: "p' = (x', a')" using prod.split_sel by blast
    with Hin consider (Bgen) "(x', a') \<in> gen (x ::= a)" | (BA) "(x', a') \<in> (A - kill (x ::= a))" by auto
    then have "(s(x := aval a s)) x' = aval a' (s(x := aval a s))"
    proof cases
      case Bgen
      with Assign show ?thesis by (auto split: if_split_asm)
    next
      case BA
      with Assign have "s x' = aval a' s" "x' \<noteq> x" "x \<notin> vars a'" by auto
      then show ?thesis by auto
    qed
    with HP show "case p' of (x', a') \<Rightarrow> (s(x := aval a s)) x' = aval a' (s(x := aval a s))" by auto
  qed
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq(2, 5) have "\<forall>(x, a) \<in> AD A c\<^sub>1. s\<^sub>2 x = aval a s\<^sub>2" by (auto simp add: AD_def)
  with Seq(4) have "\<forall>(x, a) \<in> AD (AD A c\<^sub>1) c\<^sub>2. s\<^sub>3 x = aval a s\<^sub>3" by (auto simp add: AD_def)
  then show ?case by (auto simp add: AD_def)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  from WhileTrue(3, 6) have "\<forall>(x, a) \<in> AD A c. s\<^sub>2 x = aval a s\<^sub>2" by (auto simp add: AD_def)
  with WhileTrue(5) show ?case by (auto simp add: AD_def)
qed (auto simp add: AD_def)

text\<open>
\endexercise
\<close>

end


theory prop_81
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster take plus drop *)

lemma lemma_ag [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj [thy_expl]: "plus x2 (plus y2 x2) = plus y2 (plus x2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ak [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_al [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_am [thy_expl]: "plus (plus x2 y2) x2 = plus x2 (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_an [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ao [thy_expl]: "plus (plus x3 y3) (plus x3 z3) = plus (plus x3 z3) (plus x3 y3)"
by (hipster_induct_schemes plus.simps Nat.exhaust)

lemma lemma_a [thy_expl]: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_aa [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

lemma lemma_tai [thy_expl]: "take x3 Nil2 = Nil2"
by (hipster_induct_schemes take.simps)

lemma lemma_taj [thy_expl]: "take x3 (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma lemma_tak [thy_expl]: "take (S x3) (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

(*hipster drop take
lemma lemma_ab [thy_expl]: "drop x2 (take x2 y2) = Nil2"
by (hipster_induct_schemes drop.simps take.simps)*)

  theorem x0 :
    "(take n (drop m xs)) = (drop m (take (plus n m) xs))"
    by (hipster_induct_schemes drop.simps take.simps Nat.exhaust) (*
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Equivalences\<close>
theory Equivalence_Relations
  imports
    Partial_Equivalence_Relations
begin

definition "equivalence_rel_on P R \<equiv>
  partial_equivalence_rel_on P R \<and> reflexive_on P R"

lemma equivalence_rel_onI [intro]:
  assumes "partial_equivalence_rel_on P R"
  and "reflexive_on P R"
  shows "equivalence_rel_on P R"
  unfolding equivalence_rel_on_def using assms by blast

lemma equivalence_rel_onE [elim]:
  assumes "equivalence_rel_on P R"
  obtains "partial_equivalence_rel_on P R" "reflexive_on P R"
  using assms unfolding equivalence_rel_on_def by blast

lemma equivalence_rel_on_in_field_if_partial_equivalence_rel:
  assumes "partial_equivalence_rel R"
  shows "equivalence_rel_on (in_field R) R"
  using assms
  by (intro equivalence_rel_onI reflexive_on_in_field_if_partial_equivalence_rel) auto

corollary partial_equivalence_rel_iff_equivalence_rel_on_in_field:
  "partial_equivalence_rel R \<longleftrightarrow> equivalence_rel_on (in_field R) R"
  using equivalence_rel_on_in_field_if_partial_equivalence_rel by auto

definition "equivalence_rel (R :: 'a \<Rightarrow> _) \<equiv> equivalence_rel_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma equivalence_rel_eq_equivalence_rel_on:
  "equivalence_rel (R :: 'a \<Rightarrow> _) = equivalence_rel_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding equivalence_rel_def ..

lemma equivalence_relI [intro]:
  assumes "partial_equivalence_rel R"
  and "reflexive R"
  shows "equivalence_rel R"
  unfolding equivalence_rel_eq_equivalence_rel_on using assms
  by (intro equivalence_rel_onI partial_equivalence_rel_on_if_partial_equivalence_rel
    reflexive_on_if_reflexive)

lemma equivalence_relE [elim]:
  assumes "equivalence_rel R"
  obtains "partial_equivalence_rel R" "reflexive R"
  using assms unfolding equivalence_rel_eq_equivalence_rel_on
  by (elim equivalence_rel_onE)
  (simp only: partial_equivalence_rel_eq_partial_equivalence_rel_on
    reflexive_eq_reflexive_on)

lemma equivalence_rel_on_if_equivalence:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "equivalence_rel R"
  shows "equivalence_rel_on P R"
  using assms by (elim equivalence_relE)
  (intro equivalence_rel_onI partial_equivalence_rel_on_if_partial_equivalence_rel
    reflexive_on_if_reflexive)

subsubsection \<open>Instantiations\<close>

lemma equivalence_eq: "equivalence_rel (=)"
  using partial_equivalence_rel_eq reflexive_eq by (rule equivalence_relI)

lemma equivalence_top: "equivalence_rel \<top>"
  using partial_equivalence_rel_top reflexive_top by (rule equivalence_relI)

end


(*  Author: Tobias Nipkow  *)

section "Tries (List Version)"

theory Tries
imports Trie
begin

text\<open>This is a specialization of tries where values are lists.\<close>

type_synonym ('k,'v)tries = "('k,'v list)trie"

definition lookup_tries :: "('k,'v)tries \<Rightarrow> 'k list \<Rightarrow> 'v list" where
"lookup_tries t ks = (case lookup_trie t ks of None \<Rightarrow> [] | Some vs \<Rightarrow> vs)"

definition update_with_tries ::
  "'k list \<Rightarrow> ('v list \<Rightarrow> 'v list) \<Rightarrow> ('k, 'v) tries \<Rightarrow> ('k, 'v) tries" where
"update_with_tries ks f =
  update_with_trie ks (\<lambda>vo. case vo of None \<Rightarrow> f [] | Some vs \<Rightarrow> f vs)"

definition insert_tries :: "'k list \<Rightarrow> 'v \<Rightarrow> ('k,'v)tries \<Rightarrow> ('k,'v)tries" where
"insert_tries ks v =
  update_with_trie ks (\<lambda>vo. case vo of None \<Rightarrow> [v] | Some vs \<Rightarrow> v#vs)"

definition inserts_tries :: "('v \<Rightarrow> 'k list) \<Rightarrow> 'v list \<Rightarrow> ('k,'v)tries \<Rightarrow> ('k,'v)tries" where
"inserts_tries key = fold (%v. insert_tries (key v) v)"

definition tries_of_list :: "('v \<Rightarrow> 'k list) \<Rightarrow> 'v list \<Rightarrow> ('k,'v)tries" where
"tries_of_list key vs = inserts_tries key vs (Trie None [])"

definition set_tries :: "('k,'v)tries \<Rightarrow> 'v set" where
"set_tries t = Union {gs. \<exists>a. gs = set(lookup_tries t a)}"

definition all_tries :: "('v \<Rightarrow> bool) \<Rightarrow> ('k,'v)tries \<Rightarrow> bool" where
"all_tries P = all_trie (list_all P)"

subsection \<open>@{const lookup_tries}\<close>

lemma lookup_Nil[simp]:
  "lookup_tries (Trie vo ps) [] = (case vo of None \<Rightarrow> [] | Some vs \<Rightarrow> vs)"
by (simp add: lookup_tries_def)

lemma lookup_Cons[simp]: "lookup_tries (Trie vo ps) (a#as) =
  (case map_of ps a of None \<Rightarrow> [] | Some at \<Rightarrow> lookup_tries at as)"
by (simp add: lookup_tries_def split: option.split)

lemma lookup_empty[simp]: "lookup_tries (Trie None []) as = []"
by(case_tac as, simp_all add: lookup_tries_def)

theorem lookup_update:
 "lookup_tries (update_trie as vs t) bs =
 (if as=bs then vs else lookup_tries t bs)"
by(auto simp add: lookup_tries_def lookup_update)

theorem lookup_update_with:
 "lookup_tries (update_with_tries as f t) bs =
 (if as=bs then f(lookup_tries t as) else lookup_tries t bs)"
by(auto simp add: lookup_tries_def update_with_tries_def lookup_update_with_trie
  split: option.split)

subsection \<open>@{const insert_tries}, @{const inserts_tries}, @{const tries_of_list}\<close>

lemma invar_insert_tries: "invar_trie t \<Longrightarrow> invar_trie(insert_tries as v t)"
by(simp add: insert_tries_def invar_update_with_trie split: option.split)

lemma invar_inserts_tries:
  "invar_trie t \<Longrightarrow> invar_trie (inserts_tries key xs t)"
by(induct xs arbitrary: t)(auto simp: invar_insert_tries inserts_tries_def)

lemma invar_of_list: "invar_trie (tries_of_list key xs)"
by(simp add: tries_of_list_def invar_inserts_tries)

lemma set_lookup_insert_tries: "set (lookup_tries (insert_tries ks a t) ks') =
  (if ks' = ks then Set.insert a (set(lookup_tries t ks')) else set(lookup_tries t ks'))"
by(simp add: lookup_tries_def insert_tries_def lookup_update_with_trie set_eq_iff split: option.split)

lemma in_set_lookup_inserts_tries:
  "(v \<in> set(lookup_tries (inserts_tries key vs t) (key v))) =
   (v \<in> set vs \<union> set(lookup_tries t (key v)))"
by(induct vs arbitrary: t)
  (auto simp add: inserts_tries_def set_lookup_insert_tries)

lemma in_set_lookup_of_list:
  "v \<in> set(lookup_tries (tries_of_list key vs) (key v)) = (v \<in> set vs)"
by(simp add: tries_of_list_def in_set_lookup_inserts_tries)

lemma in_set_lookup_inserts_triesD:
  "v \<in> set(lookup_tries (inserts_tries key vs t) xs) \<Longrightarrow>
  v \<in> set vs \<union> set(lookup_tries t xs)"
apply(induct vs arbitrary: t)
 apply (simp add: inserts_tries_def)
apply (simp add: inserts_tries_def)
apply (fastforce simp add: set_lookup_insert_tries split: if_splits)
done

subsection \<open>@{const set_tries}\<close>

lemma set_tries_eq_ran: "set_tries t = Union(set ` ran(lookup_trie t))"
apply(auto simp add: set_eq_iff set_tries_def lookup_tries_def ran_def)
 apply metis
by (metis option.inject)

lemma set_tries_empty[simp]: "set_tries (Trie None []) = {}"
by(simp add: set_tries_def)

lemma set_tries_insert[simp]:
  "set_tries (insert_tries a x t) = Set.insert x (set_tries t)"
apply(auto simp: set_tries_def lookup_update set_lookup_insert_tries)
by (metis insert_iff)

lemma set_insert_tries:
  "set_tries (inserts_tries key xs t) =
   set xs Un set_tries t"
by(induct xs arbitrary: t) (auto simp: inserts_tries_def)

lemma set_tries_of_list[simp]:
  "set_tries(tries_of_list key xs) = set xs"
by(simp add: tries_of_list_def set_insert_tries)

lemma in_set_lookup_set_triesD:
  "x\<in>set (lookup_tries t a) \<Longrightarrow> x \<in> set_tries t"
by(auto simp: set_tries_def)

end