(*  Title:      AVL Trees
    Author:     Tobias Nipkow and Cornelia Pusch,
                converted to Isar by Gerwin Klein
                contributions by Achim Brucker, Burkhart Wolff and Jan Smaus
                delete formalization and a transformation to Isar by Ondrej Kuncar
    Maintainer: Gerwin Klein <gerwin.klein at nicta.com.au>

    see the file Changelog for a list of changes
*)

section "AVL Trees"

theory AVL
imports Main
begin

text \<open>
  This is a monolithic formalization of AVL trees.
\<close>

subsection \<open>AVL tree type definition\<close>

datatype (set_of: 'a) tree = ET |  MKT 'a "'a tree" "'a tree" nat

subsection \<open>Invariants and auxiliary functions\<close>

primrec height :: "'a tree \<Rightarrow> nat" where
"height ET = 0" |
"height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree \<Rightarrow> bool" where
"avl ET = True" |
"avl (MKT x l r h) =
 ((height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

primrec is_ord :: "('a::order) tree \<Rightarrow> bool" where
"is_ord ET = True" |
"is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

subsection \<open>AVL interface and implementation\<close>

primrec is_in :: "('a::order) \<Rightarrow> 'a tree \<Rightarrow> bool" where
 "is_in k ET = False" |
 "is_in k (MKT n l r h) = (if k = n then True else
                           if k < n then (is_in k l)
                           else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat" where
"ht ET = 0" |
"ht (MKT x l r h) = h"

definition
 mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

fun mkt_bal_l where
"mkt_bal_l n l r = (
  if ht l = ht r + 2 then (case l of
    MKT ln ll lr _ \<Rightarrow> (if ht ll < ht lr
    then case lr of
      MKT lrn lrl lrr _ \<Rightarrow> mkt lrn (mkt ln ll lrl) (mkt n lrr r)
    else mkt ln ll (mkt n lr r)))
  else mkt n l r
)"

fun mkt_bal_r where
"mkt_bal_r n l r = (
  if ht r = ht l + 2 then (case r of
    MKT rn rl rr _ \<Rightarrow> (if ht rl > ht rr
    then case rl of
      MKT rln rll rlr _ \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
    else mkt rn (mkt n l rl) rr))
  else mkt n l r
)"

primrec insert :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x ET = MKT x ET ET 1" |
"insert x (MKT n l r h) =
   (if x=n
    then MKT n l r h
    else if x<n
      then mkt_bal_l n (insert x l) r
      else mkt_bal_r n l (insert x r))"

fun delete_max where
"delete_max (MKT n l ET h) = (n,l)" |
"delete_max (MKT n l r h) = (
  let (n',r') = delete_max r in
  (n',mkt_bal_l n l r'))"

lemmas delete_max_induct = delete_max.induct[case_names ET MKT]

fun delete_root where
"delete_root (MKT n ET r h) = r" |
"delete_root (MKT n l ET h) = l" |
"delete_root (MKT n l r h) =
  (let (new_n, l') = delete_max l in
      mkt_bal_r new_n l' r
  )"

lemmas delete_root_cases = delete_root.cases[case_names ET_t MKT_ET MKT_MKT]

primrec delete :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete _ ET = ET" |
"delete x (MKT n l r h) = (
   if x = n then delete_root (MKT n l r h)
   else if x < n then
        let l' = delete x l in
        mkt_bal_r n l' r
   else
        let r' = delete x r in
        mkt_bal_l n l r'
   )"

subsection \<open>Correctness proof\<close>

subsubsection \<open>Insertion maintains AVL balance\<close>

declare Let_def [simp]

lemma height_mkt_bal_l:
  "\<lbrakk> height l = height r + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (mkt_bal_l n l r) = height r + 2 \<or>
   height (mkt_bal_l n l r) = height r + 3"
by (cases l) (auto simp:mkt_def split:tree.split)

lemma height_mkt_bal_r:
  "\<lbrakk> height r = height l + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (mkt_bal_r n l r) = height l + 2 \<or>
   height (mkt_bal_r n l r) = height l + 3"
by (cases r) (auto simp add:mkt_def split:tree.split)

lemma [simp]: "height(mkt x l r) = max (height l) (height r) + 1"
by (simp add: mkt_def)

lemma avl_mkt:
  "\<lbrakk> avl l; avl r;
     height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1
   \<rbrakk> \<Longrightarrow> avl(mkt x l r)"
by (auto simp add:max_def mkt_def)

lemma height_mkt_bal_l2:
  "\<lbrakk> avl l; avl r; height l \<noteq> height r + 2 \<rbrakk> \<Longrightarrow>
   height (mkt_bal_l n l r) = (1 + max (height l) (height r))"
by (cases l, cases r) simp_all

lemma height_mkt_bal_r2:
  "\<lbrakk> avl l;  avl r;  height r \<noteq> height l + 2 \<rbrakk> \<Longrightarrow>
   height (mkt_bal_r n l r) = (1 + max (height l) (height r))"
by (cases l, cases r) simp_all

lemma avl_mkt_bal_l:
  assumes "avl l" "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height l = height r + 2"
  shows "avl(mkt_bal_l n l r)"
proof(cases l)
  case ET
  with assms show ?thesis by (simp add: mkt_def)
next
  case (MKT ln ll lr lh)
  with assms show ?thesis
  proof(cases "height l = height r + 2")
    case True
      from True MKT assms show ?thesis by (auto intro!: avl_mkt split: tree.split) arith+
  next
    case False
      with assms show ?thesis by (simp add: avl_mkt)
  qed
qed

lemma avl_mkt_bal_r:
  assumes "avl l" and "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height r = height l + 2"
  shows "avl(mkt_bal_r n l r)"
proof(cases r)
  case ET
  with assms show ?thesis by (simp add: mkt_def)
next
  case (MKT rn rl rr rh)
  with assms show ?thesis
  proof(cases "height r = height l + 2")
    case True
      from True MKT assms show ?thesis by (auto intro!: avl_mkt split: tree.split) arith+
  next
    case False
      with assms show ?thesis by (simp add: avl_mkt)
  qed
qed

(* It apppears that these two properties need to be proved simultaneously: *)

text\<open>Insertion maintains the AVL property:\<close>

theorem avl_insert_aux:
  assumes "avl t"
  shows "avl(insert x t)"
        "(height (insert x t) = height t \<or> height (insert x t) = height t + 1)"
using assms
proof (induction t)
  case (MKT n l r h)
  case 1
  with MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
    proof(cases "x<n")
      case True
      with MKT 1 show ?thesis by (auto simp add:avl_mkt_bal_l simp del:mkt_bal_l.simps)
    next
      case False
      with MKT 1 \<open>x\<noteq>n\<close> show ?thesis by (auto simp add:avl_mkt_bal_r simp del:mkt_bal_r.simps)
    qed
  qed
  case 2
  from 2 MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
     proof(cases "x<n")
      case True
      with MKT 2 show ?thesis
      proof(cases "height (AVL.insert x l) = height r + 2")
        case False with MKT 2 \<open>x < n\<close> show ?thesis by (auto simp del: mkt_bal_l.simps simp: height_mkt_bal_l2)
      next
        case True
        then consider (a) "height (mkt_bal_l n (AVL.insert x l) r) = height r + 2"
          | (b) "height (mkt_bal_l n (AVL.insert x l) r) = height r + 3"
          using MKT 2 by (atomize_elim, intro height_mkt_bal_l) simp_all
        then show ?thesis
        proof cases
          case a
          with 2 \<open>x < n\<close> show ?thesis by (auto simp del: mkt_bal_l.simps)
        next
          case b
          with True 1 MKT(2) \<open>x < n\<close> show ?thesis by (simp del: mkt_bal_l.simps) arith
        qed
      qed
    next
      case False
      with MKT 2 show ?thesis
      proof(cases "height (AVL.insert x r) = height l + 2")
        case False with MKT 2 \<open>\<not>x < n\<close> show ?thesis by (auto simp del: mkt_bal_r.simps simp: height_mkt_bal_r2)
      next
        case True
        then consider (a) "height (mkt_bal_r n l (AVL.insert x r)) = height l + 2"
          | (b) "height (mkt_bal_r n l (AVL.insert x r)) = height l + 3"
          using MKT 2 by (atomize_elim, intro height_mkt_bal_r) simp_all
        then show ?thesis
        proof cases
          case a
          with 2 \<open>\<not>x < n\<close> show ?thesis by (auto simp del: mkt_bal_r.simps)
        next
          case b
          with True 1 MKT(4) \<open>\<not>x < n\<close> show ?thesis by (simp del: mkt_bal_r.simps) arith
        qed
      qed
    qed
  qed
qed simp_all

lemmas avl_insert = avl_insert_aux(1)

subsubsection \<open>Deletion maintains AVL balance\<close>

lemma avl_delete_max:
  assumes "avl x" and "x \<noteq> ET"
  shows "avl (snd (delete_max x))" "height x = height(snd (delete_max x)) \<or>
         height x = height(snd (delete_max x)) + 1"
using assms
proof (induct x rule: delete_max_induct)
  case (MKT n l rn rl rr rh h)
  case 1
  with MKT have "avl l" "avl (snd (delete_max (MKT rn rl rr rh)))" by auto
  with 1 MKT have "avl (mkt_bal_l n l (snd (delete_max (MKT rn rl rr rh))))"
    by (intro avl_mkt_bal_l) fastforce+
  then show ?case
    by (auto simp: height_mkt_bal_l height_mkt_bal_l2
      linorder_class.max.absorb1 linorder_class.max.absorb2
      split:prod.split simp del:mkt_bal_l.simps)
next
  case (MKT n l rn rl rr rh h)
  case 2
  let ?r = "MKT rn rl rr rh"
  let ?r' = "snd (delete_max ?r)"
  from \<open>avl x\<close> MKT 2 have "avl l" and "avl ?r" by simp_all
  then show ?case using MKT 2 height_mkt_bal_l[of l ?r' n] height_mkt_bal_l2[of l ?r' n]
    apply (auto split:prod.splits simp del:avl.simps mkt_bal_l.simps) by arith+
qed auto

lemma avl_delete_root:
  assumes "avl t" and "t \<noteq> ET"
  shows "avl(delete_root t)"
