chapter \<open>Examples for IMP++\<close>
theory Examples
imports IPP_Lib "~~/src/HOL/Library/Multiset"
begin

locale Imp_Array_Examples begin
  unbundle IMP_Syntax          -- \<open>Syntactic Sugar for IMP Programs. Unbundling this may take some time.\<close>
  sublocale Vcg_Aux_Lemmas .   -- \<open>Library of auxiliary lemmas commonly needed for verification\<close>
end

context Imp_Array_Examples begin

section \<open>Common Loop Patterns\<close>
subsection \<open>Approximate from Below\<close>
text \<open>Used to invert a monotonic function.
  We count up, until we overshoot the desired result,
  then we subtract one.
\<close>

definition "sqrt_prog \<equiv>
  CLR r;;
  r ::= N 1;;
  WHILE ($r * $r <= $n) DO (
    r ::= Plus ($r) (N 1)
  );;
  r ::= Minus ($r) (N 1)
  "

text \<open>The invariant states that the \<open>r-1\<close> is not too big.
  When the loop terminates, \<open>r-1\<close> is not too big, but \<open>r\<close> is already too big,
  so \<open>r-1\<close> is the desired value (rounding down).
\<close>
definition Isqrt :: "int \<Rightarrow> int \<Rightarrow> bool"
  where "Isqrt n\<^sub>0 r \<equiv> 0\<le>r \<and> (r-1)\<^sup>2 \<le> n\<^sub>0"

text \<open>Note: Be careful to not accidentally define the invariant
  over some generic type \<open>'a\<close>! \<close>

lemma Isqrt_aux:
  "0 \<le> n\<^sub>0 \<Longrightarrow> Isqrt n\<^sub>0 1"
  "\<lbrakk>0 \<le> n\<^sub>0; r * r \<le> n\<^sub>0; Isqrt n\<^sub>0 r\<rbrakk> \<Longrightarrow> Isqrt n\<^sub>0 (r + 1)"
  "\<lbrakk>0 \<le> n\<^sub>0; \<not> r * r \<le> n\<^sub>0; Isqrt n\<^sub>0 r\<rbrakk> \<Longrightarrow> (r - 1)\<^sup>2 \<le> n\<^sub>0 \<and> n\<^sub>0 < r\<^sup>2"
  "Isqrt n\<^sub>0 r \<Longrightarrow> r * r \<le> n\<^sub>0 \<Longrightarrow> r\<le>n\<^sub>0"
  "\<lbrakk>0 \<le> n\<^sub>0; \<not> r * r \<le> n\<^sub>0; Isqrt n\<^sub>0 r\<rbrakk> \<Longrightarrow> 0 < r"
  apply (auto simp: Isqrt_def power2_eq_square algebra_simps)
  by (smt combine_common_factor mult_right_mono semiring_normalization_rules(3))

find_theorems "(_(_:=_)) _"