using assms
proof (cases t rule:delete_root_cases)
  case (MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  from \<open>avl t\<close> and MKT_MKT have "avl ?r" by simp
  from \<open>avl t\<close> and MKT_MKT have "avl ?l" by simp
  then have "avl(?l')" "height ?l = height(?l') \<or>
         height ?l = height(?l') + 1" by (rule avl_delete_max,simp)+
  with \<open>avl t\<close> MKT_MKT have "height ?l' = height ?r \<or> height ?l' = height ?r + 1
            \<or> height ?r = height ?l' + 1 \<or> height ?r = height ?l' + 2" by fastforce
  with \<open>avl ?l'\<close> \<open>avl ?r\<close> have "avl(mkt_bal_r (fst(delete_max ?l)) ?l' ?r)"
    by (rule avl_mkt_bal_r)
  with MKT_MKT show ?thesis by (auto split:prod.splits simp del:mkt_bal_r.simps)
qed simp_all

lemma height_delete_root:
  assumes "avl t" and "t \<noteq> ET"
  shows "height t = height(delete_root t) \<or> height t = height(delete_root t) + 1"
using assms
proof (cases t rule: delete_root_cases)
  case (MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  let ?t' = "mkt_bal_r (fst(delete_max ?l)) ?l' ?r"
  from \<open>avl t\<close> and MKT_MKT have "avl ?r" by simp
  from \<open>avl t\<close> and MKT_MKT have "avl ?l" by simp
  then have "avl(?l')"  by (rule avl_delete_max,simp)
  have l'_height: "height ?l = height ?l' \<or> height ?l = height ?l' + 1" using \<open>avl ?l\<close> by (intro avl_delete_max) auto
  have t_height: "height t = 1 + max (height ?l) (height ?r)" using \<open>avl t\<close> MKT_MKT by simp
  have "height t = height ?t' \<or> height t = height ?t' + 1" using  \<open>avl t\<close> MKT_MKT
  proof(cases "height ?r = height ?l' + 2")
    case False
    show ?thesis using l'_height t_height False by (subst  height_mkt_bal_r2[OF \<open>avl ?l'\<close> \<open>avl ?r\<close> False])+ arith
  next
    case True
    show ?thesis
    proof(cases rule: disjE[OF height_mkt_bal_r[OF True \<open>avl ?l'\<close> \<open>avl ?r\<close>, of "fst (delete_max ?l)"]])
      case 1
      then show ?thesis using l'_height t_height True by arith
    next
      case 2
      then show ?thesis using l'_height t_height True by arith
    qed
  qed
  thus ?thesis using MKT_MKT by (auto split:prod.splits simp del:mkt_bal_r.simps)
qed simp_all

text\<open>Deletion maintains the AVL property:\<close>

theorem avl_delete_aux:
  assumes "avl t"
  shows "avl(delete x t)" and "height t = (height (delete x t)) \<or> height t = height (delete x t) + 1"
using assms
proof (induct t)
  case (MKT n l r h)
  case 1
  with MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by (auto simp:avl_delete_root)
  next
    case False
    with MKT 1 show ?thesis
    proof(cases "x<n")
      case True
      with MKT 1 show ?thesis by (auto simp add:avl_mkt_bal_r simp del:mkt_bal_r.simps)
    next
      case False
      with MKT 1 \<open>x\<noteq>n\<close> show ?thesis by (auto simp add:avl_mkt_bal_l simp del:mkt_bal_l.simps)
    qed
  qed
  case 2
  with MKT show ?case
  proof(cases "x = n")
    case True
    with 1 have "height (MKT n l r h) = height(delete_root (MKT n l r h))
      \<or> height (MKT n l r h) = height(delete_root (MKT n l r h)) + 1"
      by (subst height_delete_root,simp_all)
    with True show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
     proof(cases "x<n")
      case True
      show ?thesis
      proof(cases "height r = height (delete x l) + 2")
        case False with MKT 1 \<open>x < n\<close> show ?thesis by auto
      next
        case True
        then consider (a) "height (mkt_bal_r n (delete x l) r) = height (delete x l) + 2"
          | (b) "height (mkt_bal_r n (delete x l) r) = height (delete x l) + 3"
          using MKT 2 by (atomize_elim, intro height_mkt_bal_r) auto
        then show ?thesis
        proof cases
          case a
          with \<open>x < n\<close> MKT 2 show ?thesis by auto
        next
          case b
          with \<open>x < n\<close> MKT 2 show ?thesis by auto
        qed
      qed
    next
      case False
      show ?thesis
      proof(cases "height l = height (delete x r) + 2")
        case False with MKT 1 \<open>\<not>x < n\<close> \<open>x \<noteq> n\<close> show ?thesis by auto
      next
        case True
        then consider (a) "height (mkt_bal_l n l (delete x r)) = height (delete x r) + 2"
          | (b) "height (mkt_bal_l n l (delete x r)) = height (delete x r) + 3"
          using MKT 2 by (atomize_elim, intro height_mkt_bal_l) auto
        then show ?thesis
        proof cases
          case a
          with \<open>\<not>x < n\<close> \<open>x \<noteq> n\<close> MKT 2 show ?thesis by auto
        next
          case b
          with \<open>\<not>x < n\<close> \<open>x \<noteq> n\<close> MKT 2 show ?thesis by auto
        qed
      qed
    qed
  qed
qed simp_all

lemmas avl_delete = avl_delete_aux(1)

subsubsection \<open>Correctness of insertion\<close>

lemma set_of_mkt_bal_l:
  "\<lbrakk> avl l; avl r \<rbrakk> \<Longrightarrow>
  set_of (mkt_bal_l n l r) = Set.insert n (set_of l \<union> set_of r)"
by (auto simp: mkt_def split:tree.splits)

lemma set_of_mkt_bal_r:
  "\<lbrakk> avl l; avl r \<rbrakk> \<Longrightarrow>
  set_of (mkt_bal_r n l r) = Set.insert n (set_of l \<union> set_of r)"
by (auto simp: mkt_def split:tree.splits)

text\<open>Correctness of @{const insert}:\<close>

theorem set_of_insert:
  "avl t \<Longrightarrow> set_of(insert x t) = Set.insert x (set_of t)"
by (induct t)
   (auto simp: avl_insert set_of_mkt_bal_l set_of_mkt_bal_r simp del:mkt_bal_l.simps mkt_bal_r.simps)

subsubsection \<open>Correctness of deletion\<close>

fun rightmost_item :: "'a tree \<Rightarrow> 'a" where
"rightmost_item (MKT n l ET h) = n" |
"rightmost_item (MKT n l r h) = rightmost_item r"

lemma avl_dist:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); x \<in> set_of l \<rbrakk> \<Longrightarrow>
  x \<notin> set_of r"
by fastforce

lemma avl_dist2:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); x \<in> set_of l \<or> x \<in> set_of r \<rbrakk> \<Longrightarrow>
  x \<noteq> n"
by auto

lemma ritem_in_rset: "r \<noteq> ET \<Longrightarrow> rightmost_item r \<in> set_of r"
by(induct r rule:rightmost_item.induct) auto

lemma ritem_greatest_in_rset:
  "\<lbrakk> r \<noteq> ET; is_ord r \<rbrakk> \<Longrightarrow>
  \<forall>x.  x \<in> set_of r \<longrightarrow> x \<noteq> rightmost_item r \<longrightarrow> x < rightmost_item r"
proof(induct r rule:rightmost_item.induct)
  case (2 n l rn rl rr rh h)
  show ?case (is "\<forall>x. ?P x")
  proof
    fix x
    from 2 have "is_ord (MKT rn rl rr rh)" by auto
    moreover from 2 have "n < rightmost_item (MKT rn rl rr rh)"
      by (metis is_ord.simps(2) ritem_in_rset tree.simps(2))
    moreover from 2 have "x \<in> set_of l \<longrightarrow> x < rightmost_item (MKT rn rl rr rh)"
      by (metis calculation(2) is_ord.simps(2) xt1(10))
    ultimately show "?P x" using 2 by simp
  qed
qed auto

lemma ritem_not_in_ltree:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); r \<noteq> ET \<rbrakk> \<Longrightarrow>
  rightmost_item r \<notin> set_of l"
by (metis avl_dist ritem_in_rset)

lemma set_of_delete_max:
  "\<lbrakk> avl t; is_ord t; t\<noteq>ET \<rbrakk> \<Longrightarrow>
   set_of (snd(delete_max t)) = (set_of t) - {rightmost_item t}"
proof (induct t rule: delete_max_induct)
  case (MKT n l rn rl rr rh h)
  let ?r = "MKT rn rl rr rh"
  from MKT have "avl l" and "avl ?r" by simp_all
  let ?t' = "mkt_bal_l n l (snd (delete_max ?r))"
  from MKT have "avl (snd(delete_max ?r))" by (auto simp add: avl_delete_max)
  with MKT ritem_not_in_ltree[of n l ?r h]
  have "set_of ?t' = (set_of l) \<union> (set_of ?r) - {rightmost_item ?r} \<union> {n}"
    by (auto simp add:set_of_mkt_bal_l simp del: mkt_bal_l.simps)
  moreover have "n \<notin> {rightmost_item ?r}"
    by (metis MKT(2) MKT(3) avl_dist2 ritem_in_rset singletonE tree.simps(3))
  ultimately show ?case
    by (auto simp add:insert_Diff_if split:prod.splits simp del: mkt_bal_l.simps)
qed auto

lemma fst_delete_max_eq_ritem:
  "t\<noteq>ET \<Longrightarrow> fst(delete_max t) = rightmost_item t"
by (induct t rule:rightmost_item.induct) (auto split:prod.splits)

lemma set_of_delete_root:
  assumes "t = MKT n l r h" and "avl t" and "is_ord t"
  shows "set_of (delete_root t) = (set_of t) - {n}"