lemma "
  \<Turnstile>\<^sub>t {\<lambda>n\<^sub>0. vars n in n=n\<^sub>0 \<and> 0\<le>n\<^sub>0}
      sqrt_prog
    {\<lambda>n\<^sub>0. vars r n in n=n\<^sub>0 \<and> 0\<le>r \<and> r\<^sup>2 \<le> n\<^sub>0 \<and> n\<^sub>0 < (r+1)\<^sup>2} mod {''r''}"
  unfolding sqrt_prog_def

  apply (rewrite annot_tinvar[where
    R="measure (\<lambda>s. nat (s ''n'' 0 + 1 - s ''r'' 0))" and
    I="\<lambda>n\<^sub>0. vars r n in n=n\<^sub>0 \<and> 0\<le>n\<^sub>0 \<and> Isqrt n\<^sub>0 r
    "])
  supply Isqrt_aux [simp]
  by vcg

subsection \<open>Count Up\<close>

text \<open>
  Counter \<open>c\<close> counts from \<open>0\<close> to \<open>n\<close>, such that loop is executed \<open>n\<close> times.
\<close>

subsubsection \<open>Exponential\<close>
definition "exp_prog \<equiv>
  CLR c;; CLR r;;
  c ::= N 0;;
  r ::= N 1;;
  WHILE $c < $n DO (
    r ::= $r * $b;;
    c ::= $c + (N 1)
  )"

text \<open>The invariant states that we have computed the function for the counter value \<open>c\<close>:\<close>

abbreviation "Iexp n\<^sub>0 b\<^sub>0 r c \<equiv> 0\<le>c \<and> c\<le>n\<^sub>0 \<and> r = b\<^sub>0 ^ nat c"

lemma "
  \<Turnstile>\<^sub>t {\<lambda>(n\<^sub>0,b\<^sub>0). vars n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> 0\<le>n\<^sub>0}
       exp_prog
     {\<lambda>(n\<^sub>0,b\<^sub>0). vars r n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> r = b\<^sub>0 ^ nat n\<^sub>0} mod {''c'',''r''}"
  unfolding exp_prog_def
  apply (rewrite annot_tinvar[where
    R="measure (\<lambda>s. nat (s ''n'' 0 - s ''c'' 0))" and
    I="\<lambda>(n\<^sub>0,b\<^sub>0). vars r c n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> Iexp n\<^sub>0 b\<^sub>0 r c"])
  apply vcg
  done

subsubsection \<open>Factorial\<close>

definition ifact :: "int \<Rightarrow> int" where "ifact n = (\<Prod>i=1..n. i)"

lemma ifact_simps[simp]:
  "i\<ge>0 \<Longrightarrow> ifact (i+1) = (i+1)*ifact i"
  "i\<ge>0 \<Longrightarrow> ifact (1+i) = (1+i)*ifact i"
  "i\<le>0 \<Longrightarrow> ifact i = 1"
  unfolding ifact_def
  by (auto simp: algebra_simps)

lemma ifact_nonzero[simp]: "ifact n\<^sub>0 \<noteq> 0" unfolding ifact_def by auto

abbreviation "fact_prog \<equiv>
  CLR r;; CLR c;;
  r ::= N 1;;
  c ::= N 0;;
  WHILE ($c < $n) DO (
    c ::= $c + N 1;;
    r ::= $r * $c
  )"

definition "fact_invar n r c \<equiv> 0\<le>c \<and> c\<le>n \<and> r=ifact c"

lemma fact_prog_correct: "
  \<Turnstile>\<^sub>t {\<lambda>n\<^sub>0. vars n in n=n\<^sub>0 \<and> 0\<le>n }
       fact_prog
    {\<lambda>n\<^sub>0. vars n r in n=n\<^sub>0 \<and> r = (ifact n\<^sub>0) } mod {''r'',''c''}"
  apply (rewrite annot_tinvar[where
    I="\<lambda>n\<^sub>0. vars n r c in n=n\<^sub>0 \<and> fact_invar n\<^sub>0 r c"
  and R="measure_exp ($n - $c)"
    ])
  unfolding fact_invar_def
  by vcg

subsubsection \<open>Square by Sum\<close>

text \<open>We exploit the fact that \<open>n\<^sup>2\<close> is the sum of the first \<open>n\<close> odd numbers.
  We compute the next odd number in the loop, in auxiliary variable \<open>b\<close>.
\<close>

definition "sqr_prog \<equiv>
  CLR a;; CLR b;; CLR c;;
  b ::= \<acute>1;;
  a ::= \<acute>0;;
  c ::= \<acute>0;;
  WHILE ($c < $n) DO (
    a ::= $a + $b;;
    b ::= $b + \<acute>2;;
    c ::= $c + \<acute>1
  )"

lemma sqr_prog_correct:
  "\<Turnstile>\<^sub>t {\<lambda>_. vars n in n\<ge>0} sqr_prog {\<lambda>_. vars n a in a=n\<^sup>2} mod {''a'', ''b'', ''c''}"
  unfolding sqr_prog_def
  apply (rewrite annot_tinvar[where R="measure_exp ($n-$c)"
        and I="\<lambda>_. vars a b c n in a=c\<^sup>2 \<and> b = 2*c+1 \<and> c\<le>n"])
  apply vcg_all
  apply (auto simp: power2_eq_square algebra_simps)
  done

subsubsection \<open>Fibonacci Numbers\<close>
fun fib :: "nat \<Rightarrow> nat" where
  "fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib n + fib (Suc n)"

abbreviation "fib_prog \<equiv>
  CLR j;; CLR k;; CLR c;;
  j::=N 1;;
  k::=N 1;;
  c::=N 1;;

  WHILE $c < $n DO (
    CLR t;;
    t::=$k;; k::=$k+$j;; j::=$t;;
    c::=$c + N 1
  )
"

lemma fib_aux: "0 < c \<Longrightarrow> fib (nat c) + fib (nat (c - 1)) = fib (Suc (nat c))"
  by (smt Suc_nat_eq_nat_zadd1 add.commute fib.simps(3))

lemma fib_correct: "
  \<Turnstile> {\<lambda>_. vars n in 0\<le>n }
      fib_prog
    {\<lambda>_. vars n k in k = int (fib (nat n))} mod {''c'', ''j'', ''k'', ''t''}"
  apply (rewrite annot_invar[where I="\<lambda>_. vars j k c n in
       0<c \<and> 0\<le>n
    \<and> (0<n \<longrightarrow> c\<le>n \<and> j=int (fib (nat (c-1))) \<and> k = int (fib (nat c)))
    \<and> (n=0 \<longrightarrow> k=1)
  "])
  supply fib_aux[simp]
  by vcg

subsection \<open>Count down\<close>

subsubsection \<open>Exponential\<close>
text \<open>Essentially the same as count up, but we use the input variable as counter\<close>

definition "exp_prog' \<equiv>
  CLR r;;  (* Aux variables are cleared before use. *)
  r ::= N 1;;
  WHILE N 0 < $n DO (
    r ::= $r * $b;;
    n ::= $n - N 1
  )"

lemma [simp]: "lhs_vars exp_prog' = {''n'',''r''}"
  by (simp add: exp_prog'_def)

text \<open>The invariant is the same as for count-up.
  Only that we have to compute the actual number
  of loop iterations by \<open>n\<^sub>0 - n\<close>
\<close>
definition exp_invar' :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "exp_invar' n\<^sub>0 b\<^sub>0 n r \<equiv> (
      let c=n\<^sub>0-n in
        0\<le>c \<and> c\<le>n\<^sub>0 \<and> r = b\<^sub>0 ^ nat c
    )"

text \<open>If the invariants become more complex or hard to prove automatically,
  it can be advantageous to define the (logical part of) the invariant as
  a predicate, and prove the required VCs as separate lemmas.
\<close>

lemma exp_prog'_vcs:
  "\<lbrakk>0 \<le> n\<^sub>0; 0 < n; exp_invar' n\<^sub>0 b\<^sub>0 n r\<rbrakk> \<Longrightarrow> exp_invar' n\<^sub>0 b\<^sub>0 (n - 1) (r * b\<^sub>0)"
  "\<lbrakk>0 \<le> n\<^sub>0; \<not> 0 < n; exp_invar' n\<^sub>0 b\<^sub>0 n r\<rbrakk> \<Longrightarrow> r = b\<^sub>0 ^ nat n\<^sub>0"
  "0 \<le> n\<^sub>0 \<Longrightarrow> exp_invar' n\<^sub>0 b\<^sub>0 n\<^sub>0 1"
  by (auto simp: exp_invar'_def)

lemma exp_prog'_correct: "
  \<Turnstile>\<^sub>t {\<lambda>(n\<^sub>0,b\<^sub>0). vars n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> 0\<le>n\<^sub>0}
       exp_prog'
    {\<lambda>(n\<^sub>0,b\<^sub>0). vars r b in b=b\<^sub>0 \<and> r = (b\<^sub>0 ^ nat n\<^sub>0)} mod {''r'',''n''}"
proof -
  note [simp] = exp_prog'_vcs
  show ?thesis
    unfolding exp_prog'_def
    apply (rewrite annot_tinvar[where
      I="\<lambda>(n\<^sub>0,b\<^sub>0). vars r n b in b=b\<^sub>0 \<and> exp_invar' n\<^sub>0 b\<^sub>0 n r \<and> 0\<le>n\<^sub>0" and
      R="measure (\<lambda>s. nat (s ''n'' 0))"
      ])
    by vcg
qed

subsubsection \<open>Square by Sum\<close>
definition "sqr_prog' \<equiv>
  CLR a;; CLR b;;
  b ::= \<acute>1;;
  a ::= \<acute>0;;
  WHILE (\<acute>0 < $n) DO (
    a ::= $a + $b;;
    b ::= $b + \<acute>2;;
    n ::= $n - \<acute>1
  )"

lemma sqr_prog'_correct:
  "\<Turnstile>\<^sub>t {\<lambda>n\<^sub>0. vars n in n=n\<^sub>0 \<and> 0\<le>n\<^sub>0} sqr_prog' {\<lambda>n\<^sub>0. vars a in a=n\<^sub>0\<^sup>2} mod {''a'',''b'',''n''}"
  unfolding sqr_prog'_def
  apply (rewrite annot_tinvar[where R="measure_exp ($n)"
        and I="\<lambda>n\<^sub>0. vars a b n in 0\<le>n \<and> n\<le>n\<^sub>0 \<and> (let i=n\<^sub>0-n in b=2*i+1 \<and> a=i\<^sup>2)"])
  apply vcg_all
  apply (auto simp: power2_eq_square algebra_simps)
  done

subsubsection \<open>Factorial\<close>
definition "fact_prog' \<equiv>
  CLR r;;
  r ::= N 1;;
  WHILE ($n > N 0) DO (
    r ::= $r * $n;;
    n ::= $n - N 1
  )"

definition fact'_invar :: "int \<Rightarrow> _"
  where "fact'_invar n\<^sub>0 n r \<equiv> r = ifact n\<^sub>0 div ifact n \<and> 0\<le>n \<and> n\<le>n\<^sub>0"

lemma ifact_div_one_less:
  assumes "0 < n" "n \<le> n\<^sub>0"
  shows "ifact n\<^sub>0 div ifact (n - 1) = ifact n\<^sub>0 div ifact n * n"
proof -
  have [simp]: "finite B \<Longrightarrow> 0\<notin>A \<Longrightarrow> A\<subseteq>B \<Longrightarrow> \<Prod>B div \<Prod>A = \<Prod>(B-A)" for A B :: "int set"
    by (simp add: prod.subset_diff rev_finite_subset)
  have [simp]: "0<n \<Longrightarrow> n\<le>n\<^sub>0 \<Longrightarrow> ({1..n\<^sub>0} - {1..n - 1}) = insert n ({1..n\<^sub>0} - {1..n})"
    by auto

  from assms show ?thesis
    unfolding ifact_def by auto
qed

lemma fact'_vcs:
  "0 \<le> n\<^sub>0 \<Longrightarrow> fact'_invar n\<^sub>0 n\<^sub>0 1"
  "\<lbrakk>0 < n; fact'_invar n\<^sub>0 n r\<rbrakk> \<Longrightarrow> fact'_invar n\<^sub>0 (n - 1) (r * n)"
  "\<lbrakk>\<not> 0 < n; fact'_invar n\<^sub>0 n r\<rbrakk> \<Longrightarrow> r = ifact n\<^sub>0"
  by (auto simp: fact'_invar_def ifact_div_one_less)

lemma fact'_correct: "
  \<Turnstile>\<^sub>t {\<lambda>n\<^sub>0. vars n in n=n\<^sub>0 \<and> 0\<le>n}
       fact_prog'
    {\<lambda>n\<^sub>0. vars r in r = (ifact n\<^sub>0) } mod {''n'',''r''}"
  unfolding fact_prog'_def
  apply (rewrite annot_tinvar[where
      R="measure_exp ($n)"
    and I="\<lambda>n\<^sub>0. vars r n in fact'_invar n\<^sub>0 n r
  "])
  supply [simp] = fact'_vcs
  by vcg

section \<open>Reusing Programs in Context\<close>

declare exp_prog'_correct[vcg_rules]

fun (in -) tower2 :: "nat \<Rightarrow> nat" where
  "tower2 0 = 1"
| "tower2 (Suc n) = 2^tower2 n"

definition "tower2_prog \<equiv>
  CLR b;; CLR c;; CLR a;;
  b ::= \<acute>2;;
  c ::= \<acute>0;;
  a ::= \<acute>1;;
  WHILE $c < $x DO (
    CLR n;;
    n::=$a;;
    exp_prog';;
    a::=$r;;
    c::=$c+\<acute>1
  )"

lemma tower2_prog_correct: "\<Turnstile>\<^sub>t
  {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0 \<and> 0\<le>x}
    tower2_prog
  {\<lambda>x\<^sub>0. vars x a in x=x\<^sub>0 \<and> a=int (tower2 (nat x))} mod {''b'',''c'',''a'',''n'',''r''}"
  unfolding tower2_prog_def
  apply (rewrite annot_tinvar[where
    R = "measure_exp ($x-$c)" and
    I = "\<lambda>x\<^sub>0. vars b c a x in x=x\<^sub>0 \<and> 0\<le>c \<and> c\<le>x \<and> b=2 \<and> a = int (tower2 (nat c))"
  ])
  by vcg

section \<open>Working with Arrays\<close>

subsection \<open>Summation over Array\<close>

definition "array_sum \<equiv>
  CLR r;;
  r ::= N 0;;
  WHILE $l < $h DO (
    r ::= $r + a\<^bold>[$l\<^bold>];;
    l ::= $l + (\<acute>1)
  )"

lemma array_sum_aux:
  fixes f :: "int \<Rightarrow> int"
  shows "l\<^sub>0\<le>l \<Longrightarrow> (\<Sum>i=l\<^sub>0..<l+1. f i) = (\<Sum>i=l\<^sub>0..<l. f i) + f l"
  by (auto simp: intvs_incdec)

lemma "\<Turnstile>
  {\<lambda>l\<^sub>0. vars l h (a:imap) in l\<le>h \<and> l=l\<^sub>0 }
    Imp_Array_Examples.array_sum
  {\<lambda>l\<^sub>0. vars l h (a:imap) r in r = (\<Sum>i=l\<^sub>0..<h. a i) } mod {''l'',''r''}
  "
  unfolding array_sum_def
  apply (rewrite annot_invar[where
    I="\<lambda>l\<^sub>0. vars l h (a:imap) r in
      l\<^sub>0\<le>l \<and> l\<le>h
      \<and> r = (\<Sum>i=l\<^sub>0..<l. a i)"])
  supply array_sum_aux[simp]
  by vcg

text \<open>Getting rid of the \<open>l\<le>h\<close> precondition\<close>

lemma array_sum_correct: "\<Turnstile>
  {\<lambda>l\<^sub>0. vars l h (a:imap) in l=l\<^sub>0 }
    array_sum
  {\<lambda>l\<^sub>0. vars l h (a:imap) r in r = (\<Sum>i=l\<^sub>0..<h. a i) } mod {''l'',''r''}"
  unfolding array_sum_def
  apply (rewrite annot_invar[where
    I="\<lambda>l\<^sub>0. vars l h (a:imap) r in (
        if l\<^sub>0 \<le> h then
            l\<^sub>0 \<le>l
          \<and> l \<le> h
          \<and> r = (\<Sum>i\<in>{l\<^sub>0..<l}. a i)
        else
            r = 0
          \<and> l = l\<^sub>0
        )
        "])
  supply array_sum_aux[simp]
  supply if_splits[split]
  by vcg

text \<open>Summing up only elements greater 5\<close>

definition "array_sum_gt5 \<equiv>
  CLR r;;
  r ::= N 0;;
  WHILE $l < $h DO (
    IF N 5 < a\<^bold>[$l\<^bold>] THEN
      r ::= $r + a\<^bold>[$l\<^bold>]
    ELSE SKIP;;
    l ::= $l + N 1
  )"

abbreviation "gt5 i \<equiv> if i>5 then i else 0"

lemma array_sum_gt5_correct: "\<Turnstile>
  {\<lambda>l\<^sub>0. vars l h (a:imap) in l=l\<^sub>0}
    array_sum_gt5
  {\<lambda>l\<^sub>0. vars h (a:imap) r in r = (\<Sum>i\<in>{l\<^sub>0..<h}. gt5 (a i)) } mod {''r'',''l''}"
  unfolding array_sum_gt5_def
  apply (rewrite annot_invar[where
    I="\<lambda>l\<^sub>0. vars (a:imap) h l r in
      (
        if l\<^sub>0 \<le> h then
          l\<^sub>0\<le>l
          \<and> l\<le>h
          \<and> r = (\<Sum>i\<in>{l\<^sub>0..<l}. gt5 (a i))
        else
            r = 0
          \<and> l = l\<^sub>0
      )
        "])
  supply array_sum_aux[simp]
  supply if_splits[split]
  by vcg

subsection \<open>Range of an Array as List\<close>
function (sequential) lran :: "(int \<Rightarrow> val) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> val list" where
  "lran a l h = (if l<h then a l # lran a (l+1) h else [])"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(_,l,h). nat (h-l))") auto

declare lran.simps[simp del]

text \<open>
  \<open>lran a l h\<close> is the list \<open>[a\<^sub>l,a\<^sub>l\<^sub>+\<^sub>1,...,a\<^sub>h\<^sub>-\<^sub>1]\<close>
\<close>

subsubsection \<open>Auxiliary Lemmas\<close>

lemma lran_empty[simp]:
  "lran a l l = []"
  "lran a l h = [] \<longleftrightarrow> h\<le>l"
  by (rewrite lran.simps; auto)+

lemma lran_bwd_simp: "lran a l h = (if l<h then lran a l (h-1)@[a (h-1)] else [])"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  by (auto simp: less_le)

lemma lran_append1[simp]: "l\<le>h \<Longrightarrow> lran a l (h + 1) = lran a l h @ [a h]"
  by (rewrite in "\<hole> = _" lran_bwd_simp) auto

lemma lran_prepend1[simp]: "l\<le>h \<Longrightarrow> lran a (l-1) h = a(l-1) # lran a l h"
  by (rewrite in "\<hole> = _" lran.simps) auto

lemma lran_tail[simp]: "lran a (l+1) h = tl (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  done

lemma lran_butlast[simp]: "lran a l (h-1) = butlast (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran_bwd_simp)
  apply auto
  done

lemma lran_upd_outside[simp]:
  "i<l \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  "h\<le>i \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  done

lemma lran_eq_iff: "lran a l h = lran a' l h \<longleftrightarrow> (\<forall>i. l\<le>i \<and> i<h \<longrightarrow> a i = a' i)"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  by (metis antisym_conv not_less zless_imp_add1_zle)

lemma set_lran[simp]: "set (lran a l h) = a`{l..<h}"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply auto
  by (metis atLeastLessThan_iff image_iff not_less not_less_iff_gr_or_eq zless_imp_add1_zle)

lemma mset_lran[simp]: "mset (lran a l h) = image_mset a (mset_set {l..<h})"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  by (auto simp: intvs_lower_incr)

subsection \<open>Filtering\<close>
definition "filter_prog \<equiv>
  CLR r;; CLR w;;
  r::=$l;; w::=$l;;
  WHILE $r<$h DO (
    IF a\<^bold>[$r\<^bold>] > \<acute>5 THEN
      a\<^bold>[$w\<^bold>] ::= a\<^bold>[$r\<^bold>];;
      w::=$w+\<acute>1
    ELSE SKIP;;
    r::=$r+\<acute>1
  );;
  h::=$w
  "

lemma filter_prog_correct: "
  \<Turnstile>\<^sub>t {\<lambda>(h\<^sub>0,a\<^sub>0). vars l h (a:imap) in a=a\<^sub>0 \<and> h=h\<^sub>0 \<and> l\<le>h}
       filter_prog
     {\<lambda>(h\<^sub>0,a\<^sub>0). vars l h (a:imap) in h\<le>h\<^sub>0 \<and> lran a l h = filter (\<lambda>x. 5<x) (lran a\<^sub>0 l h\<^sub>0)}
     mod {''h'', ''r'', ''w'', ''a''}
     "
  unfolding filter_prog_def
  apply (rewrite annot_tinvar[where
    I="\<lambda>(h\<^sub>0,a\<^sub>0). vars l h (a:imap) r w in
      h=h\<^sub>0 \<and> l\<le>w \<and> w\<le>r \<and> r\<le>h \<and>
      lran a l w = filter (\<lambda>x. 5<x) (lran a\<^sub>0 l r) \<and>
      lran a r h = lran a\<^sub>0 r h
      "
    and
    R="measure_exp ($h - $r)"
    ])
  supply lran_eq_iff[simp]
  by vcg

subsection \<open>Find First Element in Range\<close>
  definition "find_in_range_prog \<equiv>
    WHILE $l<$h && a\<^bold>[$l\<^bold>] != $x DO l::=$l+\<acute>1
  "

  abbreviation "iran_spec l h a x \<equiv> (
    let
      iran = \<lambda>i. i\<in>{l..<h} \<and> a i = x  (* i is in range and points to x *)
    in
      (if \<exists>i. iran i then
        (LEAST i. iran i)    (* Return least index *)
       else h                (* Or upper bound to indicate that no element has been found *)
      )
    )"

  lemma find_in_range_prog_correct: "
    \<Turnstile> {\<lambda>l\<^sub>0. vars l h x (a : imap) in l=l\<^sub>0 \<and> l\<le>h}
      find_in_range_prog
    {\<lambda>l\<^sub>0. vars l h x (a : imap) in l = iran_spec l\<^sub>0 l a x } mod {''l''}"
    unfolding find_in_range_prog_def
    apply (rewrite annot_invar[where I="\<lambda>l\<^sub>0.
      vars l h x (a : imap) in
        l\<^sub>0\<le>l \<and> l\<le>h \<and> (\<forall>i\<in>{l\<^sub>0..<l}. a i \<noteq> x)"])
    apply vcg_all
    apply (auto simp: Let_def)
    done

subsection \<open>Minimum Sort\<close>

subsubsection \<open>Find Minimum\<close>

text \<open>Find index of minimum element in \<open>a i, ..., a (h-1)\<close>, return in \<open>j\<close>\<close>
definition "find_min \<equiv>
  CLR j;; CLR k;; CLR m;;
  j::=$i;; k::=$i+\<acute>1;; m::=a\<^bold>[$j\<^bold>];;
  WHILE $k<$h DO (
    (* m stores current minimum element, j stores its index *)
    IF a\<^bold>[$k\<^bold>] < $m THEN
      m ::= a\<^bold>[$k\<^bold>];;
      j::=$k
    ELSE SKIP;;
    k::=$k+\<acute>1
  )"

lemma [simp]: "lhs_vars find_min
  = {''k'', ''j'', ''m''}"
  unfolding find_min_def by auto

(* Augment the type signature as long as no type variables ('a,'b,...) occur
  in the output of the definition command! *)
definition find_min_invar :: "int \<Rightarrow> int \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> _"
  where
  "find_min_invar i h a j k m \<equiv>
      i\<le>j \<and> j<h \<and> i<k \<and> k\<le>h            (* Everything in range *)
    \<and> m = a j \<and> a j = Min (a`{i..<k})"  (* m stores minimum element, j its index *)

lemma fmi_vcs_aux1: "i\<^sub>0 < k \<Longrightarrow> \<forall>x\<in>{i\<^sub>0..<k}. a\<^sub>0 k < (a\<^sub>0::int\<Rightarrow>int) x \<Longrightarrow> a\<^sub>0 k = Min (a\<^sub>0 ` {i\<^sub>0..<k + 1})"
  apply (rule Min_eqI[symmetric])
  apply (auto simp: Ball_def)
  using eq_iff by fastforce

lemma fmi_vcs:
  "\<lbrakk>k < h; find_min_invar i h a j k m; a k < m\<rbrakk> \<Longrightarrow> find_min_invar i h a k (k + 1) (a k)"
  "\<lbrakk>k < h; find_min_invar i h a j k m; \<not> a k < m\<rbrakk> \<Longrightarrow> find_min_invar i h a j (k + 1) m"
  "\<lbrakk>\<not> k < h; find_min_invar i h a j k m\<rbrakk> \<Longrightarrow> i \<le> j \<and> j < h \<and> a j = Min (a ` {i..<h})"
  "i < h \<Longrightarrow> find_min_invar i h a i (i + 1) (a i)"
  unfolding find_min_invar_def
  apply (simp_all add: fmi_vcs_aux1)
  subgoal
    apply (clarsimp simp add: intvs_incdec min_def not_less)
    apply (rule Min_eqI)
    apply auto
    by (metis atLeastLessThan_iff eq_iff image_eqI)
  done

lemma find_min_correct[vcg_rules]: "\<Turnstile>\<^sub>t
  {\<lambda>_. vars i h (a:imap) in i<h}
    find_min
  {\<lambda>_. vars i h (a:imap) j in i\<le>j \<and> j<h \<and> (a j = Min (a`{i..<h}))}
  mod {''j'',''k'',''m''}"
  unfolding find_min_def
  apply (rewrite annot_tinvar[where
    R="measure_exp ($h - $k)" and
    I="\<lambda>_. vars i h (a:imap) j k m in find_min_invar i h a j k m"
  ])
  apply vcg_all

  (* If the VCs make the simplifier loop, some more 'creative' techniques may help.

    using fmi_vcs by metis+

    Or, apply them one by one!
  *)
  using fmi_vcs(1) apply metis
  using fmi_vcs(2) apply metis
  using fmi_vcs(3) apply metis
  using fmi_vcs(3) apply metis
  using fmi_vcs(3) apply metis
  using fmi_vcs(4) apply metis
  done

subsubsection \<open>Minsort Algorithm\<close>
text \<open>Sort the array \<open>a\<close> in between indices \<open>l\<close> and \<open>h\<close>.
  Idea: Find minimum element in remaining part array,
    swap to end of already sorted part.

    \<open>i\<close> points to first element of unsorted part.
\<close>
definition "minsort \<equiv>
  CLR i;;
  i::=$l;;
  WHILE $i<$h DO (
    find_min;;

    CLR t;;
    t ::= a\<^bold>[$i\<^bold>];;
    a\<^bold>[$i\<^bold>] ::= a\<^bold>[$j\<^bold>];;
    a\<^bold>[$j\<^bold>] ::= $t;;

    i::=$i+\<acute>1
  )"

definition "sorted_spec l l' \<equiv> mset l' = mset l \<and> sorted l'"

(* verify that all types are inferred as int, and no polymorphic ('a) types remain! *)
definition "I_minsort a\<^sub>0 l\<^sub>0 h\<^sub>0 a i \<equiv>
    l\<^sub>0\<le>i \<and> i\<le>h\<^sub>0
  \<and> mset (lran a\<^sub>0 l\<^sub>0 h\<^sub>0) = mset (lran a l\<^sub>0 h\<^sub>0)   (* Array contains original elements *)
  \<and> sorted (lran a l\<^sub>0 i)                        (* Sorted part is sorted *)
  \<and> (\<forall>k1\<in>{l\<^sub>0..<i}. \<forall>k2\<in>{i..<h\<^sub>0}. a k1 \<le> a k2)  (* Every element of unsorted part \<ge> sorted part *)
  "

lemma [simp]: "lhs_vars minsort = {''i'', ''a'', ''t'', ''k'', ''j'', ''m''}"
  unfolding minsort_def by auto

lemma image_mset_subst_in_range:
  assumes "i\<in>{l::int..<h}"
  shows "image_mset (f(i:=x)) (mset_set {l..<h}) = image_mset f (mset_set {l..<h}) - {#f i#} + {#x#}"
proof -
  from assms have "l<h" "l\<le>i" "i<h" by auto
  then show ?thesis
    apply (induction rule: int_less_induct)
    apply (auto simp: intvs_decr_l image_mset_subst_outside)
    apply (simp add: antisym_conv)
    done
qed

lemma minsort_vcs:
  "\<lbrakk>I_minsort z l ha aa ia; ia \<le> j; j < ha; aa j = Min (aa ` {ia..<ha})\<rbrakk>
       \<Longrightarrow> I_minsort z l ha (aa(ia := Min (aa ` {ia..<ha}), j := aa ia)) (ia + 1)"
  "\<lbrakk>\<not> i < h; I_minsort z l h a i\<rbrakk> \<Longrightarrow> sorted_spec (lran z l h) (lran a l h)"
  "l \<le> h \<Longrightarrow> I_minsort z l h z l"
  subgoal
    unfolding I_minsort_def
    apply (auto simp: sorted_append)
    apply (metis fun_upd_triv)
    apply (auto simp: image_mset_subst_in_range)
    done
  subgoal
    unfolding I_minsort_def sorted_spec_def
    by (auto)

  subgoal
    unfolding I_minsort_def
    by (auto)

  done

lemma minsort_correct: "\<Turnstile>\<^sub>t
  {\<lambda>a\<^sub>0. vars l h (a:imap) in l\<le>h \<and> a=a\<^sub>0}
    minsort
  {\<lambda>a\<^sub>0. vars l h (a:imap) in sorted_spec (lran a\<^sub>0 l h) (lran a l h) }
    mod {''i'',''t'',''j'',''k'',''m'',''a''}"

  unfolding minsort_def
  apply (rewrite annot_tinvar[where
    R = "measure_exp ($h - $i)" and
    I = "\<lambda>a\<^sub>0. vars l h (a:imap) i in I_minsort a\<^sub>0 l h a i"
    ])
  supply minsort_vcs[simp]
  by vcg

section \<open>Debugging\<close>
text \<open>Automatic Derivation of Big-Step Execution\<close>
  fun vlist' :: "int \<Rightarrow> val list \<Rightarrow> (int \<Rightarrow> val)" where
    "vlist' l [] = (\<lambda>_. 0)"
  | "vlist' l (x#xs) = (vlist' (l+1) xs)(l:=x)"

  abbreviation "vlist \<equiv> vlist' 0"

  schematic_goal "(array_sum,<''l'':=var 1, ''h'':=var 5, ''a'':=vlist [100,1,2,3,4,200,300]>) \<Rightarrow> ?s"
    unfolding array_sum_def
    by BigSteps

  schematic_goal "(fact_prog',<''n'' := var 5>) \<Rightarrow> ?s"
    unfolding fact_prog'_def
    by BigSteps

end

end


theory Homework5_2
imports Main
begin

  (*
    ISSUED: Wednesday, October 18
    DUE: Wednesday, October 25, 11:59pm
    POINTS: 5
  *)

  (*
    In a directed graph, a path from node q to node v is the list of nodes
    visited on the way from q to v, including the first node, and excluding
    the last node.

    Inductively, we can characterize paths as follows:
  *)
  inductive path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
    "path E q [] q"
  | "\<lbrakk> E p q; path E q w r \<rbrakk> \<Longrightarrow> path E p (p#w) r"

  (*
    Functionally, we have the following characterization:
  *)
  lemma path_Nil_conv: "path E p [] q \<longleftrightarrow> q=p"
    by (auto elim: path.cases intro: path.intros)

  lemma path_Cons_conv: "path E p (x#xs) q \<longleftrightarrow> (x=p \<and> (\<exists>r. E p r \<and> path E r xs q))"
    by (auto elim: path.cases intro: path.intros)

  (* Prove the equivalence rule for appending two paths.
    Hint: Induction on w1, use the path_Nil_conv and path_Cons_conv
      lemmas as simp-rules. Proof should be straightforward, probably no Isar required.
  *)
  lemma path_append_conv: "path E p (w1@w2) q \<longleftrightarrow> (\<exists>r. path E p w1 r \<and> path E r w2 q)"
    sorry

  (*
    A path is called simple, if it visits each node at most once
    (except for circular path, that, of course, visit their common
      start and end node twice)

    For our path definition, a path is simple if and only if it contains
    no node twice (Isabelle constant: distinct). Recall, the end node is excluded.

    Show: If there is a path from p to q, then there is also a
      simple path from p to q.

    Proof sketch (informal):
      Induction on the length of the path (rule: length_induct)
        Assume we have a path xs from p to q.
        IH: For all shorter path, we can find a simple path
        To show: There is a simple path from p to q

        If xs is already distinct, we are done.
        Otherwise, xs must have the form xs = xs1@[x]@xs2@[x]@xs3 (thm not_distinct_decomp)
        hence, we obtain nodes p1 p2 such that
          p -xs1\<rightarrow> x   x\<rightarrow>p1   p1 -xs2\<rightarrow> x   x\<rightarrow>p2   p2 -xs3\<rightarrow> q

        Here, p -xs\<rightarrow> q denotes a path, and p\<rightarrow>q a single edge.

        by "dropping" the loop, we obtain a path  p -xs1@[x]@xs3\<rightarrow> q
        this path is shorter than the original path, so by IH, we have a simple path from p to q.
        QED.

    Prove the lemma formally. Most probably, you will need Isar!
  *)
  lemma
    assumes "path E p xs q"
    shows "\<exists>ys. distinct ys \<and> path E p ys q"
    using assms
  proof (induction xs rule: length_induct)
    case (1 xs)

    (* These two lines just assign more readable names to the premises and the IH *)
    note PREMS="1.prems"
    note IH="1.IH"

    (* Now we use these names *)
    thm PREMS (* We may assume that we have a path*)
    thm IH    (* For shorter path, there exists distinct paths *)
    term ?case (* We have to show that there exists a distinct path *)

    show ?case sorry (* Fill in your proof here! *)
  qed

end


(*  Title:      HOL/Library/Lub_Glb.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Amine Chaieb, University of Cambridge *)

section \<open>Definitions of Least Upper Bounds and Greatest Lower Bounds\<close>

theory Lub_Glb
imports Complex_Main
begin

text \<open>Thanks to suggestions by James Margetson\<close>

definition setle :: "'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"  (infixl "*<=" 70)
  where "S *<= x = (ALL y: S. y \<le> x)"

definition setge :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool"  (infixl "<=*" 70)
  where "x <=* S = (ALL y: S. x \<le> y)"

subsection \<open>Rules for the Relations \<open>*<=\<close> and \<open><=*\<close>\<close>

lemma setleI: "ALL y: S. y \<le> x \<Longrightarrow> S *<= x"
  by (simp add: setle_def)

lemma setleD: "S *<= x \<Longrightarrow> y: S \<Longrightarrow> y \<le> x"
  by (simp add: setle_def)

lemma setgeI: "ALL y: S. x \<le> y \<Longrightarrow> x <=* S"
  by (simp add: setge_def)

lemma setgeD: "x <=* S \<Longrightarrow> y: S \<Longrightarrow> x \<le> y"
  by (simp add: setge_def)

definition leastP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "leastP P x = (P x \<and> x <=* Collect P)"

definition isUb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isUb R S x = (S *<= x \<and> x: R)"

definition isLub :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isLub R S x = leastP (isUb R S) x"

definition ubs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
  where "ubs R S = Collect (isUb R S)"

subsection \<open>Rules about the Operators @{term leastP}, @{term ub} and @{term lub}\<close>

lemma leastPD1: "leastP P x \<Longrightarrow> P x"
  by (simp add: leastP_def)

lemma leastPD2: "leastP P x \<Longrightarrow> x <=* Collect P"
  by (simp add: leastP_def)

lemma leastPD3: "leastP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<le> y"
  by (blast dest!: leastPD2 setgeD)

lemma isLubD1: "isLub R S x \<Longrightarrow> S *<= x"
  by (simp add: isLub_def isUb_def leastP_def)

lemma isLubD1a: "isLub R S x \<Longrightarrow> x: R"
  by (simp add: isLub_def isUb_def leastP_def)

lemma isLub_isUb: "isLub R S x \<Longrightarrow> isUb R S x"
  unfolding isUb_def by (blast dest: isLubD1 isLubD1a)

lemma isLubD2: "isLub R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
  by (blast dest!: isLubD1 setleD)

lemma isLubD3: "isLub R S x \<Longrightarrow> leastP (isUb R S) x"
  by (simp add: isLub_def)

lemma isLubI1: "leastP(isUb R S) x \<Longrightarrow> isLub R S x"
  by (simp add: isLub_def)

lemma isLubI2: "isUb R S x \<Longrightarrow> x <=* Collect (isUb R S) \<Longrightarrow> isLub R S x"
  by (simp add: isLub_def leastP_def)

lemma isUbD: "isUb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
  by (simp add: isUb_def setle_def)

lemma isUbD2: "isUb R S x \<Longrightarrow> S *<= x"
  by (simp add: isUb_def)

lemma isUbD2a: "isUb R S x \<Longrightarrow> x: R"
  by (simp add: isUb_def)

lemma isUbI: "S *<= x \<Longrightarrow> x: R \<Longrightarrow> isUb R S x"
  by (simp add: isUb_def)

lemma isLub_le_isUb: "isLub R S x \<Longrightarrow> isUb R S y \<Longrightarrow> x \<le> y"
  unfolding isLub_def by (blast intro!: leastPD3)

lemma isLub_ubs: "isLub R S x \<Longrightarrow> x <=* ubs R S"
  unfolding ubs_def isLub_def by (rule leastPD2)

lemma isLub_unique: "[| isLub R S x; isLub R S y |] ==> x = (y::'a::linorder)"
  apply (frule isLub_isUb)
  apply (frule_tac x = y in isLub_isUb)
  apply (blast intro!: order_antisym dest!: isLub_le_isUb)
  done

lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
  by (simp add: isUbI setleI)

definition greatestP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "greatestP P x = (P x \<and> Collect P *<=  x)"

definition isLb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isLb R S x = (x <=* S \<and> x: R)"

definition isGlb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isGlb R S x = greatestP (isLb R S) x"

definition lbs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
  where "lbs R S = Collect (isLb R S)"

subsection \<open>Rules about the Operators @{term greatestP}, @{term isLb} and @{term isGlb}\<close>

lemma greatestPD1: "greatestP P x \<Longrightarrow> P x"
  by (simp add: greatestP_def)

lemma greatestPD2: "greatestP P x \<Longrightarrow> Collect P *<= x"
  by (simp add: greatestP_def)

lemma greatestPD3: "greatestP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<ge> y"
  by (blast dest!: greatestPD2 setleD)

lemma isGlbD1: "isGlb R S x \<Longrightarrow> x <=* S"
  by (simp add: isGlb_def isLb_def greatestP_def)

lemma isGlbD1a: "isGlb R S x \<Longrightarrow> x: R"
  by (simp add: isGlb_def isLb_def greatestP_def)

lemma isGlb_isLb: "isGlb R S x \<Longrightarrow> isLb R S x"
  unfolding isLb_def by (blast dest: isGlbD1 isGlbD1a)

lemma isGlbD2: "isGlb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
  by (blast dest!: isGlbD1 setgeD)

lemma isGlbD3: "isGlb R S x \<Longrightarrow> greatestP (isLb R S) x"
  by (simp add: isGlb_def)

lemma isGlbI1: "greatestP (isLb R S) x \<Longrightarrow> isGlb R S x"
  by (simp add: isGlb_def)

lemma isGlbI2: "isLb R S x \<Longrightarrow> Collect (isLb R S) *<= x \<Longrightarrow> isGlb R S x"
  by (simp add: isGlb_def greatestP_def)

lemma isLbD: "isLb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
  by (simp add: isLb_def setge_def)

lemma isLbD2: "isLb R S x \<Longrightarrow> x <=* S "
  by (simp add: isLb_def)

lemma isLbD2a: "isLb R S x \<Longrightarrow> x: R"
  by (simp add: isLb_def)

lemma isLbI: "x <=* S \<Longrightarrow> x: R \<Longrightarrow> isLb R S x"
  by (simp add: isLb_def)

lemma isGlb_le_isLb: "isGlb R S x \<Longrightarrow> isLb R S y \<Longrightarrow> x \<ge> y"
  unfolding isGlb_def by (blast intro!: greatestPD3)

lemma isGlb_ubs: "isGlb R S x \<Longrightarrow> lbs R S *<= x"
  unfolding lbs_def isGlb_def by (rule greatestPD2)

lemma isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::'a::linorder)"
  apply (frule isGlb_isLb)
  apply (frule_tac x = y in isGlb_isLb)
  apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
  done

lemma bdd_above_setle: "bdd_above A \<longleftrightarrow> (\<exists>a. A *<= a)"
  by (auto simp: bdd_above_def setle_def)

lemma bdd_below_setge: "bdd_below A \<longleftrightarrow> (\<exists>a. a <=* A)"
  by (auto simp: bdd_below_def setge_def)

lemma isLub_cSup:
  "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. S *<= b) \<Longrightarrow> isLub UNIV S (Sup S)"
  by  (auto simp add: isLub_def setle_def leastP_def isUb_def
            intro!: setgeI cSup_upper cSup_least)

lemma isGlb_cInf:
  "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. b <=* S) \<Longrightarrow> isGlb UNIV S (Inf S)"
  by  (auto simp add: isGlb_def setge_def greatestP_def isLb_def
            intro!: setleI cInf_lower cInf_greatest)

lemma cSup_le: "(S::'a::conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> S *<= b \<Longrightarrow> Sup S \<le> b"
  by (metis cSup_least setle_def)

lemma cInf_ge: "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> b <=* S \<Longrightarrow> Inf S \<ge> b"
  by (metis cInf_greatest setge_def)

lemma cSup_bounds:
  fixes S :: "'a :: conditionally_complete_lattice set"
  shows "S \<noteq> {} \<Longrightarrow> a <=* S \<Longrightarrow> S *<= b \<Longrightarrow> a \<le> Sup S \<and> Sup S \<le> b"
  using cSup_least[of S b] cSup_upper2[of _ S a]
  by (auto simp: bdd_above_setle setge_def setle_def)

lemma cSup_unique: "(S::'a :: {conditionally_complete_linorder, no_bot} set) *<= b \<Longrightarrow> (\<forall>b'<b. \<exists>x\<in>S. b' < x) \<Longrightarrow> Sup S = b"
  by (rule cSup_eq) (auto simp: not_le[symmetric] setle_def)

lemma cInf_unique: "b <=* (S::'a :: {conditionally_complete_linorder, no_top} set) \<Longrightarrow> (\<forall>b'>b. \<exists>x\<in>S. b' > x) \<Longrightarrow> Inf S = b"
  by (rule cInf_eq) (auto simp: not_le[symmetric] setge_def)

text\<open>Use completeness of reals (supremum property) to show that any bounded sequence has a least upper bound\<close>

lemma reals_complete: "\<exists>X. X \<in> S \<Longrightarrow> \<exists>Y. isUb (UNIV::real set) S Y \<Longrightarrow> \<exists>t. isLub (UNIV :: real set) S t"
  by (intro exI[of _ "Sup S"] isLub_cSup) (auto simp: setle_def isUb_def intro!: cSup_upper)

lemma Bseq_isUb: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
  by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)

lemma Bseq_isLub: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
  by (blast intro: reals_complete Bseq_isUb)

lemma isLub_mono_imp_LIMSEQ:
  fixes X :: "nat \<Rightarrow> real"
  assumes u: "isLub UNIV {x. \<exists>n. X n = x} u" (* FIXME: use 'range X' *)
  assumes X: "\<forall>m n. m \<le> n \<longrightarrow> X m \<le> X n"
  shows "X \<longlonglongrightarrow> u"
proof -
  have "X \<longlonglongrightarrow> (SUP i. X i)"
    using u[THEN isLubD1] X
    by (intro LIMSEQ_incseq_SUP) (auto simp: incseq_def image_def eq_commute bdd_above_setle)
  also have "(SUP i. X i) = u"
    using isLub_cSup[of "range X"] u[THEN isLubD1]
    by (intro isLub_unique[OF _ u]) (auto simp add: image_def eq_commute)
  finally show ?thesis .
qed

lemmas real_isGlb_unique = isGlb_unique[where 'a=real]

lemma real_le_inf_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. b <=* s \<Longrightarrow> Inf s \<le> Inf (t::real set)"
  by (rule cInf_superset_mono) (auto simp: bdd_below_setge)

lemma real_ge_sup_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. s *<= b \<Longrightarrow> Sup s \<ge> Sup (t::real set)"
  by (rule cSup_subset_mono) (auto simp: bdd_above_setle)

end


theory Part_1 imports Main

begin

(* 4.1 *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node left a right) = (set left) \<union> (set right) \<union> {a}"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node left a right) = ((\<forall>x\<in>set left. x \<le> a) \<and> (\<forall>y\<in>set right. y > a) \<and> ord left \<and> ord right)"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins n Tip = Node Tip n Tip" |
"ins n (Node left a right) =
  (if n = a
    then Node left a right
  else if n \<le> a
    then Node (ins n left) a right
  else
    Node left a (ins n right))"

lemma set_ins [simp] : "set (ins x t) = {x} \<union> set t"
  apply(induction t)
   apply(auto)
  done

lemma ord_ins : "ord t \<Longrightarrow> ord (ins i t)"
  apply(induction t)
   apply(auto)
  done

end


theory Chapter3
imports Main Chapter2
begin

(* Exercise 3.1 *)

datatype 'a tree = Tip | Node " 'a tree" 'a " 'a tree"

fun set :: " 'a tree \<Rightarrow> 'a set" where
"set Tip = {}"
| "set (Node l a r) = {a} \<union> (set l) \<union> (set r)"

fun leq_tree :: "int tree \<Rightarrow> int \<Rightarrow> bool" where
"leq_tree Tip x = True"
| "leq_tree (Node l a r) x = ((a \<le> x) & (leq_tree l x) & (leq_tree r x))"

fun sg_tree :: "int tree \<Rightarrow> int \<Rightarrow> bool" where
"sg_tree Tip x = True"
| "sg_tree (Node l a r) x = ((x < a) & (sg_tree l x) & (sg_tree r x))"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True"
| "ord (Node l a r) = ( (ord l) & (ord r) & (leq_tree l a) & (sg_tree r a)  ) "

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins x Tip = Node Tip x Tip"
| "ins x (Node l a r) = (
    if x = a then Node l a r
    else (if x < a then Node (ins x l) a r  else Node l a (ins x r))
)"

lemma ins_spec : "set (ins x t) = {x} \<union> set t"
  apply(induction t arbitrary: x)
   apply(auto)
  done

lemma tree_ord_prop1 [simp] : "leq_tree t1 x2  \<Longrightarrow> x < x2 \<Longrightarrow> leq_tree (ins x t1) x2"
  apply(induction t1 arbitrary: x2 x)
   apply(auto)
  done

lemma trich_int_prop : "\<not> x < x2 \<Longrightarrow> x \<noteq> x2 \<Longrightarrow> x2 < (x::int)"
  apply(auto)
  done

lemma tree_ord_prop2 [simp]  : " sg_tree t2 x2 \<Longrightarrow> x2 < x \<Longrightarrow> sg_tree (ins x t2) x2"
  apply(induction t2 arbitrary: x2 x)
   apply(auto)
  done

lemma ord_spec : "ord t \<Longrightarrow>  ord (ins x t)"
  apply(induction t)
   apply(auto)
  done

(* Exercise 3.2 *)

inductive palindrome :: " 'a list \<Rightarrow> bool " where
empty : " palindrome Nil"
| singleton : "palindrome [a]"
| palin_append : " palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

lemma palindrome_correct : " palindrome xs \<Longrightarrow> rev xs = xs "
  apply(induction xs rule: palindrome.induct)
    apply(auto)
  done

(* Exercise 3.3 *)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl : "star r x x" |
step : " r x y  \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl' : "star' r x x" |
step' : "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star_step_symm [intro] : "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(rule step)
    apply(auto)
   apply(rule refl)
  apply(rule step)
   apply(auto)
  done

lemma star'_step'_symm [intro] : "  star' r y z \<Longrightarrow> r x y  \<Longrightarrow>  star' r x z"
 apply(induction rule: star'.induct)
   apply(rule step')
    apply(auto)
   apply(rule refl')
  apply(rule step')
   apply(auto)
  done

lemma star_star'_equiv : "star' r x y = star r x y"
  apply(rule)
   apply(induction rule: star'.induct)
    apply(simp add: refl)
   apply(auto)
  apply(induction rule: star.induct)
   apply(rule refl')
  apply(auto)
  done

(* Exercise 3.4 *)

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
 iter0: "iter r 0 x x"
| iter1: "r x y \<Longrightarrow>  iter r (Suc 0) x y"
| iter_step: "iter r n x y \<Longrightarrow> iter r m y z \<Longrightarrow> iter r (n + m) x z"

lemma trivial [simp] : "  iter r n y z \<Longrightarrow> \<exists> m.  iter r m y z"
  by auto

lemma iter_spec : " star r x y \<Longrightarrow> EX n.  iter r n x y"
  apply(induction rule: star.induct)
   apply(rule)
   apply(rule iter0)
  apply(auto)
  apply(rule)
  apply(rule iter_step)
   apply(rule iter1)
   apply(assumption)
  apply(rule)
   apply(auto)
  apply(rule iter0)
  done

(* Exercise 3.5 *)

datatype alpha = a | b | c

type_synonym word = "alpha list"

inductive S :: "word  \<Rightarrow> bool" where
Sempty : "S Nil"
| Sconj : " S w \<Longrightarrow> S ( a # w @ [b]) "
| Sdouble : " S w \<Longrightarrow> S u  \<Longrightarrow> S (w @ u)"

inductive T :: "word  \<Rightarrow> bool" where
Tempty : "T Nil"
| Talt : " T w \<Longrightarrow> T u \<Longrightarrow> T ( w @ [a] @ u @ [b]) "

lemma T_append [simp] : " T u \<Longrightarrow> T w \<Longrightarrow> T(w @ u) "
  apply(induction rule: T.induct)
   apply(simp)
  apply(metis T.simps app_assoc) (* by Sledgehammer *)
  done

lemma S_T_equiv : " S w = T w "
  apply(rule)
   apply(induction rule: S.induct)
     apply(rule Tempty)
    apply(auto)
   apply (metis T.simps Tempty append.simps(1) append.simps(2)) (* by Sledgehammer *)
  apply(induction rule: T.induct)
   apply(rule)
  apply(auto)
  apply(simp add: Sconj Sdouble)
  done

end


theory Fib
  imports Main
begin

section {* Fibonacci *}

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

value "fib 0"
value "fib 1"
value "fib (Suc (Suc 0))"

lemma fib_test1: "fib 1 = 1" by simp
lemma fib_test2: "fib (Suc 1) = 2" by simp
lemma fib_test3: "fib (Suc (Suc 1)) = 3" by simp

theorem fib_thy: "fib n \<ge> 1"
  apply(induction n rule:fib.induct)
  apply(auto)
  done

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Additional properties of relations, and operators on relations,
  as they have been defined by Relations.thy\<close>

theory RelationProperties
imports
  RelationOperators

begin

subsection \<open>Right-Uniqueness\<close>

(* flip is applied to pairs so that (flip (x, y)) = (y, x) *)
lemma injflip: "inj_on flip A"
  by (metis flip_flip inj_on_def)

lemma lm01: "card P = card (P^-1)"
  using card_image flip_conv injflip by metis

lemma cardinalityOneTheElemIdentity: "(card X = 1) = (X={the_elem X})"
  by (metis One_nat_def card_Suc_eq card_empty empty_iff the_elem_eq)

lemma lm02: "trivial X = (X={} \<or> card X=1)"
  using cardinalityOneTheElemIdentity order_refl subset_singletonD trivial_def trivial_empty by (metis(no_types))

lemma lm03: "trivial P = trivial (P^-1)"
  using trivial_def subset_singletonD  subset_refl subset_insertI cardinalityOneTheElemIdentity converse_inject
        converse_empty lm01
  by metis

(* The range of P restricted to X is equal to the image of X through P *)
lemma restrictedRange: "Range (P||X) = P``X"
  unfolding restrict_def by blast

lemma doubleRestriction:  "((P || X) || Y) = (P || (X \<inter> Y))"
  unfolding restrict_def by fast

lemma restrictedDomain: "Domain (R||X) = Domain R \<inter> X"
  using restrict_def by fastforce

text \<open>A subrelation of a right-unique relation is right-unique.\<close>

lemma subrel_runiq:
  assumes "runiq Q" "P \<subseteq> Q"
  shows "runiq P"
  using assms runiq_def by (metis Image_mono subsetI trivial_subset)

lemma rightUniqueInjectiveOnFirstImplication:
  assumes "runiq P"
  shows "inj_on fst P"
  unfolding inj_on_def
  using assms runiq_def trivial_def trivial_imp_no_distinct
        the_elem_eq surjective_pairing subsetI Image_singleton_iff
  by (metis(no_types))

text \<open>alternative characterization of right-uniqueness: the image of a singleton set is
   @{const trivial}, i.e.\ an empty or a singleton set.\<close>
lemma runiq_alt: "runiq R \<longleftrightarrow> (\<forall> x . trivial (R `` {x}))"
  unfolding runiq_def by (metis Image_empty2 trivial_empty_or_singleton trivial_singleton)

text \<open>an alternative definition of right-uniqueness in terms of @{const eval_rel}\<close>
(* Note that R `` {x} is the image of {x} under R and R ,, x gives you an element y such that R x y. Because of right-uniqueness in this case the element is determined, otherwise it may be undetermined *)
lemma runiq_wrt_eval_rel: "runiq R = (\<forall>x . R `` {x} \<subseteq> {R ,, x})"
  by (metis eval_rel.simps runiq_alt trivial_def)

lemma rightUniquePair:
  assumes "runiq f"
  assumes "(x,y)\<in>f"
  shows "y=f,,x"
  using assms runiq_wrt_eval_rel subset_singletonD Image_singleton_iff equals0D singletonE
  by fast

lemma runiq_basic: "runiq R \<longleftrightarrow> (\<forall> x y y' . (x, y) \<in> R \<and> (x, y') \<in> R \<longrightarrow> y = y')"
  unfolding runiq_alt trivial_same by blast

lemma rightUniqueFunctionAfterInverse:
  assumes "runiq f"
  shows "f``(f^-1``Y) \<subseteq> Y"
  using assms runiq_basic ImageE converse_iff subsetI by (metis(no_types))

lemma lm04:
  assumes "runiq f" "y1 \<in> Range f"
  shows "(f^-1 `` {y1} \<inter> f^-1 `` {y2} \<noteq> {}) = (f^-1``{y1}=f^-1``{y2})"
  using assms rightUniqueFunctionAfterInverse by fast

lemma converse_Image:
  assumes runiq: "runiq R"
      and runiq_conv: "runiq (R^-1)"
  shows "(R^-1) `` R `` X \<subseteq> X"
  using assms by (metis converse_converse rightUniqueFunctionAfterInverse)

lemma lm05:
  assumes "inj_on fst P"
  shows "runiq P"
  unfolding runiq_basic
  using assms fst_conv inj_on_def old.prod.inject
  by (metis(no_types))

(* Another characterization of runiq, relating the set theoretical expression P to the injectivity of the function fst applied to P *)
lemma rightUniqueInjectiveOnFirst: "(runiq P) = (inj_on fst P)"
  using rightUniqueInjectiveOnFirstImplication lm05 by blast

lemma disj_Un_runiq:
  assumes "runiq P" "runiq Q" "(Domain P) \<inter> (Domain Q) = {}"
  shows "runiq (P \<union> Q)"
  using assms rightUniqueInjectiveOnFirst fst_eq_Domain injection_union by metis

lemma runiq_paste1:
  assumes "runiq Q" "runiq (P outside Domain Q)"
  shows "runiq (P +* Q)"
  unfolding paste_def
  using assms disj_Un_runiq Diff_disjoint Un_commute outside_reduces_domain
  by (metis (poly_guards_query))

corollary runiq_paste2:
  assumes "runiq Q" "runiq P"
  shows "runiq (P +* Q)"
  using assms runiq_paste1 subrel_runiq Diff_subset Outside_def
  by (metis)

(* Let f be a function, then its graph {(x, f x)} and all its restrictions such that P x for arbitrary P are right-unique. *)
lemma rightUniqueRestrictedGraph: "runiq {(x,f x)| x. P x}"
  unfolding runiq_basic by fast

lemma rightUniqueSetCardinality:
  assumes "x \<in> Domain R" "runiq R"
  shows "card (R``{x})=1"
  using assms  lm02 DomainE Image_singleton_iff empty_iff
  by (metis runiq_alt)

text \<open>The image of a singleton set under a right-unique relation is a singleton set.\<close>
lemma Image_runiq_eq_eval:
  assumes "x \<in> Domain R" "runiq R"
  shows "R `` {x} = {R ,, x}"
  using assms rightUniqueSetCardinality
  by (metis eval_rel.simps cardinalityOneTheElemIdentity)

lemma lm06:
  assumes "trivial f"
  shows "runiq f"
  using assms trivial_subset_non_empty runiq_basic snd_conv
  by fastforce

text \<open>A singleton relation is right-unique.\<close>
corollary runiq_singleton_rel: "runiq {(x, y)}"
  using trivial_singleton lm06 by fast

text \<open>The empty relation is right-unique\<close>
lemma runiq_emptyrel: "runiq {}"
  using trivial_empty lm06 by blast

(* characterization of right-uniqueness with  \<exists>! *)
lemma runiq_wrt_ex1:
  "runiq R \<longleftrightarrow> (\<forall> a \<in> Domain R . \<exists>! b . (a, b) \<in> R)"
  using runiq_basic by (metis Domain.DomainI Domain.cases)

text \<open>alternative characterization of the fact that, if a relation @{term R} is right-unique,
  its evaluation @{term "R,,x"} on some argument @{term x} in its domain, occurs in @{term R}'s
  range. Note that we need runiq R in order to get a definite value for @{term "R,,x"}\<close>
lemma eval_runiq_rel:
  assumes domain: "x \<in> Domain R"
      and runiq: "runiq R"
  shows "(x, R,,x) \<in> R"
  using assms by (metis rightUniquePair runiq_wrt_ex1)

text \<open>Evaluating a right-unique relation as a function on the relation's domain yields an
  element from its range.\<close>
lemma eval_runiq_in_Range:
  assumes "runiq R"
      and "a \<in> Domain R"
  shows "R ,, a \<in> Range R"
  using assms by (metis Range_iff eval_runiq_rel)

subsection \<open>Converse\<close>

text \<open>The inverse image of the image of a singleton set under some relation is the same
  singleton set, if both the relation and its converse are right-unique and the singleton set
  is in the relation's domain.\<close>
lemma converse_Image_singleton_Domain:
  assumes runiq: "runiq R"
      and runiq_conv: "runiq (R\<inverse>)"
      and domain: "x \<in> Domain R"
  shows "R\<inverse> `` R `` {x} = {x}"
proof -
  have sup: "{x} \<subseteq> R\<inverse> `` R `` {x}" using domain by fast
  have "trivial (R `` {x})" using runiq domain by (metis runiq_def trivial_singleton)
  then have "trivial (R\<inverse> `` R `` {x})"
    using assms runiq_def by blast
  then show ?thesis
    using sup by (metis singleton_sub_trivial_uniq subset_antisym trivial_def)
qed

text \<open>The images of two disjoint sets under an injective function are disjoint.\<close>

lemma disj_Domain_imp_disj_Image:
  assumes "Domain R \<inter> X \<inter> Y = {}"
  assumes "runiq R"
      and "runiq (R\<inverse>)"
  shows "(R `` X) \<inter> (R `` Y) = {}"
  using assms unfolding runiq_basic by blast

lemma runiq_converse_paste_singleton:
  assumes "runiq (P^-1)" "y\<notin>(Range P)"
  shows "runiq ((P +* {(x,y)})\<inverse>)"
  (is "?u (?P^-1)")
proof -
  have "(?P) \<subseteq> P \<union> {(x,y)}" using assms by (metis paste_sub_Un)
  then have "?P^-1 \<subseteq> P^-1 \<union> ({(x,y)}^-1)" by blast
  moreover have "... = P^-1 \<union> {(y,x)}" by fast
  moreover have "Domain (P^-1) \<inter> Domain {(y,x)} = {}" using assms(2) by auto
  ultimately moreover have "?u (P^-1 \<union> {(y,x)})" using assms(1) by (metis disj_Un_runiq runiq_singleton_rel)
  ultimately show ?thesis by (metis subrel_runiq)
qed

subsection \<open>Injectivity\<close>

text \<open>The following is a classical definition of the set of all injective functions from @{term X} to @{term Y}.\<close>
definition injections :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set set"
  where "injections X Y = {R . Domain R = X \<and> Range R \<subseteq> Y \<and> runiq R \<and> runiq (R\<inverse>)}"

text \<open>The following definition is a constructive (computational) characterization of the set of all injections X Y, represented by a list. That is, we define the list of all injective functions (represented as relations) from one set (represented as a list) to another set. We formally prove the equivalence of the constructive and the classical definition in Universes.thy.\<close>
fun injections_alg (* :: "'a list \<Rightarrow> 'b::linorder set \<Rightarrow> ('a \<times> 'b) set list" *)
  where "injections_alg [] Y = [{}]" |
        "injections_alg (x # xs) Y = concat [ [ R +* {(x,y)} . y \<leftarrow> sorted_list_of_set (Y - Range R) ]
       . R \<leftarrow> injections_alg xs Y ]"
(* We need this as a list in order to be able to iterate over it.  It would be easy to provide
   an alternative of type ('a \<times> 'b) set set, by using \<Union> and set comprehension. *)

lemma Image_within_domain':
  fixes x R
  shows "(x \<in> Domain R) = (R `` {x} \<noteq> {})"
  by blast

end


theory P24 imports Main begin

primrec insort :: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
"insort x Nil = [x]" |
"insort x (y # ys) = (if (x < y) then ([x, y] @ ys) else (y # (insort x ys)))"

primrec sort :: "nat list \<Rightarrow> nat list" where
"sort Nil = Nil" |
"sort (x # xs) = (insort x (sort xs))"

primrec le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
"le n Nil = True" |
"le n (x # xs) = ((n \<le> x) \<and> (le n xs))"

primrec sorted :: "nat list \<Rightarrow> bool" where
"sorted Nil = True" |
"sorted (x # xs) = (if xs = Nil then True else ((x \<le> hd xs) \<and> sorted xs))"

lemma [simp]: "P24.sorted xs \<Longrightarrow> P24.sorted (P24.insort a xs)"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
  proof (cases xs)
    case Nil
  then show ?thesis by simp
  next
    case (Cons y ys)
    then show ?thesis
      using Cons.hyps Cons.prems by auto
  qed
qed

theorem "sorted (sort xs)"
  apply (induct xs)
   apply auto
  done

fun count :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
"count xs n = length (filter (\<lambda>x. x=n) xs)"

lemma [simp]: "count (a # xs) x = (count xs x) + (if (x=a) then 1 else 0)"
  apply (induct xs)
   apply auto
  done

lemma insort_length[simp]: "count (insort a xs) x = (count xs x) + (if (x=a) then 1 else 0)"
  apply (induct xs arbitrary: a x)
   apply auto
  done

theorem "count (sort xs) x = count xs x"
proof (induct xs arbitrary: x)
case Nil
then show ?case by simp
next
  case (Cons a xs)
  then show ?case
  proof (cases "x=a")
    case True
    print_facts
    have "count (sort (a # xs)) x = (count (sort xs) x + 1)"
      using True insort_length by auto
    also have "\<dots> = (count xs x + 1)" using Cons.hyps by auto
    finally have 1: "count (P24.sort (a # xs)) x =(count xs x + 1)" by blast
    have "count (a # xs) x = (count xs x + 1)" using True by simp
    then show ?thesis using 1 by auto
  next
    case False
    have "count (sort (a # xs)) x = count (insort a (sort xs)) x" by simp
    also have "\<dots> = count (sort xs) x" using False insort_length by auto
    also have "\<dots> = count xs x" using Cons.hyps by simp
    finally have 1: "count (sort (a # xs)) x = count xs x" by blast
    have "count (a # xs) x = count xs x" using False by simp
    then show ?thesis using 1 by auto
  qed
qed

end


theory Ex029
  imports Main
begin

(*since implication has right associativity this is the same as (A \<longrightarrow> B) \<longrightarrow> (C \<longrightarrow> \<not>B) \<longrightarrow> A \<longrightarrow> \<not>C*)
lemma "(A \<longrightarrow> B) \<longrightarrow> (C \<longrightarrow> \<not>B) \<longrightarrow> (A \<longrightarrow> \<not>C)"
proof -
  {
    assume a:"A \<longrightarrow> B"
    {
      assume b:"C \<longrightarrow> \<not>B"
      {
        assume A
        with a have c:B by (rule mp)
        {
          assume C
          with b have "\<not>B" by (rule mp)
          with c have False by contradiction
        }
        hence "\<not>C" by (rule notI)
      }
      hence "A \<longrightarrow> \<not>C" by (rule impI)
    }
    hence "(C \<longrightarrow> \<not>B) \<longrightarrow> A \<longrightarrow> \<not>C" by (rule impI)
  }
  thus ?thesis by (rule impI)
qed


theory Indices
imports Main
begin

(**************************************************************************************************)
(**************************************************************************************************)
section\<open>Basic Lemmas for Manipulating Indices and Lists\<close>
(**************************************************************************************************)
(**************************************************************************************************)
fun index_list where
"index_list 0 = []"|
"index_list (Suc n) = index_list n @ [n]"

lemma index_list_length:
"length (index_list n) = n"
  by(induction n, simp, auto )

lemma index_list_indices:
"k < n \<Longrightarrow> (index_list n)!k = k"
  apply(induction n)
  apply (simp; fail)
  by (simp add: index_list_length nth_append)

lemma index_list_set:
"set (index_list n) = {..<n}"
  apply(induction n)
  apply force
  by (metis Zero_not_Suc atLeastLessThan_empty atLeastLessThan_singleton atLeastLessThan_upt
      diff_Suc_1 index_list.elims ivl_disj_un_singleton(2) lessI lessThan_Suc_atMost less_Suc_eq_le
      set_append sorted_list_of_set_empty sorted_list_of_set_range upt_rec)

fun flat_map :: "('a => 'b list) => 'a list => 'b list" where
  "flat_map f [] = []"
 |"flat_map f (h#t) = (f h)@(flat_map f t)"

abbreviation(input) project_at_indices ("\<pi>\<^bsub>_\<^esub>") where
"project_at_indices S as \<equiv> nths as S"

fun insert_at_index :: " 'a list \<Rightarrow>'a \<Rightarrow> nat \<Rightarrow> 'a list" where
"insert_at_index as a n= (take n as) @ (a#(drop n as))"

lemma insert_at_index_length:
  shows "length (insert_at_index as a n) = length as + 1"
  by(induction n, auto)

lemma insert_at_index_eq[simp]:
  assumes "n \<le> length as"
  shows "(insert_at_index as a n)!n = a"
  by (metis assms insert_at_index.elims length_take min.absorb2 nth_append_length)

lemma insert_at_index_eq'[simp]:
  assumes "n \<le> length as"
  assumes "k < n"
  shows "(insert_at_index as a n)!k = as ! k"
  using assms
  by (simp add: nth_append)

lemma insert_at_index_eq''[simp]:
  assumes "n < length as"
  assumes "k \<le> n"
  shows "(insert_at_index as a k)!(Suc n) = as ! n"
  using assms insert_at_index.simps[of as a k]
  by (smt Suc_diff_Suc append_take_drop_id diff_Suc_Suc dual_order.order_iff_strict
      le_imp_less_Suc length_take less_trans min.absorb2 not_le nth_Cons_Suc nth_append)

text\<open>Correctness of project\_at\_indices\<close>

definition indices_of :: "'a list \<Rightarrow> nat set" where
"indices_of as = {..<(length as)}"

lemma proj_at_index_list_length[simp]:
  assumes "S \<subseteq> indices_of as"
  shows "length (project_at_indices S as) = card S"
proof-
  have "S = {i. i < length as \<and> i \<in> S}"
    using assms unfolding indices_of_def
    by blast
  thus ?thesis
  using length_nths[of as S] by auto
qed

text\<open>A function which enumerates finite sets\<close>

abbreviation(input) set_to_list :: "nat set \<Rightarrow>  nat list" where
"set_to_list S \<equiv> sorted_list_of_set S"

lemma set_to_list_set:
  assumes "finite S"
  shows "set (set_to_list S) = S"
  by (simp add: assms)

lemma set_to_list_length:
  assumes "finite S"
  shows "length (set_to_list S) = card S"
  by (metis assms length_remdups_card_conv length_sort set_sorted_list_of_set sorted_list_of_set_sort_remdups)

lemma set_to_list_empty:
  assumes "card S = 0"
  shows "set_to_list S = []"
  by (metis assms length_0_conv length_sorted_list_of_set)

lemma set_to_list_first:
  assumes "card S > 0"
  shows "Min S = set_to_list S ! 0 "
proof-
  have 0: "set (set_to_list S) = S"
    using assms card_ge_0_finite set_sorted_list_of_set by blast
  have 1: "sorted (set_to_list S)"
    by simp
  show ?thesis apply(rule Min_eqI)
    using assms card_ge_0_finite apply blast
     apply (metis "0" "1" in_set_conv_nth less_Suc0 less_or_eq_imp_le not_less_eq sorted_iff_nth_mono_less)
      by (metis "0" Max_in assms card_0_eq card_ge_0_finite gr_zeroI in_set_conv_nth not_less0)
qed

lemma set_to_list_last:
  assumes "card S > 0"
  shows "Max S = last (set_to_list S)"
proof-
  have 0: "set (set_to_list S) = S"
    using assms card_ge_0_finite set_sorted_list_of_set by blast
  have 1: "sorted (set_to_list S)"
    by simp
  show ?thesis apply(rule Max_eqI)
    using assms card_ge_0_finite apply blast
     apply (smt "0" "1" Suc_diff_1 in_set_conv_nth last_conv_nth le_simps(2) length_greater_0_conv
        less_or_eq_imp_le nat_neq_iff neq0_conv not_less_eq sorted_iff_nth_mono_less)
      by (metis "0" assms card.empty empty_set last_in_set less_numeral_extra(3))
qed

lemma set_to_list_insert_Max:
  assumes "finite S"
  assumes "\<And>s. s \<in> S \<Longrightarrow> a > s"
  shows "set_to_list (insert a S) = set_to_list S @[a]"
  by (metis assms(1) assms(2) card_0_eq card_insert_if finite.insertI infinite_growing
      insert_not_empty less_imp_le_nat sorted_insort_is_snoc sorted_list_of_set(1) sorted_list_of_set(2)
      sorted_list_of_set_insert)

lemma set_to_list_insert_Min:
  assumes "finite S"
  assumes "\<And>s. s \<in> S \<Longrightarrow> a < s"
  shows "set_to_list (insert a S) = a#set_to_list S"
  by (metis assms(1) assms(2) insort_is_Cons nat_less_le sorted_list_of_set(1) sorted_list_of_set_insert)

fun nth_elem where
"nth_elem S n = set_to_list S ! n"

lemma nth_elem_closed:
  assumes "i < card S"
  shows "nth_elem S i \<in> S"
  by (metis assms card.infinite not_less0 nth_elem.elims nth_mem set_to_list_length sorted_list_of_set(1))

lemma nth_elem_Min:
  assumes "card S > 0"
  shows "nth_elem S 0 = Min S"
  by (simp add: assms  set_to_list_first)

lemma nth_elem_Max:
  assumes "card S > 0"
  shows "nth_elem S (card S - 1) = Max S"
proof-
  have "last (set_to_list S) = set_to_list S ! (card S - 1)"
    by (metis assms card_0_eq card_ge_0_finite last_conv_nth neq0_conv set_to_list_length sorted_list_of_set_eq_Nil_iff)
  thus ?thesis
    using assms set_to_list_last set_to_list_length
    by simp
qed

lemma nth_elem_Suc:
  assumes "card S > Suc n"
  shows "nth_elem S (Suc n) > nth_elem S n"
  using assms sorted_sorted_list_of_set[of S] set_to_list_length[of S]
  by (metis Suc_lessD card.infinite distinct_sorted_list_of_set lessI nat_less_le not_less0 nth_elem.elims nth_eq_iff_index_eq sorted_iff_nth_mono_less)

lemma nth_elem_insert_Min:
  assumes "card S > 0"
  assumes "a < Min S"
  shows "nth_elem (insert a S) (Suc i) = nth_elem S i"
  using assms
  by (metis Min_gr_iff card_0_eq card_ge_0_finite neq0_conv nth_Cons_Suc nth_elem.elims set_to_list_insert_Min)

lemma set_to_list_Suc_map:
  assumes "finite S"
  shows "set_to_list (Suc ` S) = map Suc (set_to_list S)"
proof-
  obtain n where n_def: "n = card S"
    by blast
  have "\<And>S. card S = n \<Longrightarrow> set_to_list (Suc ` S) = map Suc (set_to_list S)"
  proof(induction n)
    case 0
    then show ?case
      by (metis card_eq_0_iff finite_imageD image_is_empty inj_Suc list.simps(8) set_to_list_empty)
  next
    case (Suc n)
    have 0: "S = insert (Min S) (S - {Min S})"
      by (metis Min_in Suc.prems card_gt_0_iff insert_Diff zero_less_Suc)
    have 1: "sorted_list_of_set (Suc ` (S - {Min S})) = map Suc (sorted_list_of_set (S - {Min S}))"
      by (metis "0" Suc.IH Suc.prems card_Diff_singleton card.infinite diff_Suc_1 insertI1 nat.simps(3))
    have 2: "set_to_list S = (Min S)#(set_to_list (S - {Min S}))"
      by (metis "0" DiffD1 Min_le Suc.prems card_Diff_singleton card.infinite card_insert_if
          diff_Suc_1 finite_Diff n_not_Suc_n nat.simps(3) nat_less_le set_to_list_insert_Min)
    have 3: "sorted_list_of_set (Suc ` S) = (Min (Suc ` S))#(set_to_list ((Suc ` S) - {Min (Suc ` S)}))"
      by (metis DiffD1 Diff_idemp Min_in Min_le Suc.prems card_Diff1_less card_eq_0_iff finite_Diff
          finite_imageI image_is_empty insert_Diff nat.simps(3) nat_less_le set_to_list_insert_Min)
    have 4: "(Min (Suc ` S)) = Suc (Min S)"
      by (metis Min.hom_commute Suc.prems Suc_le_mono card_eq_0_iff min_def nat.simps(3))
    have 5: "sorted_list_of_set (Suc ` S) = Suc (Min S)#(set_to_list ((Suc ` S) - {Suc (Min S)}))"
      using 3 4 by auto
    have 6: "sorted_list_of_set (Suc ` S) = Suc (Min S)#(set_to_list (Suc ` (S - {Min S})))"
      by (metis (no_types, lifting) "0" "5" Diff_insert_absorb image_insert inj_Suc inj_on_insert)
    show ?case
      using 6
      by (simp add: "1" "2")
  qed
  thus ?thesis
    using n_def by blast
qed

lemma nth_elem_Suc_im:
  assumes "i < card S"
  shows "nth_elem (Suc ` S) i = Suc (nth_elem S i) "
  using set_to_list_Suc_map
  by (metis assms card_ge_0_finite dual_order.strict_trans not_gr0 nth_elem.elims nth_map set_to_list_length)

lemma set_to_list_upto:
"set_to_list {..<n} = [0..<n]"
  by (simp add: lessThan_atLeast0)

lemma nth_elem_upto:
  assumes "i < n"
  shows "nth_elem {..<n} i = i"
  using set_to_list_upto
  by (simp add: assms)

text\<open>Characterizing the entries of project\_at\_indices \<close>

lemma project_at_indices_append:
"project_at_indices S (as@bs) = project_at_indices S as @ project_at_indices {j. j + length as \<in> S} bs"
  using nths_append[of as bs S] by auto

lemma project_at_indices_nth:
  assumes "S \<subseteq> indices_of as"
  assumes "card S > i"
  shows "project_at_indices S as ! i = as ! (nth_elem S i)"
proof-
  have "\<And> S i. S \<subseteq> indices_of as \<and> card S > i \<Longrightarrow> project_at_indices S as ! i = as ! (nth_elem S i)"
  proof(induction as)
    case Nil
    then show ?case
      by (metis list.size(3) not_less0 nths_nil proj_at_index_list_length)
  next
    case (Cons a as)
    assume A: "S \<subseteq> indices_of (a # as) \<and> i < card S"
    have 0: "nths (a # as) S = (if 0 \<in> S then [a] else []) @ nths as {j. Suc j \<in> S}"
      using nths_Cons[of a as S] by simp
    show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
    proof(cases "0 \<in> S")
      case True
      show ?thesis
      proof(cases "S = {0}")
        case True
        then show ?thesis
          using "0" Cons.prems  by auto
      next
        case False
        have T0: "nths (a # as) S = a#nths as {j. Suc j \<in> S}"
          using 0
          by (simp add: True)
        have T1: "{j. Suc j \<in> S} \<subseteq> indices_of as"
        proof fix x assume A: "x \<in> {j. Suc j \<in> S}"
          then have "Suc x < length (a#as)"
          using Cons.prems indices_of_def by blast
         then show "x \<in> indices_of as"
          by (simp add: indices_of_def)
        qed
        have T2: "\<And>i.  i < card {j. Suc j \<in> S} \<Longrightarrow> nths as {j. Suc j \<in> S} ! i = as ! nth_elem {j. Suc j \<in> S} i"
          using Cons.IH T1 by blast
        have T3: "\<And>i.  i < card {j. Suc j \<in> S} \<Longrightarrow> nth_elem {j. j > 0 \<and> j\<in> S} i = nth_elem S (Suc i)"
        proof-
          have 0: " 0 < card {j. Suc j \<in> S}"
            by (smt Cons.prems Diff_iff Diff_subset False T0 T1 True add_diff_cancel_left'
                card.insert card_0_eq card.infinite finite_subset gr_zeroI insert_Diff
                length_Cons n_not_Suc_n plus_1_eq_Suc proj_at_index_list_length singletonI)
          have 1: "(insert 0 {j. 0 < j \<and> j \<in> S}) = S"
            apply(rule set_eqI) using True  gr0I by blast
          have 2: "0 < Min {j. 0 < j \<and> j \<in> S}" using False
            by (metis (mono_tags, lifting) "1" Cons.prems Min_in finite_insert finite_lessThan
                finite_subset indices_of_def less_Suc_eq less_Suc_eq_0_disj mem_Collect_eq singleton_conv)
          show "\<And>i. i < card {j. Suc j \<in> S} \<Longrightarrow> nth_elem {j. 0 < j \<and> j \<in> S} i = nth_elem S (Suc i)"
            using 0 1 2 nth_elem_insert_Min[of "{j. 0 < j \<and> j \<in> S}" 0] True False
            by (metis (no_types, lifting) Cons.prems T0 T1 card_gt_0_iff finite_insert length_Cons less_SucI proj_at_index_list_length)
        qed
        show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
          apply(cases "i = 0")
           apply (metis Cons.prems Min_le T0 True card_ge_0_finite le_zero_eq nth_Cons' nth_elem_Min)
        proof-
          assume "i \<noteq> 0"
          then have "i = Suc (i - 1)"
            using Suc_pred' by blast
          hence "nths (a # as) S ! i = nths as {j. Suc j \<in> S} ! (i-1)"
            using A by (simp add: T0)
          thus "nths (a # as) S ! i = (a # as) ! nth_elem S i"
          proof-
            have "i - 1 < card {j. Suc j \<in> S}"
              by (metis Cons.prems Suc_less_SucD T0 T1 \<open>i = Suc (i - 1)\<close> length_Cons proj_at_index_list_length)
            hence 0: "nth_elem {j. 0 < j \<and> j \<in> S} (i - 1) = nth_elem S i"
              using T3[of "i-1"] \<open>i = Suc (i - 1)\<close> by auto

            have 1: "nths as {j. Suc j \<in> S} ! (i-1) = as ! nth_elem {j. Suc j \<in> S} (i-1)"
              using T2 \<open>i - 1 < card {j. Suc j \<in> S}\<close> by blast
            have 2: "(a # as) ! nth_elem S i = as! ((nth_elem S i) - 1)"
              by (metis Cons.prems \<open>i = Suc (i - 1)\<close> not_less0 nth_Cons' nth_elem_Suc)
            have 3: "(nth_elem S i) - 1 = nth_elem {j. Suc j \<in> S} (i-1)"
            proof-
              have "Suc ` {j. Suc j \<in> S} = {j. 0 < j \<and> j \<in> S}"
              proof
                show "Suc ` {j. Suc j \<in> S} \<subseteq> {j. 0 < j \<and> j \<in> S}"
                  by blast
                show "{j. 0 < j \<and> j \<in> S} \<subseteq> Suc ` {j. Suc j \<in> S}"
                  using Suc_pred gr0_conv_Suc by auto
              qed
              thus ?thesis
                using "0" \<open>i - 1 < card {j. Suc j \<in> S}\<close> nth_elem_Suc_im by fastforce
            qed
            show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
              using "1" "2" "3" \<open>nths (a # as) S ! i = nths as {j. Suc j \<in> S} ! (i - 1)\<close> by auto
          qed
        qed
      qed
    next
      case False
      have F0: "nths (a # as) S = nths as {j. Suc j \<in> S}"
        by (simp add: "0" False)
      have F1: "Suc `{j. Suc j \<in> S} = S"
      proof show "Suc ` {j. Suc j \<in> S} \<subseteq> S" by auto
            show "S \<subseteq> Suc ` {j. Suc j \<in> S}"  using False Suc_pred
                by (smt image_iff mem_Collect_eq neq0_conv subsetI)
      qed
      have F2: "{j. Suc j \<in> S} \<subseteq> indices_of as \<and> i < card {j. Suc j \<in> S}"
        using F1
        by (metis (mono_tags, lifting) A F0 Suc_less_SucD indices_of_def length_Cons lessThan_iff
            mem_Collect_eq proj_at_index_list_length subset_iff)
      have F3: "project_at_indices {j. Suc j \<in> S} as ! i = as ! (nth_elem {j. Suc j \<in> S} i)"
        using F2 Cons(1)[of "{j. Suc j \<in> S}"] Cons(2)
        by blast
      then show ?thesis
        using F0 F1 F2 nth_elem_Suc_im by fastforce
    qed
  qed
  then show ?thesis
    using assms(1) assms(2) by blast
qed

text\<open>An inverse for nth\_elem\<close>

definition set_rank where
"set_rank S x = (THE i. i < card S \<and> x = nth_elem S i)"

lemma set_rank_exist:
  assumes "finite S"
  assumes "x \<in> S"
  shows "\<exists>i. i < card S \<and> x = nth_elem S i"
  using assms nth_elem.simps[of S]
  by (metis in_set_conv_nth set_to_list_length sorted_list_of_set(1))

lemma set_rank_unique:
  assumes "finite S"
  assumes "x \<in> S"
  assumes "i < card S \<and> x = nth_elem S i"
  assumes "j < card S \<and> x = nth_elem S j"
  shows "i = j"
  using assms nth_elem.simps[of S]
  by (simp add: \<open>i < card S \<and> x = nth_elem S i\<close> \<open>j < card S \<and> x = nth_elem S j\<close>
      nth_eq_iff_index_eq set_to_list_length)

lemma nth_elem_set_rank_inv:
  assumes "finite S"
  assumes "x \<in> S"
  shows "nth_elem S (set_rank S x) = x"
  using the_equality  set_rank_unique set_rank_exist assms
  unfolding set_rank_def
  by smt

lemma set_rank_nth_elem_inv:
  assumes "finite S"
  assumes "i < card S"
  shows "set_rank S (nth_elem S i) = i"
  using the_equality  set_rank_unique set_rank_exist assms
  unfolding set_rank_def
proof -
  show "(THE n. n < card S \<and> nth_elem S i = nth_elem S n) = i"
    using assms(1) assms(2) nth_elem_closed set_rank_unique by blast
qed

lemma set_rank_range:
  assumes "finite S"
  assumes "x \<in> S"
  shows "set_rank S x < card S"
  using assms(1) assms(2) set_rank_exist set_rank_nth_elem_inv by fastforce

lemma project_at_indices_nth':
  assumes "S \<subseteq> indices_of as"
  assumes "i \<in> S"
  shows "as ! i = project_at_indices S as ! (set_rank S i) "
  by (metis assms(1) assms(2) finite_lessThan finite_subset indices_of_def nth_elem_set_rank_inv
      project_at_indices_nth set_rank_range)

fun proj_away_from_index :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" ("\<pi>\<^bsub>\<noteq>_\<^esub>")where
"proj_away_from_index n as = (take n as)@(drop (Suc n) as)"

text\<open>proj\_away\_from\_index is an inverse to insert\_at\_index\<close>

lemma insert_at_index_project_away[simp]:
  assumes "k < length as"
  assumes "bs = (insert_at_index as a k)"
  shows "\<pi>\<^bsub>\<noteq> k\<^esub> bs = as"
  using assms insert_at_index.simps[of as a k] proj_away_from_index.simps[of k bs]
  by (simp add: \<open>k < length as\<close> less_imp_le_nat min.absorb2)

definition fibred_cell :: "'a list set \<Rightarrow> ('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list set" where
"fibred_cell C P = {as . \<exists>x t. as = (t#x) \<and> x \<in> C \<and> (P x t)}"

definition fibred_cell_at_ind :: "nat \<Rightarrow> 'a list set \<Rightarrow> ('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list set" where
"fibred_cell_at_ind n C P = {as . \<exists>x t. as = (insert_at_index x t n) \<and> x \<in> C \<and> (P x t)}"

lemma fibred_cell_lengths:
  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
  shows "k \<in> (fibred_cell C P) \<Longrightarrow> length k = Suc n"
proof-
  assume "k \<in> (fibred_cell C P)"
  obtain x t where "k = (t#x) \<and> x \<in> C \<and> P x t"
  proof -
    assume a1: "\<And>t x. k = t # x \<and> x \<in> C \<and> P x t \<Longrightarrow> thesis"
    have "\<exists>as a. k = a # as \<and> as \<in> C \<and> P as a"
      using \<open>k \<in> fibred_cell C P\<close> fibred_cell_def by blast
    then show ?thesis
      using a1 by blast
  qed
  then show ?thesis
    by (simp add: assms)
qed

lemma fibred_cell_at_ind_lengths:
  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
  assumes "k \<le> n"
  shows "c \<in> (fibred_cell_at_ind k C P) \<Longrightarrow> length c = Suc n"
proof-
  assume "c \<in> (fibred_cell_at_ind k C P)"
  then obtain x t where "c = (insert_at_index x t k) \<and> x \<in> C \<and> (P x t)"
    using assms
    unfolding fibred_cell_at_ind_def
    by blast
  then show ?thesis
    by (simp add: assms(1))
qed

lemma project_fibred_cell:
  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
  assumes "k < n"
  assumes "\<forall>x \<in> C. \<exists>t. P x t"
  shows "\<pi>\<^bsub>\<noteq> k\<^esub> ` (fibred_cell_at_ind k C P) = C"
proof
  show "\<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P \<subseteq> C"
  proof
    fix x
    assume x_def: "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
    then obtain c where c_def: "x = \<pi>\<^bsub>\<noteq>k\<^esub> c \<and> c \<in>  fibred_cell_at_ind k C P"
      by blast
    then obtain y t where yt_def: "c = (insert_at_index y t k) \<and> y \<in> C \<and> (P y t)"
      using assms
      unfolding fibred_cell_at_ind_def
      by blast
    have 0: "x =\<pi>\<^bsub>\<noteq>k\<^esub> c"
      by (simp add: c_def)
    have 1: "y =\<pi>\<^bsub>\<noteq>k\<^esub> c"
      using yt_def  assms(1) assms(2)
      by (metis insert_at_index_project_away)
    have 2: "x = y" using 0 1 by auto
    then show "x \<in> C"
      by (simp add: yt_def)
  qed
  show "C \<subseteq> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
  proof fix x
    assume A: "x \<in> C"
    obtain t where t_def: "P x t"
      using assms A by auto
    then show "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
    proof -
      have f1: "\<forall>a n A as. take n as @ (a::'a) # drop n as \<notin> A \<or> as \<in> \<pi>\<^bsub>\<noteq>n\<^esub> ` A \<or> \<not> n < length as"
        by (metis insert_at_index.simps insert_at_index_project_away rev_image_eqI)
      have "\<forall>n. \<exists>as a. take n x @ t # drop n x = insert_at_index as a n \<and> as \<in> C \<and> P as a"
        using A t_def by auto
      then have "\<forall>n. take n x @ t # drop n x \<in> {insert_at_index as a n |as a. as \<in> C \<and> P as a}"
        by blast
      then have "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` {insert_at_index as a k |as a. as \<in> C \<and> P as a}"
        using f1 by (metis (lifting) A assms(1) assms(2))
      then show ?thesis
        by (simp add: fibred_cell_at_ind_def)
    qed
  qed
qed

definition list_segment where
"list_segment i j as = map (nth as)  [i..<j]"

lemma list_segment_length:
  assumes "i \<le> j"
  assumes "j \<le>  length as"
  shows "length (list_segment i j as) = j - i"
  using  assms
  unfolding list_segment_def
  by (metis length_map length_upt)

lemma list_segment_drop:
  assumes "i < length as"
  shows "(list_segment i (length as) as) = drop i  as"
  by (metis One_nat_def Suc_diff_Suc add_diff_inverse_nat drop0  drop_map drop_upt
      less_Suc_eq list_segment_def map_nth neq0_conv not_less0 plus_1_eq_Suc)

lemma list_segment_concat:
  assumes "j \<le> k"
  assumes "i \<le> j"
  shows "(list_segment i j as) @ (list_segment j k as) = (list_segment i k as)"
  using assms   unfolding list_segment_def
  using le_Suc_ex upt_add_eq_append
  by fastforce

lemma list_segment_subset:
  assumes "j \<le> k"
  shows "set (list_segment i j as) \<subseteq> set (list_segment i k as)"
  apply(cases "i > j")
  unfolding list_segment_def
  apply (metis in_set_conv_nth length_map list.size(3) order.asym subsetI upt_rec zero_order(3))
proof-
  assume "\<not> j < i"
  then have "i \<le>j"
    using not_le
    by blast
  then have "list_segment i j as @ list_segment j k as = list_segment i k as"
    using assms list_segment_concat[of j k i as] by auto
  then show "set (map ((!) as) [i..<j]) \<subseteq> set (map ((!) as) [i..<k])"
    using set_append  unfolding list_segment_def
    by (metis Un_upper1)
qed

lemma list_segment_subset_list_set:
  assumes "j \<le> length as"
  shows "set (list_segment i j as) \<subseteq> set as"
  apply(cases "i \<ge> j")
  apply (simp add: list_segment_def)
proof-
  assume A: "\<not> j \<le> i"
  then have B: "i < j"
    by auto
  have 0: "list_segment i (length as) as = drop i as"
    using B assms list_segment_drop[of i as] less_le_trans
    by blast
  have 1: "set (list_segment i j as) \<subseteq> set (list_segment i (length as) as)"
    using B assms list_segment_subset[of j "length as" i as]
    by blast
  then show ?thesis
  using assms 0 dual_order.trans  set_drop_subset[of i as]
    by metis
qed

definition fun_inv where
"fun_inv = inv"

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_bin_nat_plus
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus2 :: "Bin => Bin => Bin" where
"plus2 (One) y = s y"
| "plus2 (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus2 (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus2 z ys)"
| "plus2 (ZeroAnd z) (OneAnd xs) = OneAnd (plus2 z xs)"
| "plus2 (OneAnd x2) (One) = s (OneAnd x2)"
| "plus2 (OneAnd x2) (ZeroAnd zs) = OneAnd (plus2 x2 zs)"
| "plus2 (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus2 x2 ys2))"

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

fun toNat :: "Bin => Nat" where
"toNat (One) = S Z"
| "toNat (ZeroAnd xs) = plus (toNat xs) (toNat xs)"
| "toNat (OneAnd ys) = plus (plus (S Z) (toNat ys)) (toNat ys)"

theorem property0 :
  "((toNat (plus2 x y)) = (plus (toNat x) (toNat y)))"
  oops

end