using assms
proof(cases t rule:delete_root_cases)
  case(MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?t' = "mkt_bal_r (fst (delete_max l)) (snd (delete_max l)) r"
  from assms MKT_MKT have "avl l" and "avl r" and "is_ord l" and "l\<noteq>ET" by auto
  moreover from MKT_MKT assms have "avl (snd(delete_max l))"
    by (auto simp add: avl_delete_max)
  ultimately have "set_of ?t' = (set_of l) \<union> (set_of r)"
    by (fastforce simp add: Set.insert_Diff ritem_in_rset fst_delete_max_eq_ritem
       set_of_delete_max set_of_mkt_bal_r  simp del: mkt_bal_r.simps)
  moreover from MKT_MKT assms(1) have "set_of (delete_root t) = set_of ?t'"
    by (simp split:prod.split del:mkt_bal_r.simps)
  moreover from MKT_MKT assms have "(set_of t) - {n} = set_of l \<union> set_of r"
    by (metis Diff_insert_absorb UnE avl_dist2 tree.set(2) tree.inject)
  ultimately show ?thesis using MKT_MKT assms(1)
    by (simp del: delete_root.simps)
qed auto

text\<open>Correctness of @{const delete}:\<close>

subsubsection \<open>Correctness of lookup\<close>

theorem is_in_correct: "is_ord t \<Longrightarrow> is_in k t = (k : set_of t)"
by (induct t) auto

subsubsection \<open>Insertion maintains order\<close>

lemma is_ord_mkt_bal_l:
  "is_ord(MKT n l r h) \<Longrightarrow> is_ord (mkt_bal_l n l r)"
by (cases l) (auto simp: mkt_def split:tree.splits intro: order_less_trans)

lemma is_ord_mkt_bal_r: "is_ord(MKT n l r h) \<Longrightarrow> is_ord (mkt_bal_r n l r)"
by (cases r) (auto simp: mkt_def split:tree.splits intro: order_less_trans)

text\<open>If the order is linear, @{const insert} maintains the order:\<close>

theorem is_ord_insert:
  "\<lbrakk> avl t; is_ord t \<rbrakk> \<Longrightarrow> is_ord(insert (x::'a::linorder) t)"
by (induct t) (simp_all add:is_ord_mkt_bal_l is_ord_mkt_bal_r avl_insert set_of_insert
                linorder_not_less order_neq_le_trans del:mkt_bal_l.simps mkt_bal_r.simps)

subsubsection \<open>Deletion maintains order\<close>

lemma is_ord_delete_max:
  "\<lbrakk> avl t; is_ord t; t\<noteq>ET \<rbrakk> \<Longrightarrow> is_ord(snd(delete_max t))"
proof(induct t rule:delete_max_induct)
  case(MKT n l rn rl rr rh h)
  let ?r = "MKT rn rl rr rh"
  let ?r' = "snd(delete_max ?r)"
  from MKT have "\<forall>h. is_ord(MKT n l ?r' h)" by (auto simp: set_of_delete_max)
  moreover from MKT have "avl(?r')" by (auto simp: avl_delete_max)
  moreover note MKT is_ord_mkt_bal_l[of n l ?r']
  ultimately show ?case by (auto split:prod.splits simp del:is_ord.simps mkt_bal_l.simps)
qed auto

lemma is_ord_delete_root:
  assumes "avl t" and "is_ord t" and "t \<noteq> ET"
  shows "is_ord (delete_root t)"
using assms
proof(cases t rule:delete_root_cases)
  case(MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  let ?n' = "fst (delete_max ?l)"
  from assms MKT_MKT have "\<forall>h. is_ord(MKT ?n' ?l' ?r h)"
  proof -
    from assms MKT_MKT have "is_ord ?l'" by (auto simp add: is_ord_delete_max)
    moreover from assms MKT_MKT have "is_ord ?r" by auto
    moreover from assms MKT_MKT have "\<forall>x. x \<in> set_of ?r \<longrightarrow> ?n' < x"
      by (metis fst_delete_max_eq_ritem is_ord.simps(2) order_less_trans ritem_in_rset
          tree.simps(3))
    moreover from assms MKT_MKT ritem_greatest_in_rset have "\<forall>x. x \<in> set_of ?l' \<longrightarrow> x < ?n'"
      by (metis Diff_iff avl.simps(2) fst_delete_max_eq_ritem is_ord.simps(2)
          set_of_delete_max singleton_iff tree.simps(3))
    ultimately show ?thesis by auto
  qed
  moreover from assms MKT_MKT have "avl ?r" by simp
  moreover from assms MKT_MKT have "avl ?l'"  by (simp add: avl_delete_max)
  moreover note MKT_MKT is_ord_mkt_bal_r[of  ?n' ?l' ?r]
  ultimately show ?thesis by (auto simp del:mkt_bal_r.simps is_ord.simps split:prod.splits)
qed simp_all

text\<open>If the order is linear, @{const delete} maintains the order:\<close>

theorem is_ord_delete:
  "\<lbrakk> avl t; is_ord t \<rbrakk> \<Longrightarrow> is_ord (delete x t)"
proof (induct t)
  case (MKT n l r h)
  then show ?case
  proof(cases "x = n")
    case True
    with MKT is_ord_delete_root[of "MKT n l r h"] show ?thesis by simp
  next
    case False
    with MKT show ?thesis
    proof(cases "x<n")
      case True
      with True MKT have "\<forall>h. is_ord (MKT n (delete x l) r h)" by (auto simp:set_of_delete)
      with True MKT is_ord_mkt_bal_r[of n "(delete x l)" r]  show ?thesis
        by (auto simp add: avl_delete)
    next
      case False
      with False MKT have "\<forall>h. is_ord (MKT n l (delete x r) h)" by (auto simp:set_of_delete)
      with False MKT is_ord_mkt_bal_l[of n l "(delete x r)"] \<open>x\<noteq>n\<close> show ?thesis by (simp add: avl_delete)
    qed
  qed
qed simp

end


theory Graph_Theory_Batteries
  imports "Graph_Theory.Graph_Theory"
begin

text \<open>This theory collects some useful lemmas which extend the graph library.\<close>

lemma (in wf_digraph) sp_non_neg_if_w_non_neg:
  assumes w_non_neg: "\<forall>e \<in> arcs G. w e \<ge> 0"
  shows "\<mu> w u v \<ge> 0"
proof(cases "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v")
  case True
  have *: "awalk u p v \<Longrightarrow> awalk_cost w p \<ge> 0" for p
    by (simp add: pos_cost_pos_awalk_cost w_non_neg)
  then show ?thesis unfolding \<mu>_def
    by (metis (mono_tags, lifting) INF_less_iff ereal_less_eq(5) mem_Collect_eq not_less)
next
  case False
  then show ?thesis by (simp add: shortest_path_inf)
qed

lemma (in wf_digraph) sp_to_self_if_w_non_neg:
  assumes w_non_neg: "\<forall>e \<in> arcs G. w e \<ge> 0" and "u \<in> verts G"
  shows "\<mu> w u u = 0"
proof -
  have "awalk u [] u" and "awalk_cost w [] = 0"
    by (auto simp: assms(2) awalk_Nil_iff)
  moreover
  have "\<mu> w u u \<ge> 0" by (simp add: sp_non_neg_if_w_non_neg w_non_neg)
  ultimately show "\<mu> w u u = 0"
    by (metis antisym ereal_eq_0(2) min_cost_le_walk_cost)
qed

lemma (in fin_digraph) reachable_verts_finite: "finite {x. u \<rightarrow>\<^sup>* x}"
  using finite_verts
  by (metis finite_subset mem_Collect_eq reachable_in_vertsE subsetI)

lemma (in wf_digraph) awalk_not_distinct:
  assumes "finite (verts G)" and "awalk u p v" and "length p \<ge> card (verts G)"
  shows "\<not> distinct (awalk_verts u p)"
proof -
  have *: "length (awalk_verts u p) > length p"
    by (induction p arbitrary: u) auto

  show ?thesis
  proof(cases "length p = 0")
    case True
    with assms show ?thesis unfolding awalk_def by simp
  next
    case False
    with assms * have "length (awalk_verts u p) > card (verts G)"
      by auto
    moreover
    have "set (awalk_verts u p) \<subseteq> verts G" using assms(2) by blast
    ultimately show ?thesis using assms(1)
      by (induction p arbitrary: u)
         (auto, metis card_subset_eq distinct_card less_antisym)
  qed
qed

lemma (in wf_digraph) awalk_del_vert:
  "\<lbrakk> awalk u p v; x \<notin> set (awalk_verts u p) \<rbrakk> \<Longrightarrow> pre_digraph.awalk (del_vert x) u p v"
proof(induction p arbitrary: u)
  case Nil
  then have "set (awalk_verts u []) = {u}" by auto
  with Nil have "x \<noteq> u" by simp
  moreover
  from Nil have "u = v" unfolding awalk_def by auto
  ultimately show ?case using Nil
    by (simp add: awalk_hd_in_verts pre_digraph.verts_del_vert
        wf_digraph.awalk_Nil_iff wf_digraph_del_vert)
next
  case (Cons a p)
  then obtain u' where u': "pre_digraph.awalk (del_vert x) u' p v"
    using awalk_Cons_iff by auto
  moreover
  from Cons.prems have "head G a \<noteq> x"
    using hd_in_awalk_verts(1) awalk_Cons_iff by auto
  ultimately show ?case using Cons
    by (auto simp: awalk_Cons_iff head_del_vert pre_digraph.del_vert_simps(2)
        tail_del_vert wf_digraph.awalk_Cons_iff wf_digraph_del_vert)
qed

text \<open>This is an alternative formulation of @{thm pre_digraph.arcs_del_vert}.\<close>
lemma (in pre_digraph) arcs_del_vert2:
  "arcs (del_vert v) = arcs G - in_arcs G v - out_arcs G v"
  using arcs_del_vert by force

lemma (in wf_digraph) strongly_con_imp_reachable_eq_verts:
  "\<lbrakk> r \<in> verts G; strongly_connected G \<rbrakk> \<Longrightarrow> {x. r \<rightarrow>\<^sup>* x} = verts G"
  unfolding strongly_connected_def using reachable_in_verts(2) by blast

lemma (in wf_digraph) strongly_con_imp_sp_finite:
  "\<lbrakk> u \<in> verts G; v \<in> verts G; strongly_connected G \<rbrakk> \<Longrightarrow> \<mu> w u v < \<infinity>"
  unfolding strongly_connected_def using \<mu>_reach_conv by auto

text \<open>This is an alternative formulation of @{thm fin_digraph.min_cost_awalk} with different
  assumptions.\<close>
lemma (in fin_digraph) min_cost_awalk2:
  assumes "\<mu> w a b \<noteq> \<infinity>" "\<mu> w a b \<noteq> -\<infinity>"
  shows "\<exists>p. apath a p b \<and> \<mu> w a b = awalk_cost w p"
proof -
  from assms have "a \<rightarrow>\<^sup>* b" using \<mu>_reach_conv by auto
  then show ?thesis using no_neg_cyc_reach_imp_path
    using assms(2) neg_cycle_imp_inf_\<mu> by blast
qed

lemma (in fin_digraph) sp_triangle:
  assumes "a \<in> verts G" "b \<in> verts G" "c \<in> verts G"
      and w_non_neg: "\<forall>e \<in> arcs G. w e \<ge> 0"
    shows "\<mu> w a c \<le> \<mu> w a b + \<mu> w b c"
proof(rule ccontr)
  assume "\<not> \<mu> w a c \<le> \<mu> w a b + \<mu> w b c"
  then have *: "\<mu> w a c > \<mu> w a b + \<mu> w b c"
    using not_less by blast
  consider (minf) "\<mu> w a c = -\<infinity>" | (pinf) "\<mu> w a c = \<infinity>"
    | (fin) "\<mu> w a c \<noteq> -\<infinity> \<and> \<mu> w a c \<noteq> \<infinity>" by auto
  then show "False"
  proof(cases)
    case minf
    with * show ?thesis by auto
  next
    case pinf
    with * have "\<mu> w a b < \<infinity>" "\<mu> w b c < \<infinity>"
      by auto
    then have "a \<rightarrow>\<^sup>* b" "b \<rightarrow>\<^sup>* c" using \<mu>_reach_conv by auto
    then have "a \<rightarrow>\<^sup>* c" using reachable_trans by blast
    then have "\<mu> w a c \<noteq> \<infinity>" using \<mu>_reach_conv by auto
    with pinf show ?thesis by simp
  next
    case fin
    with * have "\<mu> w a b \<noteq> \<infinity>" "\<mu> w b c \<noteq> \<infinity>" by auto
    moreover
    from fin * have "\<mu> w a b \<noteq> -\<infinity>" "\<mu> w b c \<noteq> -\<infinity>"
      using w_non_neg sp_non_neg_if_w_non_neg by auto
    ultimately have
      "\<exists>p. awalk a p b \<and> awalk_cost w p = \<mu> w a b"
      "\<exists>p. awalk b p c \<and> awalk_cost w p = \<mu> w b c"
      using min_cost_awalk2 by (fastforce intro: awalkI_apath)+
    then obtain p1 p2 where
        "awalk a p1 b" "awalk_cost w p1 = \<mu> w a b" and
        "awalk b p2 c" "awalk_cost w p2 = \<mu> w b c" by blast
    then have "awalk a (p1@p2) c \<and> awalk_cost w (p1@p2) = \<mu> w a b + \<mu> w b c"
      by (auto intro: awalk_appendI) (metis plus_ereal.simps(1))
    then show ?thesis using min_cost_le_walk_cost
      by (metis \<open>\<not> \<mu> w a c \<le> \<mu> w a b + \<mu> w b c\<close>)
  qed
qed

end


theory BST_Demo
imports "HOL-Library.Tree"
begin

(* useful most of the time: *)
declare Let_def [simp]

section "Basic BST Functions"

fun isin :: "('a::linorder) tree \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node l a r) x =
  (if x < a then isin l x else
   if x > a then isin r x
   else True)"

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

subsection "Functional Correctness"

lemma "bst t \<Longrightarrow> isin t x = (x \<in> set_tree t)"
apply(induction t)
apply auto
done

lemma set_tree_ins: "set_tree (ins x t) = {x} \<union> set_tree t"
apply(induction t)
apply auto
done

subsection "Preservation of Invariant"

lemma bst_ins: "bst t \<Longrightarrow> bst (ins x t)"
apply(induction t)
apply (auto simp: set_tree_ins)
done

section "Reducing the Number of Comparisons"

text \<open>Idea: never test for \<open>=\<close> but remember the last value where you
should have tested for \<open>=\<close> but did not. Compare with that value when
you reach a leaf.\<close>

fun isin2 :: "('a::linorder) tree \<Rightarrow> 'a option \<Rightarrow> 'a \<Rightarrow> bool" where
"isin2 Leaf z x = (case z of None \<Rightarrow> False | Some y \<Rightarrow> x = y) " |
"isin2 (Node l a r) z x =
  (if x < a then isin2 l z x else isin2 r (Some a) x)"

lemma isin2_Some:
  "\<lbrakk> bst t;  \<forall>x \<in> set_tree t. y < x \<rbrakk>
  \<Longrightarrow> isin2 t (Some y) x = (isin t x \<or> x=y)"
apply(induction t arbitrary: y)
apply auto
done

lemma isin2_None:
  "bst t \<Longrightarrow> isin2 t None x = isin t x"
apply(induction t)
apply (auto simp: isin2_Some)
done

section "Trees with Size Info"

type_synonym 'a tree_sz = "('a * nat) tree"

fun inv_sz :: "('a::linorder) tree_sz \<Rightarrow> bool" where
"inv_sz \<langle>\<rangle> = True" |
"inv_sz \<langle>l, (a,s), r\<rangle> = (inv_sz l \<and> inv_sz r \<and> s = size l + size r + 1)"

fun sz :: "'a tree_sz \<Rightarrow> nat" where
"sz Leaf = 0" |
"sz (Node _ (_,s) _) = s"

abbreviation un_sz :: "'a tree_sz \<Rightarrow> 'a tree" where
"un_sz t == map_tree fst t"

fun ins_sz :: "'a::linorder \<Rightarrow> 'a tree_sz \<Rightarrow> 'a tree_sz" where
"ins_sz x Leaf = Node Leaf (x,1) Leaf" |
"ins_sz x (Node l (a,s) r) =
  (if x < a then let l' = ins_sz x l in Node l' (a, sz l' + sz r + 1) r else
   if x > a then let r' = ins_sz x r in Node l (a, sz l + sz r' + 1) r'
   else Node l (a,s) r)"

subsection "Functional Correctness"

lemma un_sz_ins_sz: "un_sz (ins_sz x t) = ins x (un_sz t)"
apply(induction t)
apply auto
done

subsection "Preservation of Invariants"

lemma "bst(un_sz t) \<Longrightarrow> bst(un_sz (ins_sz x t))"
by(simp add: un_sz_ins_sz bst_ins)

lemma sz_size[simp]: "inv_sz t \<Longrightarrow> sz t = size t"
apply(induction t)
apply auto
done

lemma "inv_sz t \<Longrightarrow> inv_sz (ins_sz x t)"
apply(induction t)
apply (auto)
done

(* nth smallest element: *)
fun nth_min :: "('a::linorder) tree_sz \<Rightarrow> nat \<Rightarrow> 'a" where
"nth_min \<langle>l, (a,s), r\<rangle> n =
   (let sl = sz l in
    if n = sl then a else
    if n < sl then nth_min l n else nth_min r (n-sl-1))"

lemma "\<lbrakk> bst(un_sz t);  inv_sz t;  n < size t \<rbrakk>
 \<Longrightarrow> nth_min t n = nth (inorder(un_sz t)) n"
apply(induction t arbitrary: n)
apply (auto simp: nth_append)
done

section "Compressing the Height of BSTs"

fun compress :: "'a tree \<Rightarrow> 'a tree" where
"compress (Node Leaf a t) =
  (case compress t of
     Node Leaf b u \<Rightarrow> Node (Node Leaf a Leaf) b u |
     u \<Rightarrow> Node Leaf a u)" |
"compress (Node l a r) = Node (compress l) a (compress r)" |
"compress Leaf = Leaf"

(* Another way of saying that \<open>bst\<close> and \<open>set_tree\<close> are preserved: *)
lemma "inorder(compress t) = inorder t"
apply(induction t rule: compress.induct)
apply (auto split: tree.split)
done

lemma "height (compress t) \<le> height t"
apply(induction t rule: compress.induct)
apply (auto split: tree.split)
done

(* What is the correct relationship? *)
lemma "height t \<le> height (compress t)"
oops

section "BST Implementation of Maps"

fun lookup :: "('a::linorder * 'b) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node l (a,b) r) x =
  (if x < a then lookup l x else
   if x > a then lookup r x
   else Some b)"

fun update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a::linorder * 'b) tree \<Rightarrow> ('a * 'b) tree" where
"update x y Leaf = Node Leaf (x,y) Leaf" |
"update x y (Node l (a,b) r) =
  (if x < a then Node (update x y l) (a,b) r else
   if x > a then Node l (a,b) (update x y r)
   else Node l (x,y) r)"

subsection "Functional Correctness"

lemma "lookup (update x y t) a = (if x=a then Some y else lookup t a)"
apply(induction t)
apply auto
done

subsection "Preservation of Invariant"

definition "bst1 t = bst (map_tree fst t)"

lemma map_tree_update: "map_tree fst (update x y t) = ins x (map_tree fst t)"
apply(induction t)
apply auto
done

lemma "bst1 t \<Longrightarrow> bst1(update x y t)"
apply(induction t)
apply (auto simp: bst1_def map_tree_update set_tree_ins)
done

end


section \<open>Prefixes\<close>

theory prefix
  imports Main
begin

text \<open>This Function describes that a list is a prefix of another list.\<close>

definition
  "isPrefix xs ys \<equiv> xs = take (length xs) ys"

lemma isPrefix_append:
  "isPrefix xs ys \<Longrightarrow> isPrefix xs (ys@zs)"
  using take_all by (fastforce simp add: isPrefix_def)

lemma isPrefix_refl: "isPrefix xs xs"
  by (simp add: isPrefix_def)

lemma isPrefix_empty: "isPrefix xs [] \<longleftrightarrow> xs = []"
  by (simp add: isPrefix_def)

lemma isPrefix_empty_first: "isPrefix [] xs"
  by (simp add: isPrefix_def)

lemma isPrefix_appendI:
  "isPrefix xs (xs@ys)"
  by (simp add: isPrefix_def)

lemma isPrefix_len:
  "isPrefix tr tr' \<Longrightarrow> length tr \<le> length tr'"
  by (metis isPrefix_def nat_le_linear take_all)

lemma isPrefix_trans:
  "isPrefix xs ys \<Longrightarrow> isPrefix ys zs \<Longrightarrow> isPrefix xs zs"
  by (auto simp add: isPrefix_def, metis length_take take_take)

lemma isPrefix_appendPrefix:
  "isPrefix (xs@ys) zs \<Longrightarrow> isPrefix xs zs"
  using isPrefix_appendI isPrefix_trans by blast

lemma isPrefix_subset:
  "isPrefix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
  by (metis isPrefix_def set_take_subset)

lemma isPrefix_subset2:
  "isPrefix xs ys \<Longrightarrow> x\<in>set xs \<Longrightarrow> x\<in> set ys"
  using isPrefix_subset by auto

lemma isPrefix_same:
  assumes "isPrefix tr tr'"
    and "i<length tr"
  shows "tr!i = tr'!i"
  using assms by (auto simp add: isPrefix_def, metis nth_take)

end


theory ch12
imports Main
begin

text {*
 Note: to avoid name clashes with the existing type of lists we build
 on top of Datatype rather than Main. This is an exception!
*}

datatype 'a list = Nil | Cons 'a "'a list"

primrec app :: "'a list => 'a list => 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

primrec rev :: "'a list => 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

text {*
  Simple proofs:

  Command 'lemma' / 'theorem': state a proposition
  Attribute 'simp': use this theorem as a simplification rule in future proofs
  Method 'induct': structural induction
  Method 'auto':  automatic proof (mostly by simplification)
  Command 'done':  end of proof
*}

lemma app_Nil2[simp]: "app xs Nil = xs"
apply (induct xs)
apply auto
done

lemma app_assoc[simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply (induct xs)
apply auto
done

lemma rev_app[simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
apply (induct xs)
apply auto
done

theorem rev_rev[simp]: "rev (rev xs) = xs"
apply (induct xs)
apply auto
done

(* Hint for demo:
   do the proof top down, discovering the lemmas one by one,
   as described in LNCS2283.
*)

end


theory group_class
imports Main
begin

class semigroup =
  fixes mult :: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

class monoidl = semigroup +
  fixes neutral :: 'a ("e")
  assumes neutl: "e \<otimes> x = x"

class monoid = monoidl +
  assumes neutr: "x \<otimes> e = x"

class group = monoidl +
fixes inverse ::"'a \<Rightarrow> 'a" ("inv")
assumes invl: "(inv x) \<otimes> x = e"

lemma (in group) left_cancel: "x \<otimes> y = x \<otimes> z \<Longrightarrow> y = z"
proof-
assume "x \<otimes> y = x \<otimes> z"
then have "(inv x) \<otimes> (x \<otimes> y) = (inv x) \<otimes> (x \<otimes> z)" by simp
then have "((inv x) \<otimes> x) \<otimes> y = ((inv x) \<otimes> x) \<otimes> z" using assoc by simp
then show "y = z" using neutl and invl by simp
qed

(*
subclass (in group) monoid
proof-
fix x
from invl have "(inv x) \<otimes> x = e" by simp
then have "(inv x) \<otimes> (x \<otimes> e) = (inv x) \<otimes> x" using assoc [symmetric] and neutl and invl by simp
then have "x \<otimes> e = x" using left_cancel by simp
*)


theory power
  imports Main
begin

  (*
    We define the property of power x^n. We will recursively go through till n is equal to 0.
  *)
  primrec pow :: "nat => nat => nat"
    where
      "pow x 0       = Suc 0"
    | "pow x (Suc n) = x * pow x n"

  (*
    We will prove that when we multiply the powers,
    its the same as doing the power twice first with m then with n.
  *)

  (*
    First we will prove the base case, which is multiplying the
    results of two powered numbers is the same as adding the powers before hand.
    We use induction tactic on the power and apply auto.
  *)
  lemma pow_add: "pow x (m + n) = pow x m * pow x n"
    apply (induct n)
    apply auto
  done

  (*
    This uses the base case that we proved above using the lemma.
    We use induction tactic on the power and apply auto.
  *)
  theorem pow_mult: "pow x (m * n) = pow (pow x m) n"
    apply (induct n)
    apply (auto simp add: pow_add)
  done

end


(*  Title:      HOL/Complete_Partial_Order.thy
    Author:     Brian Huffman, Portland State University
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Chain-complete partial orders and their fixpoints\<close>

theory Complete_Partial_Order
  imports Product_Type
begin

subsection \<open>Monotone functions\<close>

text \<open>Dictionary-passing version of @{const Orderings.mono}.\<close>

definition monotone :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "monotone orda ordb f \<longleftrightarrow> (\<forall>x y. orda x y \<longrightarrow> ordb (f x) (f y))"

lemma monotoneI[intro?]: "(\<And>x y. orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone orda ordb f"
  unfolding monotone_def by iprover

lemma monotoneD[dest?]: "monotone orda ordb f \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
  unfolding monotone_def by iprover

subsection \<open>Chains\<close>

text \<open>
  A chain is a totally-ordered set. Chains are parameterized over
  the order for maximal flexibility, since type classes are not enough.
\<close>

definition chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "chain ord S \<longleftrightarrow> (\<forall>x\<in>S. \<forall>y\<in>S. ord x y \<or> ord y x)"

lemma chainI:
  assumes "\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> ord x y \<or> ord y x"
  shows "chain ord S"
  using assms unfolding chain_def by fast

lemma chainD:
  assumes "chain ord S" and "x \<in> S" and "y \<in> S"
  shows "ord x y \<or> ord y x"
  using assms unfolding chain_def by fast

lemma chainE:
  assumes "chain ord S" and "x \<in> S" and "y \<in> S"
  obtains "ord x y" | "ord y x"
  using assms unfolding chain_def by fast

lemma chain_empty: "chain ord {}"
  by (simp add: chain_def)

lemma chain_equality: "chain op = A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x = y)"
  by (auto simp add: chain_def)

lemma chain_subset: "chain ord A \<Longrightarrow> B \<subseteq> A \<Longrightarrow> chain ord B"
  by (rule chainI) (blast dest: chainD)

lemma chain_imageI:
  assumes chain: "chain le_a Y"
    and mono: "\<And>x y. x \<in> Y \<Longrightarrow> y \<in> Y \<Longrightarrow> le_a x y \<Longrightarrow> le_b (f x) (f y)"
  shows "chain le_b (f ` Y)"
  by (blast intro: chainI dest: chainD[OF chain] mono)

subsection \<open>Chain-complete partial orders\<close>

text \<open>
  A \<open>ccpo\<close> has a least upper bound for any chain.  In particular, the
  empty set is a chain, so every \<open>ccpo\<close> must have a bottom element.
\<close>

class ccpo = order + Sup +
  assumes ccpo_Sup_upper: "chain (op \<le>) A \<Longrightarrow> x \<in> A \<Longrightarrow> x \<le> Sup A"
  assumes ccpo_Sup_least: "chain (op \<le>) A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup A \<le> z"
begin

lemma chain_singleton: "Complete_Partial_Order.chain op \<le> {x}"
  by (rule chainI) simp

lemma ccpo_Sup_singleton [simp]: "\<Squnion>{x} = x"
  by (rule antisym) (auto intro: ccpo_Sup_least ccpo_Sup_upper simp add: chain_singleton)

subsection \<open>Transfinite iteration of a function\<close>

context notes [[inductive_internals]]
begin

inductive_set iterates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set"
  for f :: "'a \<Rightarrow> 'a"
  where
    step: "x \<in> iterates f \<Longrightarrow> f x \<in> iterates f"
  | Sup: "chain (op \<le>) M \<Longrightarrow> \<forall>x\<in>M. x \<in> iterates f \<Longrightarrow> Sup M \<in> iterates f"

end

lemma iterates_le_f: "x \<in> iterates f \<Longrightarrow> monotone (op \<le>) (op \<le>) f \<Longrightarrow> x \<le> f x"
  by (induct x rule: iterates.induct)
    (force dest: monotoneD intro!: ccpo_Sup_upper ccpo_Sup_least)+

lemma chain_iterates:
  assumes f: "monotone (op \<le>) (op \<le>) f"
  shows "chain (op \<le>) (iterates f)" (is "chain _ ?C")
proof (rule chainI)
  fix x y
  assume "x \<in> ?C" "y \<in> ?C"
  then show "x \<le> y \<or> y \<le> x"
  proof (induct x arbitrary: y rule: iterates.induct)
    fix x y
    assume y: "y \<in> ?C"
      and IH: "\<And>z. z \<in> ?C \<Longrightarrow> x \<le> z \<or> z \<le> x"
    from y show "f x \<le> y \<or> y \<le> f x"
    proof (induct y rule: iterates.induct)
      case (step y)
      with IH f show ?case by (auto dest: monotoneD)
    next
      case (Sup M)
      then have chM: "chain (op \<le>) M"
        and IH': "\<And>z. z \<in> M \<Longrightarrow> f x \<le> z \<or> z \<le> f x" by auto
      show "f x \<le> Sup M \<or> Sup M \<le> f x"
      proof (cases "\<exists>z\<in>M. f x \<le> z")
        case True
        then have "f x \<le> Sup M"
          apply rule
          apply (erule order_trans)
          apply (rule ccpo_Sup_upper[OF chM])
          apply assumption
          done
        then show ?thesis ..
      next
        case False
        with IH' show ?thesis
          by (auto intro: ccpo_Sup_least[OF chM])
      qed
    qed
  next
    case (Sup M y)
    show ?case
    proof (cases "\<exists>x\<in>M. y \<le> x")
      case True
      then have "y \<le> Sup M"
        apply rule
        apply (erule order_trans)
        apply (rule ccpo_Sup_upper[OF Sup(1)])
        apply assumption
        done
      then show ?thesis ..
    next
      case False with Sup
      show ?thesis by (auto intro: ccpo_Sup_least)
    qed
  qed
qed

lemma bot_in_iterates: "Sup {} \<in> iterates f"
  by (auto intro: iterates.Sup simp add: chain_empty)

subsection \<open>Fixpoint combinator\<close>

definition fixp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "fixp f = Sup (iterates f)"

lemma iterates_fixp:
  assumes f: "monotone (op \<le>) (op \<le>) f"
  shows "fixp f \<in> iterates f"
  unfolding fixp_def
  by (simp add: iterates.Sup chain_iterates f)

lemma fixp_unfold:
  assumes f: "monotone (op \<le>) (op \<le>) f"
  shows "fixp f = f (fixp f)"
proof (rule antisym)
  show "fixp f \<le> f (fixp f)"
    by (intro iterates_le_f iterates_fixp f)
  have "f (fixp f) \<le> Sup (iterates f)"
    by (intro ccpo_Sup_upper chain_iterates f iterates.step iterates_fixp)
  then show "f (fixp f) \<le> fixp f"
    by (simp only: fixp_def)
qed

lemma fixp_lowerbound:
  assumes f: "monotone (op \<le>) (op \<le>) f"
    and z: "f z \<le> z"
  shows "fixp f \<le> z"
  unfolding fixp_def
proof (rule ccpo_Sup_least[OF chain_iterates[OF f]])
  fix x
  assume "x \<in> iterates f"
  then show "x \<le> z"
  proof (induct x rule: iterates.induct)
    case (step x)
    from f \<open>x \<le> z\<close> have "f x \<le> f z" by (rule monotoneD)
    also note z
    finally show "f x \<le> z" .
  next
    case (Sup M)
    then show ?case
      by (auto intro: ccpo_Sup_least)
  qed
qed

end

subsection \<open>Fixpoint induction\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "ccpo")\<close>

definition admissible :: "('a set \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "admissible lub ord P \<longleftrightarrow> (\<forall>A. chain ord A \<longrightarrow> A \<noteq> {} \<longrightarrow> (\<forall>x\<in>A. P x) \<longrightarrow> P (lub A))"

lemma admissibleI:
  assumes "\<And>A. chain ord A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<forall>x\<in>A. P x \<Longrightarrow> P (lub A)"
  shows "ccpo.admissible lub ord P"
  using assms unfolding ccpo.admissible_def by fast

lemma admissibleD:
  assumes "ccpo.admissible lub ord P"
  assumes "chain ord A"
  assumes "A \<noteq> {}"
  assumes "\<And>x. x \<in> A \<Longrightarrow> P x"
  shows "P (lub A)"
  using assms by (auto simp: ccpo.admissible_def)

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

lemma (in ccpo) fixp_induct:
  assumes adm: "ccpo.admissible Sup (op \<le>) P"
  assumes mono: "monotone (op \<le>) (op \<le>) f"
  assumes bot: "P (Sup {})"
  assumes step: "\<And>x. P x \<Longrightarrow> P (f x)"
  shows "P (fixp f)"
  unfolding fixp_def
  using adm chain_iterates[OF mono]
proof (rule ccpo.admissibleD)
  show "iterates f \<noteq> {}"
    using bot_in_iterates by auto
next
  fix x
  assume "x \<in> iterates f"
  then show "P x"
  proof (induct rule: iterates.induct)
    case prems: (step x)
    from this(2) show ?case by (rule step)
  next
    case (Sup M)
    then show ?case by (cases "M = {}") (auto intro: step bot ccpo.admissibleD adm)
  qed
qed

lemma admissible_True: "ccpo.admissible lub ord (\<lambda>x. True)"
  unfolding ccpo.admissible_def by simp

(*lemma admissible_False: "\<not> ccpo.admissible lub ord (\<lambda>x. False)"
unfolding ccpo.admissible_def chain_def by simp
*)
lemma admissible_const: "ccpo.admissible lub ord (\<lambda>x. t)"
  by (auto intro: ccpo.admissibleI)

lemma admissible_conj:
  assumes "ccpo.admissible lub ord (\<lambda>x. P x)"
  assumes "ccpo.admissible lub ord (\<lambda>x. Q x)"
  shows "ccpo.admissible lub ord (\<lambda>x. P x \<and> Q x)"
  using assms unfolding ccpo.admissible_def by simp

lemma admissible_all:
  assumes "\<And>y. ccpo.admissible lub ord (\<lambda>x. P x y)"
  shows "ccpo.admissible lub ord (\<lambda>x. \<forall>y. P x y)"
  using assms unfolding ccpo.admissible_def by fast

lemma admissible_ball:
  assumes "\<And>y. y \<in> A \<Longrightarrow> ccpo.admissible lub ord (\<lambda>x. P x y)"
  shows "ccpo.admissible lub ord (\<lambda>x. \<forall>y\<in>A. P x y)"
  using assms unfolding ccpo.admissible_def by fast

lemma chain_compr: "chain ord A \<Longrightarrow> chain ord {x \<in> A. P x}"
  unfolding chain_def by fast

context ccpo
begin

lemma admissible_disj:
  fixes P Q :: "'a \<Rightarrow> bool"
  assumes P: "ccpo.admissible Sup (op \<le>) (\<lambda>x. P x)"
  assumes Q: "ccpo.admissible Sup (op \<le>) (\<lambda>x. Q x)"
  shows "ccpo.admissible Sup (op \<le>) (\<lambda>x. P x \<or> Q x)"
proof (rule ccpo.admissibleI)
  fix A :: "'a set"
  assume chain: "chain (op \<le>) A"
  assume A: "A \<noteq> {}" and P_Q: "\<forall>x\<in>A. P x \<or> Q x"
  have "(\<exists>x\<in>A. P x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y) \<or> (\<exists>x\<in>A. Q x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> Q y)"
    (is "?P \<or> ?Q" is "?P1 \<and> ?P2 \<or> _")
  proof (rule disjCI)
    assume "\<not> ?Q"
    then consider "\<forall>x\<in>A. \<not> Q x" | a where "a \<in> A" "\<forall>y\<in>A. a \<le> y \<longrightarrow> \<not> Q y"
      by blast
    then show ?P
    proof cases
      case 1
      with P_Q have "\<forall>x\<in>A. P x" by blast
      with A show ?P by blast
    next
      case 2
      note a = \<open>a \<in> A\<close>
      show ?P
      proof
        from P_Q 2 have *: "\<forall>y\<in>A. a \<le> y \<longrightarrow> P y" by blast
        with a have "P a" by blast
        with a show ?P1 by blast
        show ?P2
        proof
          fix x
          assume x: "x \<in> A"
          with chain a show "\<exists>y\<in>A. x \<le> y \<and> P y"
          proof (rule chainE)
            assume le: "a \<le> x"
            with * a x have "P x" by blast
            with x le show ?thesis by blast
          next
            assume "a \<ge> x"
            with a \<open>P a\<close> show ?thesis by blast
          qed
        qed
      qed
    qed
  qed
  moreover
  have "Sup A = Sup {x \<in> A. P x}" if "\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y" for P
  proof (rule antisym)
    have chain_P: "chain (op \<le>) {x \<in> A. P x}"
      by (rule chain_compr [OF chain])
    show "Sup A \<le> Sup {x \<in> A. P x}"
      apply (rule ccpo_Sup_least [OF chain])
      apply (drule that [rule_format])
      apply clarify
      apply (erule order_trans)
      apply (simp add: ccpo_Sup_upper [OF chain_P])
      done
    show "Sup {x \<in> A. P x} \<le> Sup A"
      apply (rule ccpo_Sup_least [OF chain_P])
      apply clarify
      apply (simp add: ccpo_Sup_upper [OF chain])
      done
  qed
  ultimately
  consider "\<exists>x. x \<in> A \<and> P x" "Sup A = Sup {x \<in> A. P x}"
    | "\<exists>x. x \<in> A \<and> Q x" "Sup A = Sup {x \<in> A. Q x}"
    by blast
  then show "P (Sup A) \<or> Q (Sup A)"
    apply cases
     apply simp_all
     apply (rule disjI1)
     apply (rule ccpo.admissibleD [OF P chain_compr [OF chain]]; simp)
    apply (rule disjI2)
    apply (rule ccpo.admissibleD [OF Q chain_compr [OF chain]]; simp)
    done
qed

end

instance complete_lattice \<subseteq> ccpo
  by standard (fast intro: Sup_upper Sup_least)+

lemma lfp_eq_fixp:
  assumes mono: "mono f"
  shows "lfp f = fixp f"
proof (rule antisym)
  from mono have f': "monotone (op \<le>) (op \<le>) f"
    unfolding mono_def monotone_def .
  show "lfp f \<le> fixp f"
    by (rule lfp_lowerbound, subst fixp_unfold [OF f'], rule order_refl)
  show "fixp f \<le> lfp f"
    by (rule fixp_lowerbound [OF f']) (simp add: lfp_fixpoint [OF mono])
qed

hide_const (open) iterates fixp

end


section \<open>Challenge 1.A\<close>
theory Challenge1A
  imports Main
  "../../../../SeLFiE"
begin

text \<open>Problem definition:
\<^url>\<open>https://ethz.ch/content/dam/ethz/special-interest/infk/chair-program-method/pm/documents/Verify%20This/Challenges%202019/ghc_sort.pdf\<close>\<close>

  subsection \<open>Implementation\<close>
  text \<open>We phrase the algorithm as a functional program.
    Instead of a list of indexes for segment boundaries,
    we return a list of lists, containing the segments.\<close>

  text \<open>We start with auxiliary functions to take the longest
    increasing/decreasing sequence from the start of the list
  \<close>
  fun take_incr :: "int list \<Rightarrow> _" where
    "take_incr [] = []"
  | "take_incr [x] = [x]"
  | "take_incr (x#y#xs) = (if x<y then x#take_incr (y#xs) else [x])"

  fun take_decr :: "int list \<Rightarrow> _" where
    "take_decr [] = []"
  | "take_decr [x] = [x]"
  | "take_decr (x#y#xs) = (if x\<ge>y then x#take_decr (y#xs) else [x])"

  fun take where
    "take [] = []"
  | "take [x] = [x]"
  | "take (x#y#xs) = (if x<y then take_incr (x#y#xs) else take_decr (x#y#xs))"

  definition "take2 xs \<equiv> let l=take xs in (l,drop (length l) xs)"
    \<comment> \<open>Splits of a longest increasing/decreasing sequence from the list\<close>

  text \<open>The main algorithm then iterates until the whole input list is split\<close>
  function cuts where
    "cuts xs = (if xs=[] then [] else let (c,xs) = take2 xs in c#cuts xs)"
    by pat_completeness auto

  subsection \<open>Termination\<close>
  text \<open>First, we show termination. This will give us induction and proper unfolding lemmas.\<close>

  lemma take_non_empty:
    "take xs \<noteq> []" if "xs \<noteq> []"
    using that
    apply (cases xs)
     apply clarsimp
    subgoal for x ys
      apply (cases ys)
       apply auto
      done
    done

  termination
    apply (relation "measure length")
     apply (auto simp: take2_def Let_def)
    using take_non_empty
    apply auto
    done

  declare cuts.simps[simp del]

  subsection \<open>Correctness\<close>

  subsubsection \<open>Property 1: The Exact Sequence is Covered\<close>
  lemma tdconc: "\<exists>ys. xs = take_decr xs @ ys"semantic_induct
    apply (induction xs rule: take_decr.induct)
    apply auto
    done

  lemma ticonc: "\<exists>ys. xs = take_incr xs @ ys"semantic_induct
    apply (induction xs rule: take_incr.induct)
    apply auto
    done

  lemma take_conc: "\<exists>ys. xs = take xs@ys"
    using tdconc ticonc
    apply (cases xs rule: take.cases)
    by auto

  theorem concat_cuts: "concat (cuts xs) = xs"semantic_induct
    apply (induction xs rule: cuts.induct)
    apply (subst cuts.simps)
    apply (auto simp: take2_def Let_def)
    by (metis append_eq_conv_conj take_conc)

  subsubsection \<open>Property 2: Monotonicity\<close>
  text \<open>We define constants to specify increasing/decreasing sequences.\<close>
  fun incr where
    "incr [] \<longleftrightarrow> True"
  | "incr [_] \<longleftrightarrow> True"
  | "incr (x#y#xs) \<longleftrightarrow> x<y \<and> incr (y#xs)"

  fun decr where
    "decr [] \<longleftrightarrow> True"
  | "decr [_] \<longleftrightarrow> True"
  | "decr (x#y#xs) \<longleftrightarrow> x\<ge>y \<and> decr (y#xs)"

  lemma tki: "incr (take_incr xs)"semantic_induct
    apply (induction xs rule: take_incr.induct)
    apply auto
    apply (case_tac xs)
    apply auto
    done

  lemma tkd: "decr (take_decr xs)"semantic_induct
    apply (induction xs rule: take_decr.induct)
    apply auto
    apply (case_tac xs)
    apply auto
    done

  lemma icod: "incr (take xs) \<or> decr (take xs)"
    apply (cases xs rule: take.cases)
    apply (auto simp: tki tkd simp del: take_incr.simps take_decr.simps)
    done

theorem cuts_incr_decr: "\<forall>c\<in>set (cuts xs). incr c \<or> decr c"  semantic_induct
  all_induction_heuristic [on["xs"], arb[],rule["cuts.induct"]]
    apply (induction xs rule: cuts.induct)
    apply (subst cuts.simps)
    apply (auto simp: take2_def Let_def)
    using icod by blast

  subsubsection \<open>Property 3: Maximality\<close>
  text \<open>Specification of a cut that consists of maximal segments:
    The segements are non-empty, and for every two neighbouring segments,
    the first value of the last segment cannot be used to continue the first segment:
  \<close>
  fun maxi where
     "maxi [] \<longleftrightarrow> True"
   | "maxi [c] \<longleftrightarrow> c\<noteq>[]"
   | "maxi (c1#c2#cs) \<longleftrightarrow> (c1\<noteq>[] \<and> c2\<noteq>[] \<and> maxi (c2#cs) \<and> (
        incr c1 \<and> \<not>(last c1 < hd c2)
      \<or> decr c1 \<and> \<not>(last c1 \<ge> hd c2)
        ))"

  text \<open>Obviously, our specification implies that there are no
    empty segments\<close>
  lemma maxi_imp_non_empty: "maxi xs \<Longrightarrow> []\<notin>set xs"
    by (induction xs rule: maxi.induct) auto

  lemma tdconc': "xs\<noteq>[] \<Longrightarrow>
    \<exists>ys. xs = take_decr xs @ ys \<and> (ys\<noteq>[]
      \<longrightarrow> \<not>(last (take_decr xs) \<ge> hd ys))"semantic_induct
    apply (induction xs rule: take_decr.induct)
    apply auto
    apply (case_tac xs) apply (auto split: if_splits)
    done

  lemma ticonc': "xs\<noteq>[] \<Longrightarrow> \<exists>ys. xs = take_incr xs @ ys \<and> (ys\<noteq>[] \<longrightarrow> \<not>(last (take_incr xs) < hd ys))"semantic_induct
    apply (induction xs rule: take_incr.induct)
    apply auto
    apply (case_tac xs) apply (auto split: if_splits)
    done

  lemma take_conc': "xs\<noteq>[] \<Longrightarrow> \<exists>ys. xs = take xs@ys \<and> (ys\<noteq>[] \<longrightarrow> (
    take xs=take_incr xs \<and> \<not>(last (take_incr xs) < hd ys)
  \<or> take xs=take_decr xs \<and> \<not>(last (take_decr xs) \<ge> hd ys)
  ))"
    using tdconc' ticonc'
    apply (cases xs rule: take.cases)
    by auto

  lemma take_decr_non_empty:
    "take_decr xs \<noteq> []" if "xs \<noteq> []"
    using that
    apply (cases xs)
     apply auto
    subgoal for x ys
      apply (cases ys)
       apply (auto split: if_split_asm)
      done
    done

  lemma take_incr_non_empty:
    "take_incr xs \<noteq> []" if "xs \<noteq> []"
    using that
    apply (cases xs)
     apply auto
    subgoal for x ys
      apply (cases ys)
       apply (auto split: if_split_asm)
      done
    done

  lemma take_conc'': "xs\<noteq>[] \<Longrightarrow> \<exists>ys. xs = take xs@ys \<and> (ys\<noteq>[] \<longrightarrow> (
    incr (take xs) \<and> \<not>(last (take xs) < hd ys)
  \<or> decr (take xs) \<and> \<not>(last (take xs) \<ge> hd ys)
  ))"
    using tdconc' ticonc' tki tkd
    apply (cases xs rule: take.cases)
    apply auto
    apply (auto simp add: take_incr_non_empty)
    apply (simp add: take_decr_non_empty)
    apply (metis list.distinct(1) take_incr.simps(3))
    by (smt list.simps(3) take_decr.simps(3))

  lemma inv_cuts: "cuts xs = c#cs \<Longrightarrow> \<exists>ys. c=take xs \<and> xs=c@ys \<and> cs = cuts ys"
    apply (subst (asm) cuts.simps)
    apply (cases xs rule: cuts.cases)
    apply (auto split: if_splits simp: take2_def Let_def)
    by (metis append_eq_conv_conj take_conc)

theorem maximal_cuts: "maxi (cuts xs)" semantic_induct
  all_induction_heuristic [on["cuts xs"], arb[],rule["maxi.induct"]]
    apply (induction "cuts xs" arbitrary: xs rule: maxi.induct)
    subgoal by auto
    subgoal for c xs
      apply (drule sym; simp)
      apply (subst (asm) cuts.simps)
      apply (auto split: if_splits prod.splits simp: take2_def Let_def take_non_empty)
      done
    subgoal for c1 c2 cs xs
      apply (drule sym)
      apply simp
      apply (drule inv_cuts; clarsimp)
      apply auto
      subgoal by (metis cuts.simps list.distinct(1) take_non_empty)
      subgoal by (metis append.left_neutral inv_cuts not_Cons_self)
      subgoal using icod by blast
      subgoal by (metis
            Nil_is_append_conv cuts.simps hd_append2 inv_cuts list.distinct(1)
            same_append_eq take_conc'' take_non_empty)
      subgoal by (metis
            append_is_Nil_conv cuts.simps hd_append2 inv_cuts list.distinct(1)
            same_append_eq take_conc'' take_non_empty)
      done
    done

  subsubsection \<open>Equivalent Formulation Over Indexes\<close>
  text \<open>After the competition, we got the comment that a specification of
    monotonic sequences via indexes might be more readable.

    We show that our functional specification is equivalent to a
    specification over indexes.\<close>

  fun ii_induction where
    "ii_induction [] = ()"
  | "ii_induction [_] = ()"
  | "ii_induction (_#y#xs) = ii_induction (y#xs)"

  locale cnvSpec =
    fixes fP P
    assumes [simp]: "fP [] \<longleftrightarrow> True"
    assumes [simp]: "fP [x] \<longleftrightarrow> True"
    assumes [simp]: "fP (a#b#xs) \<longleftrightarrow> P a b \<and> fP (b#xs)"
  begin

    lemma idx_spec: "fP xs \<longleftrightarrow> (\<forall>i<length xs - 1. P (xs!i) (xs!Suc i))"semantic_induct
      apply (induction xs rule: ii_induction.induct)
      using less_Suc_eq_0_disj
      by auto

  end

  locale cnvSpec' =
    fixes fP P P'
    assumes [simp]: "fP [] \<longleftrightarrow> True"
    assumes [simp]: "fP [x] \<longleftrightarrow> P' x"
    assumes [simp]: "fP (a#b#xs) \<longleftrightarrow> P' a \<and> P' b \<and> P a b \<and> fP (b#xs)"
  begin

    lemma idx_spec: "fP xs \<longleftrightarrow> (\<forall>i<length xs. P' (xs!i)) \<and> (\<forall>i<length xs - 1. P (xs!i) (xs!Suc i))"semantic_induct
      apply (induction xs rule: ii_induction.induct)
      apply auto []
      apply auto []
      apply clarsimp
      by (smt less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc)

  end

  interpretation INCR: cnvSpec incr "(<)"
    apply unfold_locales by auto

  interpretation DECR: cnvSpec decr "(\<ge>)"
    apply unfold_locales by auto

  interpretation MAXI: cnvSpec' maxi "\<lambda>c1 c2. ( (
        incr c1 \<and> \<not>(last c1 < hd c2)
      \<or> decr c1 \<and> \<not>(last c1 \<ge> hd c2)
        ))"
      "\<lambda>x. x \<noteq> []"
    apply unfold_locales by auto

  lemma incr_by_idx: "incr xs = (\<forall>i<length xs - 1. xs ! i < xs ! Suc i)"
    by (rule INCR.idx_spec)

  lemma decr_by_idx: "decr xs = (\<forall>i<length xs - 1. xs ! i \<ge> xs ! Suc i)"
    by (rule DECR.idx_spec)

  lemma maxi_by_idx: "maxi xs \<longleftrightarrow>
    (\<forall>i<length xs. xs ! i \<noteq> []) \<and>
    (\<forall>i<length xs - 1.
         incr (xs ! i) \<and> \<not> last (xs ! i) < hd (xs ! Suc i)
       \<or> decr (xs ! i) \<and> \<not> hd (xs ! Suc i) \<le> last (xs ! i)
    )"
    by (rule MAXI.idx_spec)

  theorem all_correct:
    "concat (cuts xs) = xs"
    "\<forall>c\<in>set (cuts xs). incr c \<or> decr c"
    "maxi (cuts xs)"
    "[] \<notin> set (cuts xs)"
    using cuts_incr_decr concat_cuts maximal_cuts
          maxi_imp_non_empty[OF maximal_cuts]
    by auto

end


(*
  File: Partial_Equiv_Rel.thy
  Author: Bohua Zhan
*)

section \<open>Partial equivalence relation\<close>

theory Partial_Equiv_Rel
  imports "Auto2_HOL.Auto2_Main"
begin

text \<open>
  Partial equivalence relations, following theory
  Lib/Partial\_Equivalence\_Relation in \<^cite>\<open>"Collections-AFP"\<close>.
\<close>

definition part_equiv :: "('a \<times> 'a) set \<Rightarrow> bool" where [rewrite]:
  "part_equiv R \<longleftrightarrow> sym R \<and> trans R"

lemma part_equivI [forward]: "sym R \<Longrightarrow> trans R \<Longrightarrow> part_equiv R" by auto2
lemma part_equivD1 [forward]: "part_equiv R \<Longrightarrow> sym R" by auto2
lemma part_equivD2 [forward]: "part_equiv R \<Longrightarrow> trans R" by auto2
setup \<open>del_prfstep_thm_eqforward @{thm part_equiv_def}\<close>

subsection \<open>Combining two elements in a partial equivalence relation\<close>

definition per_union :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set" where [rewrite]:
  "per_union R a b = R \<union> { (x,y). (x,a)\<in>R \<and> (b,y)\<in>R } \<union> { (x,y). (x,b)\<in>R \<and> (a,y)\<in>R }"

lemma per_union_memI1 [backward]:
  "(x, y) \<in> R \<Longrightarrow> (x, y) \<in> per_union R a b" by (simp add: per_union_def)
setup \<open>add_forward_prfstep_cond @{thm per_union_memI1} [with_term "per_union ?R ?a ?b"]\<close>

lemma per_union_memI2 [backward]:
  "(x, a) \<in> R \<Longrightarrow> (b, y) \<in> R \<Longrightarrow> (x, y) \<in> per_union R a b" by (simp add: per_union_def)

lemma per_union_memI3 [backward]:
  "(x, b) \<in> R \<Longrightarrow> (a, y) \<in> R \<Longrightarrow> (x, y) \<in> per_union R a b" by (simp add: per_union_def)

lemma per_union_memD:
  "(x, y) \<in> per_union R a b \<Longrightarrow> (x, y) \<in> R \<or> ((x, a) \<in> R \<and> (b, y) \<in> R) \<or> ((x, b) \<in> R \<and> (a, y) \<in> R)"
  by (simp add: per_union_def)
setup \<open>add_forward_prfstep_cond @{thm per_union_memD} [with_cond "?x \<noteq> ?y", with_filt (order_filter "x" "y")]\<close>
setup \<open>del_prfstep_thm @{thm per_union_def}\<close>

lemma per_union_is_trans [forward]:
  "trans R \<Longrightarrow> trans (per_union R a b)" by auto2

lemma per_union_is_part_equiv [forward]:
  "part_equiv R \<Longrightarrow> part_equiv (per_union R a b)" by auto2

end


(* Author: Tobias Nipkow *)

section "Extended Regular Expressions"

theory Regular_Exp2
imports Regular_Set
begin

datatype (atoms: 'a) rexp =
  is_Zero: Zero |
  is_One: One |
  Atom 'a |
  Plus "('a rexp)" "('a rexp)" |
  Times "('a rexp)" "('a rexp)" |
  Star "('a rexp)" |
  Not "('a rexp)" |
  Inter "('a rexp)" "('a rexp)"

context
fixes S :: "'a set"
begin

primrec lang :: "'a rexp => 'a lang" where
"lang Zero = {}" |
"lang One = {[]}" |
"lang (Atom a) = {[a]}" |
"lang (Plus r s) = (lang r) Un (lang s)" |
"lang (Times r s) = conc (lang r) (lang s)" |
"lang (Star r) = star(lang r)" |
"lang (Not r) = lists S - lang r" |
"lang (Inter r s) = (lang r Int lang s)"

end

lemma lang_subset_lists: "atoms r \<subseteq> S \<Longrightarrow> lang S r \<subseteq> lists S"
by(induction r)(auto simp: conc_subset_lists star_subset_lists)

primrec nullable :: "'a rexp \<Rightarrow> bool" where
"nullable Zero = False" |
"nullable One = True" |
"nullable (Atom c) = False" |
"nullable (Plus r1 r2) = (nullable r1 \<or> nullable r2)" |
"nullable (Times r1 r2) = (nullable r1 \<and> nullable r2)" |
"nullable (Star r) = True" |
"nullable (Not r) = (\<not> (nullable r))" |
"nullable (Inter r s) = (nullable r \<and> nullable s)"

lemma nullable_iff: "nullable r \<longleftrightarrow> [] \<in> lang S r"
by (induct r) (auto simp add: conc_def split: if_splits)

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

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

datatype Nat = Z | S "Nat"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(Nat list) list => Nat list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun risers :: "Nat list => (Nat list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun msortbu2 :: "Nat list => Nat list" where
  "msortbu2 x = mergingbu2 (risers x)"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "((msortbu2 xs) = (isort xs))"
  oops

end


theory Predic_Logic
  imports Main
begin

lemma "(\<exists>x. \<forall>y. P(x,y)) \<longrightarrow> (\<forall> y. \<exists>x. P(x,y))"
  apply (rule impI)
  apply (erule exE)
  apply (rule allI)
  apply (erule allE)
  apply (rule exI)
  apply assumption
  done

lemma "(\<forall>x. P(x) \<longrightarrow> Q) = ((\<exists>x. P(x)) \<longrightarrow> Q)"
  apply (rule iffI)
   apply (rule impI)
   apply (erule exE)
   apply (erule allE)
   apply (erule impE)
    apply assumption+
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule exI)
   apply assumption+
  done

lemma "(\<not> (\<forall>x. P x)) = (\<exists>x. \<not> P x)"
proof (rule iffI)
  assume "\<not> (\<forall>x. P x)"
  show "\<exists>x. \<not> P x"
  proof (rule ccontr)
    assume "\<not> (\<exists>x. \<not> P x)"
    then have "\<forall>x. P x" by simp
    with \<open>\<not> (\<forall>x. P x)\<close> show False by contradiction
  qed
next
  assume "\<exists>x. \<not> P x"
  then obtain c where "\<not> P c" by (rule exE)
  show "\<not> (\<forall>x. P x)"
  proof (rule notI)
    assume "\<forall>x. P x"
    then have "P c" by (rule allE)
    with \<open>\<not> P c\<close> show False by contradiction
  qed
qed

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Ordinal Arithmetic *}

theory OrdinalArith
imports OrdinalRec
begin

subsection {* Addition *}

instantiation ordinal :: plus
begin

definition
  "op + = (\<lambda>x. ordinal_rec x (\<lambda>p. oSuc))"

instance ..

end

lemma ordinal_plus_0 [simp]: "x + 0 = (x::ordinal)"
by (simp add: plus_ordinal_def)

lemma ordinal_plus_oSuc [simp]: "x + oSuc y = oSuc (x + y)"
by (simp add: plus_ordinal_def)

lemma ordinal_plus_oLimit [simp]: "x + oLimit f = oLimit (\<lambda>n. x + f n)"
by (simp add: normal.oLimit normal_plus)

lemma ordinal_0_plus [simp]: "0 + x = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_plus_assoc:
"(x + y) + z = x + (y + z::ordinal)"
by (rule_tac a=z in oLimit_induct, simp_all)

lemma ordinal_plus_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x + y \<le> x' + (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct, simp_all)
 apply clarify
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma ordinal_plus_monoR: "y \<le> y' \<Longrightarrow> x + y \<le> x + (y'::ordinal)"
by (rule normal.monoD[OF normal_plus])

lemma ordinal_plus_mono:
"\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x + y \<le> x' + (y'::ordinal)"
by (rule order_trans[OF ordinal_plus_monoL ordinal_plus_monoR])

lemma ordinal_plus_strict_monoR: "y < y' \<Longrightarrow> x + y < x + (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_plus])

lemma ordinal_le_plusL [simp]: "y \<le> x + (y::ordinal)"
by (cut_tac ordinal_plus_monoL[OF ordinal_0_le], simp)

lemma ordinal_le_plusR [simp]: "x \<le> x + (y::ordinal)"
by (cut_tac ordinal_plus_monoR[OF ordinal_0_le], simp)

lemma ordinal_less_plusR: "0 < y \<Longrightarrow> x < x + (y::ordinal)"
by (drule_tac ordinal_plus_strict_monoR, simp)

lemma ordinal_plus_left_cancel [simp]:
"(w + x = w + y) = (x = (y::ordinal))"
by (rule normal.cancel_eq[OF normal_plus])

lemma ordinal_plus_left_cancel_le [simp]:
"(w + x \<le> w + y) = (x \<le> (y::ordinal))"
by (rule normal.cancel_le[OF normal_plus])

lemma ordinal_plus_left_cancel_less [simp]:
"(w + x < w + y) = (x < (y::ordinal))"
by (rule normal.cancel_less[OF normal_plus])

lemma ordinal_plus_not_0: "(0 < x + y) = (0 < x \<or> 0 < (y::ordinal))"
 apply safe
   apply simp
  apply (erule order_less_le_trans, rule ordinal_le_plusR)
 apply (erule order_less_le_trans, rule ordinal_le_plusL)
done

lemma not_inject: "(\<not> P) = (\<not> Q) \<Longrightarrow> P = Q"
by auto

lemma ordinal_plus_eq_0:
"((x::ordinal) + y = 0) = (x = 0 \<and> y = 0)"
by (rule not_inject, simp add: ordinal_plus_not_0)

subsection {* Subtraction *}

instantiation ordinal :: minus
begin

definition
  minus_ordinal_def:
    "x - y = ordinal_rec 0 (\<lambda>p w. if y \<le> p then oSuc w else w) x"

instance ..

end

lemma continuous_minus: "continuous (\<lambda>x. x - y)"
 apply (unfold minus_ordinal_def)
 apply (rule continuous_ordinal_rec)
 apply (simp add: order_less_imp_le)
done

lemma ordinal_0_minus [simp]: "0 - x = (0::ordinal)"
by (simp add: minus_ordinal_def)

lemma ordinal_oSuc_minus [simp]: "y \<le> x \<Longrightarrow> oSuc x - y = oSuc (x - y)"
by (simp add: minus_ordinal_def)

lemma ordinal_oLimit_minus [simp]: "oLimit f - y = oLimit (\<lambda>n. f n - y)"
by (rule continuousD[OF continuous_minus])

lemma ordinal_minus_0 [simp]: "x - 0 = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_oSuc_minus2: "x < y \<Longrightarrow> oSuc x - y = x - y"
by (simp add: minus_ordinal_def linorder_not_le[symmetric])

lemma ordinal_minus_eq_0 [rule_format, simp]:
"x \<le> y \<longrightarrow> x - y = (0::ordinal)"
 apply (rule_tac a=x in oLimit_induct)
   apply simp
  apply (simp add: ordinal_oSuc_minus2 order_less_imp_le oSuc_le_eq_less)
 apply (simp add: order_trans[OF le_oLimit])
done

lemma ordinal_plus_minus1 [simp]: "(x + y) - x = (y::ordinal)"
by (rule_tac a=y in oLimit_induct, simp_all)

lemma ordinal_plus_minus2 [simp]: "x \<le> y \<Longrightarrow> x + (y - x) = (y::ordinal)"
 apply (subgoal_tac "\<forall>z. y < x + z \<longrightarrow> x + (y - x) = y")
  apply (drule_tac x="oSuc y" in spec, erule mp)
  apply (rule order_less_le_trans[OF less_oSuc], simp)
 apply (rule allI, rule_tac a=z in oLimit_induct)
   apply (simp add: linorder_not_less[symmetric])
  apply (clarsimp simp add: less_oSuc_eq_le)
 apply (clarsimp, drule less_oLimitD, clarsimp)
done

lemma ordinal_minusI: "x = y + z \<Longrightarrow> x - y = (z::ordinal)"
by simp

lemma ordinal_minus_less_eq [simp]:
"(y::ordinal) \<le> x \<Longrightarrow> (x - y < z) = (x < y + z)"
 apply (subgoal_tac "(x - y < z) = (y + (x - y) < y + z)", simp)
 apply (simp only: ordinal_plus_left_cancel_less)
done

lemma ordinal_minus_le_eq [simp]:
"(x - y \<le> z) = (x \<le> y + (z::ordinal))"
 apply (rule_tac x=x and y=y in linorder_le_cases)
  apply (simp, erule order_trans, simp)
 apply (subgoal_tac "(x - y \<le> z) = (y + (x - y) \<le> y + z)", simp)
 apply (simp only: ordinal_plus_left_cancel_le)
done

lemma ordinal_minus_monoL: "x \<le> y \<Longrightarrow> x - z \<le> y - (z::ordinal)"
by (erule continuous.monoD[OF continuous_minus])

lemma ordinal_minus_monoR: "x \<le> y \<Longrightarrow> z - y \<le> z - (x::ordinal)"
 apply (rule_tac x=y and y=z in linorder_le_cases)
  apply (subst ordinal_minus_le_eq)
  apply (subgoal_tac "x + (z - x) \<le> y + (z - x)")
   apply (drule order_trans, assumption, simp)
  apply (erule ordinal_plus_monoL)
 apply simp
done

subsection {* Multiplication *}

instantiation ordinal :: times
begin

definition
  times_ordinal_def: "op * = (\<lambda>x. ordinal_rec 0 (\<lambda>p w. w + x))"

instance ..

end

lemma continuous_times: "continuous (op * x)"
by (simp add: times_ordinal_def continuous_ordinal_rec)

lemma normal_times: "0 < x \<Longrightarrow> normal (op * x)"
 apply (unfold times_ordinal_def)
 apply (rule normal_ordinal_rec[rule_format], rename_tac y)
 apply (subgoal_tac "y + 0 < y + x", simp)
 apply (simp only: ordinal_plus_left_cancel_less)
done

lemma ordinal_times_0 [simp]: "x * 0 = (0::ordinal)"
by (simp add: times_ordinal_def)

lemma ordinal_times_oSuc [simp]: "x * oSuc y = (x * y) + x"
by (simp add: times_ordinal_def)

lemma ordinal_times_oLimit [simp]: "x * oLimit f = oLimit (\<lambda>n. x * f n)"
by (simp add: times_ordinal_def ordinal_rec_oLimit)

lemma ordinal_0_times [simp]: "0 * x = (0::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_1_times [simp]: "oSuc 0 * x = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_times_1 [simp]: "x * oSuc 0 = (x::ordinal)"
by simp

lemma ordinal_times_distrib:
"x * (y + z) = (x * y) + (x * z::ordinal)"
by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_plus_assoc)

lemma ordinal_times_assoc:
"(x * y::ordinal) * z = x * (y * z)"
by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_distrib)

lemma ordinal_times_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x * y \<le> x' * (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply clarify
  apply (simp add: ordinal_plus_mono)
 apply clarsimp
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma ordinal_times_monoR: "y \<le> y' \<Longrightarrow> x * y \<le> x * (y'::ordinal)"
by (rule continuous.monoD[OF continuous_times])

lemma ordinal_times_mono:
"\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x * y \<le> x' * (y'::ordinal)"
by (rule order_trans[OF ordinal_times_monoL ordinal_times_monoR])

lemma ordinal_times_strict_monoR:
"\<lbrakk>y < y'; 0 < x\<rbrakk> \<Longrightarrow> x * y < x * (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_times])

lemma ordinal_le_timesL [simp]: "0 < x \<Longrightarrow> y \<le> x * (y::ordinal)"
by (drule ordinal_times_monoL[OF oSuc_leI], simp)

lemma ordinal_le_timesR [simp]: "0 < y \<Longrightarrow> x \<le> x * (y::ordinal)"
by (drule ordinal_times_monoR[OF oSuc_leI], simp)

lemma ordinal_less_timesR: "\<lbrakk>0 < x; oSuc 0 < y\<rbrakk> \<Longrightarrow> x < x * (y::ordinal)"
by (drule ordinal_times_strict_monoR, assumption, simp)

lemma ordinal_times_left_cancel [simp]:
"0 < w \<Longrightarrow> (w * x = w * y) = (x = (y::ordinal))"
by (rule normal.cancel_eq[OF normal_times])

lemma ordinal_times_left_cancel_le [simp]:
"0 < w \<Longrightarrow> (w * x \<le> w * y) = (x \<le> (y::ordinal))"
by (rule normal.cancel_le[OF normal_times])

lemma ordinal_times_left_cancel_less [simp]:
"0 < w \<Longrightarrow> (w * x < w * y) = (x < (y::ordinal))"
by (rule normal.cancel_less[OF normal_times])

lemma ordinal_times_eq_0:
"((x::ordinal) * y = 0) = (x = 0 \<or> y = 0)"
 apply (rule iffI)
  apply (erule contrapos_pp, clarsimp)
  apply (drule oSuc_leI)
  apply (erule order_less_le_trans)
  apply (drule ordinal_times_monoL, simp)
 apply auto
done

lemma ordinal_times_not_0 [simp]:
"((0::ordinal) < x * y) = (0 < x \<and> 0 < y)"
by (rule not_inject, simp add: ordinal_times_eq_0)

subsection {* Exponentiation *}

definition
  exp_ordinal :: "[ordinal, ordinal] \<Rightarrow> ordinal" (infixr "**" 75) where
  "op ** = (\<lambda>x. if 0 < x then ordinal_rec 1 (\<lambda>p w. w * x)
                         else (\<lambda>y. if y = 0 then 1 else 0))"

lemma continuous_exp: "0 < x \<Longrightarrow> continuous (op ** x)"
by (simp add: exp_ordinal_def continuous_ordinal_rec)

lemma ordinal_exp_0 [simp]: "x ** 0 = (1::ordinal)"
by (simp add: exp_ordinal_def)

lemma ordinal_exp_oSuc [simp]: "x ** oSuc y = (x ** y) * x"
by (simp add: exp_ordinal_def)

lemma ordinal_exp_oLimit [simp]:
"0 < x \<Longrightarrow> x ** oLimit f = oLimit (\<lambda>n. x ** f n)"
by (rule continuousD[OF continuous_exp])

lemma ordinal_0_exp [simp]: "0 ** x = (if x = 0 then 1 else 0)"
by (simp add: exp_ordinal_def)

lemma ordinal_1_exp [simp]: "oSuc 0 ** x = oSuc 0"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_exp_1 [simp]: "x ** oSuc 0 = x"
by simp

lemma ordinal_exp_distrib:
"x ** (y + z) = (x ** y) * (x ** (z::ordinal))"
 apply (case_tac "x = 0", simp_all add: ordinal_plus_not_0)
 apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_assoc)
done

lemma ordinal_exp_not_0 [simp]: "(0 < x ** y) = (0 < x \<or> y = 0)"
 apply auto
  apply (erule contrapos_pp, simp)
 apply (rule_tac a=y in oLimit_induct, simp_all)
 apply (rule less_oLimitI, erule spec)
done

lemma ordinal_exp_eq_0 [simp]: "(x ** y = 0) = (x = 0 \<and> 0 < y)"
by (rule not_inject, simp)

lemma ordinal_exp_assoc:
"(x ** y) ** z = x ** (y * z)"
 apply (case_tac "x = 0", simp_all)
 apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_exp_distrib)
done

lemma ordinal_exp_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x ** y \<le> x' ** (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply (simp add: ordinal_times_mono)
 apply clarsimp
 apply (case_tac "x = 0", simp)
 apply (case_tac "x' = 0", simp_all)
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma normal_exp: "oSuc 0 < x \<Longrightarrow> normal (op ** x)"
 apply (frule_tac order_less_trans[OF less_oSuc])
 apply (rule normalI, simp, rename_tac y)
 apply (subgoal_tac "x ** y * 1 < x ** y * x", simp)
 apply (subst ordinal_times_left_cancel_less)
  apply simp
 apply simp
done

lemma ordinal_exp_monoR:
"\<lbrakk>0 < x; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x ** (y'::ordinal)"
by (rule continuous.monoD[OF continuous_exp])

lemma ordinal_exp_mono:
"\<lbrakk>0 < x'; x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x' ** (y'::ordinal)"
by (rule order_trans[OF ordinal_exp_monoL ordinal_exp_monoR])

lemma ordinal_exp_strict_monoR:
"\<lbrakk>oSuc 0 < x; y < y'\<rbrakk> \<Longrightarrow> x ** y < x ** (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_exp])

lemma ordinal_le_expR [simp]: "0 < y \<Longrightarrow> x \<le> x ** (y::ordinal)"
 apply (subgoal_tac "x ** oSuc 0 \<le> x ** y")
  apply (simp del: ordinal_exp_oSuc)
 apply (case_tac "x = 0", simp)
 apply (rule ordinal_exp_monoR, simp_all add: oSuc_leI)
done

lemma ordinal_exp_left_cancel [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x = w ** y) = (x = y)"
by (rule normal.cancel_eq[OF normal_exp])

lemma ordinal_exp_left_cancel_le [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x \<le> w ** y) = (x \<le> y)"
by (rule normal.cancel_le[OF normal_exp])

lemma ordinal_exp_left_cancel_less [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x < w ** y) = (x < y)"
by (rule normal.cancel_less[OF normal_exp])

end


(*
  File:     Power_By_Squaring.thy
  Author:   Manuel Eberl, TU München

  Fast computing of funpow (applying some functon n times) for weakly associative binary
  functions using exponentiation by squaring. Yields efficient exponentiation algorithms on
  monoid_mult and for modular exponentiation "b ^ e mod m" (and thus also for "cong")
*)
section \<open>Exponentiation by Squaring\<close>
theory Power_By_Squaring
  imports Main
begin

context
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
begin

function efficient_funpow :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "efficient_funpow y x 0 = y"
| "efficient_funpow y x (Suc 0) = f x y"
| "n \<noteq> 0 \<Longrightarrow> even n \<Longrightarrow> efficient_funpow y x n = efficient_funpow y (f x x) (n div 2)"
| "n \<noteq> 1 \<Longrightarrow> odd n \<Longrightarrow> efficient_funpow y x n = efficient_funpow (f x y) (f x x) (n div 2)"
  by force+
termination by (relation "measure (snd \<circ> snd)") (auto elim: oddE)

lemma efficient_funpow_code [code]:
  "efficient_funpow y x n =
     (if n = 0 then y
      else if n = 1 then f x y
      else if even n then efficient_funpow y (f x x) (n div 2)
      else efficient_funpow (f x y) (f x x) (n div 2))"
  by (induction y x n rule: efficient_funpow.induct) auto

end

lemma efficient_funpow_correct:
  assumes f_assoc: "\<And>x z. f x (f x z) = f (f x x) z"
  shows "efficient_funpow f y x n = (f x ^^ n) y"
proof -
  have [simp]: "f ^^ 2 = (\<lambda>x. f (f x))" for f :: "'a \<Rightarrow> 'a"
    by (simp add: eval_nat_numeral o_def)
  show ?thesis
    by (induction y x n rule: efficient_funpow.induct[of _ f])
       (auto elim!: evenE oddE simp: funpow_mult [symmetric] funpow_Suc_right f_assoc
             simp del: funpow.simps(2))
qed

(*
  TODO: This could be used as a code_unfold rule or something like that but the
  implications are not quite clear. Would this be a good default implementation
  for powers?
*)
context monoid_mult
begin

lemma power_by_squaring: "efficient_funpow (*) (1 :: 'a) = (^)"
proof (intro ext)
  fix x :: 'a and n
  have "efficient_funpow (*) 1 x n = ((*) x ^^ n) 1"
    by (subst efficient_funpow_correct) (simp_all add: mult.assoc)
  also have "\<dots> = x ^ n"
    by (induction n) simp_all
  finally show "efficient_funpow (*) 1 x n = x ^ n" .
qed

end

end


section "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

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

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

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

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

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

text {* A little syntax magic to write larger states compactly: *}

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

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

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

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

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

lemma null_state_app[simp]: "<> x = 0" by (auto simp: null_state_def)

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

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

text{* Now we also eliminate all occurrences of 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

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

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

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

end


theory Graph
  imports Main
begin

section \<open>Graphs\<close>

record 'a graph =
  vertices :: "'a set"
  edges :: "'a set set"

locale graph =
  fixes G :: "'a graph"
  assumes graph: "\<forall>e\<in>edges G. \<exists>u v. u \<in> vertices G \<and> v \<in> vertices G \<and> u \<noteq> v \<and> e = {u, v}"

lemma (in graph) Union_edges_subset_vertices:
  shows "\<Union> (edges G) \<subseteq> vertices G"
  using graph
  by fastforce

lemma (in graph) edge_subset_vertices:
  assumes "e \<in> edges G"
  shows "e \<subseteq> vertices G"
  using assms Union_edges_subset_vertices
  by blast

locale finite_graph = graph G for G +
  assumes vertices_finite: "finite (vertices G)"

lemma (in finite_graph) edges_finite:
  shows "finite (edges G)"
proof -
  have "\<Union> (edges G) \<subseteq> vertices G"
    using Union_edges_subset_vertices
    by simp
  moreover have "finite ..."
    using vertices_finite
    by simp
  ultimately have "finite (\<Union> (edges G))"
    by (rule finite_subset)
  thus ?thesis
    by (rule finite_UnionD)
qed

section \<open>Subgraphs\<close>

locale subgraph = supergraph: graph G + subgraph: graph H for G H +
  assumes vertices_subset: "vertices H \<subseteq> vertices G"
  assumes edges_subset: "edges H \<subseteq> edges G"

locale induced_subgraph = graph G for G +
  fixes H :: "'a graph"
  fixes V :: "'a set"
  assumes induced: "H = \<lparr>vertices = vertices G \<inter> V, edges = {e \<in> edges G. e \<subseteq> V}\<rparr>"

sublocale induced_subgraph \<subseteq> subgraph
proof (rule subgraph.intro)
  show "graph G"
    using graph_axioms
    .
next
  { fix e
    assume "e \<in> edges H"
    hence
      "e \<in> edges G"
      "e \<subseteq> V"
      by (simp add: induced)+
    then obtain u v where
      "u \<noteq> v" and
      "e = {u, v}" and
      "u \<in> vertices H"
      "v \<in> vertices H"
      using graph
      by (auto simp add: induced)
    hence "\<exists>u v. u \<in> vertices H \<and> v \<in> vertices H \<and> u \<noteq> v \<and> e = {u, v}"
      by blast }
  thus "graph H"
    by (simp add: graph_def)
next
  have "vertices H \<subseteq> vertices G"
    by (simp add: induced)
  moreover have "edges H \<subseteq> edges G"
    by (simp add: induced)
  ultimately show "subgraph_axioms G H"
    by (rule subgraph_axioms.intro)
qed

lemmas (in induced_subgraph) vertices_subset = vertices_subset
lemmas (in induced_subgraph) edges_subset = edges_subset
lemmas (in induced_subgraph) subgraph_graph_axioms = subgraph.graph_axioms

lemma (in induced_subgraph) vertices_subgraph_subset:
  shows "vertices H \<subseteq> V"
  by (simp add: induced)

lemma (in induced_subgraph) vertices_subgraph_eq:
  assumes "V \<subseteq> vertices G"
  shows "vertices H = V"
  using assms
  by (auto simp add: induced)

lemma induced_subgraph_trans:
  assumes G_induced_subgraph: "induced_subgraph F G V"
  assumes H_induced_subgraph: "induced_subgraph G H W"
  shows "induced_subgraph F H (V \<inter> W)"
proof (rule induced_subgraph.intro)
  show "graph F"
    using G_induced_subgraph
    by (rule induced_subgraph.axioms(1))
next
  have
    "vertices H = vertices G \<inter> W"
    "edges H = {e \<in> edges G. e \<subseteq> W}"
    by (simp add: induced_subgraph.induced[OF H_induced_subgraph])+
  hence
    "vertices H = vertices F \<inter> V \<inter> W"
    "edges H = {e \<in> {e \<in> edges F. e \<subseteq> V}. e \<subseteq> W}"
    by (simp add: induced_subgraph.induced[OF G_induced_subgraph])+
  hence
    "vertices H = vertices F \<inter> (V \<inter> W)"
    "edges H = {e \<in> edges F. e \<subseteq> (V \<inter> W)}"
    by blast+
  thus "induced_subgraph_axioms F H (V \<inter> W)"
    by (intro induced_subgraph_axioms.intro) simp
qed

section \<open>Neighborhood\<close>

definition neighborhood :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "neighborhood G v \<equiv> {u \<in> vertices G. {v, u} \<in> edges G}"

lemma (in graph) in_neighborhood_iff:
  shows "u \<in> neighborhood G v \<longleftrightarrow> {v, u} \<in> edges G"
  using edge_subset_vertices
  by (auto simp add: neighborhood_def)

lemma (in graph) neighborhood_symmetric:
  shows "u \<in> neighborhood G v \<longleftrightarrow> v \<in> neighborhood G u"
  by (simp add: in_neighborhood_iff insert_commute)

lemma neighborhood_subset_vertices:
  shows "neighborhood G v \<subseteq> vertices G"
  by (simp add: neighborhood_def)

lemma in_neighborhood_implies_in_vertices:
  assumes "u \<in> neighborhood G v"
  shows "u \<in> vertices G"
  using assms neighborhood_subset_vertices
  by fastforce

lemma (in finite_graph) neighborhood_finite:
  shows "finite (neighborhood G v)"
  using neighborhood_subset_vertices vertices_finite
  by (rule finite_subset)

section \<open>Degree\<close>

abbreviation degree :: "'a graph \<Rightarrow> 'a \<Rightarrow> nat" where
  "degree G v \<equiv> card (neighborhood G v)"

lemma (in finite_graph) degree_0_conv:
  shows "degree G v = 0 \<longleftrightarrow> (\<nexists>e. e \<in> edges G \<and> v \<in> e)"
proof -
  have "finite (neighborhood G v)"
    using neighborhood_finite
    .
  hence "card (neighborhood G v) = 0 \<longleftrightarrow> neighborhood G v = {}"
    by (rule card_0_eq)
  also have "... \<longleftrightarrow> (\<nexists>u. {v, u} \<in> edges G)"
    by (auto simp add: in_neighborhood_iff)
  finally show ?thesis
    using graph
    by (auto simp add: insert_commute)
qed

end


theory YT_tut_2 imports Main begin

thm fold.simps

fun list_sum :: "nat list \<Rightarrow> nat" where
  "list_sum [] = 0"
| "list_sum (x#xs) = x + list_sum xs"

value "list_sum [1,2,3]"

definition list_sum' :: "nat list \<Rightarrow> nat" where
  "list_sum' xs = fold (+) xs 0"

value "list_sum' [1,2,3]"

thm list_sum'_def

lemma lemma_aux:  "\<forall>a. fold (+) xs a = list_sum xs + a" apply (induction xs) by auto
lemma "list_sum xs = list_sum' xs" apply (induction xs) by (auto simp: list_sum'_def lemma_aux)

datatype 'a ltree = Leaf 'a | Node "'a ltree" "'a ltree"

fun inorder :: "'a ltree \<Rightarrow> 'a list" where
  "inorder (Leaf x) = [x]"
| "inorder (Node l r) = inorder l @ inorder r"

value "inorder (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3))"

fun fold_ltree :: "('a \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 'a ltree \<Rightarrow> 's \<Rightarrow> 's" where
  "fold_ltree f (Leaf x) a = f x a"
| "fold_ltree f (Node l r) a = fold_ltree f r (fold_ltree f l a)"

value "fold_ltree (+) (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3)) 0"

lemma "\<forall> a. fold f (inorder t) a = fold_ltree f t a" apply (induction t) by auto

fun mirror :: "'a ltree \<Rightarrow> 'a ltree" where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = (Node (mirror r) (mirror l))"

lemma "inorder (mirror t) = rev (inorder t)" apply (induction t) by auto

fun shuffles :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "shuffles xs [] = [xs]"
| "shuffles [] ys = [ys]"
| "shuffles (x#xs) (y#ys) = map (\<lambda>xs. x#xs) (shuffles xs (y#ys)) @
                            map (\<lambda>ys. y#ys) (shuffles (x#xs) ys)"

thm shuffles.induct

lemma "zs \<in> set (shuffles xs ys) \<Longrightarrow> length zs = length xs + length ys"
  apply (induction xs ys arbitrary: zs rule: shuffles.induct) by auto

end