theory Demo09
  imports 
    Main
begin


section \<open>Typedef\<close>

text \<open>Redefinition of sets, we use capital letters to distinguish 
  it from existing set-type.\<close>

typedef 'a SET = "{ f :: 'a \<Rightarrow> bool. True}" by auto
print_theorems

term "Rep_SET :: 'a SET \<Rightarrow> ('a \<Rightarrow> bool)" 
term "Abs_SET :: ('a \<Rightarrow> bool) \<Rightarrow> 'a SET"

definition EMPTY :: "'a SET" where
  "EMPTY = Abs_SET (\<lambda> _. False)" 

definition ELEM :: "'a \<Rightarrow> 'a SET \<Rightarrow> bool" where
  "ELEM x A = Rep_SET A x" 

definition UNION :: "'a SET \<Rightarrow> 'a SET \<Rightarrow> 'a SET" where
  "UNION A B = Abs_SET (\<lambda> x. Rep_SET A x \<or> Rep_SET B x)" 

lemma UNION: "ELEM x (UNION A B) \<longleftrightarrow> ELEM x A \<or> ELEM x B" 
  unfolding UNION_def ELEM_def 
  apply (subst Abs_SET_inverse)
  by auto

thm Abs_SET_inverse


text \<open>Example Type-Definitions\<close>

typedef 'a ty1 = "{ f :: 'a \<Rightarrow> nat . True}" by auto

typedef 'a ty2 = "{ f :: 'a \<Rightarrow> nat . finite {x. f x > 0}}" 
    by (intro exI[of _ "\<lambda> _ . 0"], auto)

typedef 'a ty3 = "{ f :: nat \<Rightarrow> 'a . True}" by auto

typedef 'a ty4 = "{ (n, f :: nat \<Rightarrow> 'a) . (\<forall> i. i < n \<or> f i = undefined) }" by auto


text \<open>Example: Integers\<close> 

typedef INTEGER = "{ bn. case bn of (b,n :: nat) \<Rightarrow> n = 0 \<longrightarrow> b}" by auto 
print_theorems
thm Rep_INTEGER_inverse
thm Rep_INTEGER
thm Abs_INTEGER_inverse


definition ZERO :: INTEGER where 
  "ZERO = Abs_INTEGER (True, 0)" 

text \<open>define addition on representative type\<close>

fun add_integer :: "bool \<times> nat \<Rightarrow> bool \<times> nat \<Rightarrow> bool \<times> nat" where
  "add_integer (True,n) (True,m) = (True, n+m)" 
| "add_integer (False,n) (False,m) = (False, n+m)" 
| "add_integer (True,n) (False,m) = (if m \<le> n then (True, n - m) else (False, m - n))" 
| "add_integer (False,n) (True,m) = (if n \<le> m then (True, m - n) else (False, n - m))" 

text \<open>and lift this to addition on abstract type\<close>

definition ADD :: "INTEGER \<Rightarrow> INTEGER \<Rightarrow> INTEGER" where
  "ADD x y = Abs_INTEGER (add_integer (Rep_INTEGER x) (Rep_INTEGER y))" 

text \<open>tedious reasoning via conversion functions\<close>

lemma "ADD x ZERO = x" 
  unfolding ADD_def ZERO_def
  apply (cases "Rep_INTEGER x", auto)
  thm Abs_INTEGER_inverse
  apply (simp add: Abs_INTEGER_inverse)
proof -
  fix b n
  assume *: "Rep_INTEGER x = (b,n)" 
  show "Abs_INTEGER (add_integer (b, n) (True, 0)) = x" 
  proof (cases b)
    case True
    thus ?thesis using * apply auto 
      by (metis Rep_INTEGER_inverse)
    thm Rep_INTEGER_inverse
  next
    case False
    with * have n: "n > 0" using Rep_INTEGER[of x] by auto
    thus ?thesis using * False apply auto
      by (metis Rep_INTEGER_inverse)
  qed
qed



section \<open>Lifting and Transfer Package\<close>

subsection \<open>Example: Integers\<close>

setup_lifting type_definition_INTEGER

lift_definition Zero :: INTEGER is "(True,0)" by auto

lift_definition Add :: "INTEGER \<Rightarrow> INTEGER \<Rightarrow> INTEGER" is add_integer
proof (goal_cases)
  case (1 bn1 bn2) 
  thus ?case
    by (cases "(bn1,bn2)" rule: add_integer.cases, auto)
qed

lemma "Add x Zero = x"
proof (transfer, goal_cases)
  case (1 bn)
  thus ?case by (cases "(bn, (True,0 :: nat))" rule: add_integer.cases, auto)
qed

lift_definition Negate :: "INTEGER \<Rightarrow> INTEGER" is
  "\<lambda> (b,n). if n = 0 then (b,0) else (\<not> b, n)" 
  by (auto split: prod.splits)

lemma "Negate Zero = Zero" by (transfer, auto)

lemma "Negate (Negate x) = x" 
  by (transfer, auto split: if_splits)

lemma "Add (Negate x) x = Zero" 
proof (transfer, goal_cases)
  case (1 bn)
  then obtain b n where bn: "bn = (b,n)" and cond: "n = 0 \<Longrightarrow> b" by auto
  show ?case unfolding bn split using cond
    by (cases b, auto)
qed
  


subsection \<open>Implementation of Binary Search Trees from Previous Week\<close>

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

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

inductive ordered :: "'a :: linorder tree \<Rightarrow> bool" where
  oLeaf: "ordered Leaf" 
| oNode: "ordered l \<Longrightarrow> ordered r 
  \<Longrightarrow> Ball (set_t l) (\<lambda> y. y < x)
  \<Longrightarrow> Ball (set_t r) (\<lambda> y. y > x)
  \<Longrightarrow> ordered (Node l x r)" 

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

lemma member_correct: "ordered t \<Longrightarrow> member x t = (x \<in> set_t t)" 
  by (induction rule: ordered.induct, auto)

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

lemma set_insert_t[simp]: "set_t (insert_t x t) = insert x (set_t t)" 
  by (induct t, auto)

lemma ordered_insert_t: "ordered t \<Longrightarrow> ordered (insert_t x t)" 
  by (induction rule: ordered.induct, auto intro!: oNode oLeaf)

fun delete_right :: "'a :: linorder tree \<Rightarrow> 'a tree \<times> 'a" where
  "delete_right (Node l x Leaf) = (l, x)" 
| "delete_right (Node l x r) = (case delete_right r of (r', y) \<Rightarrow> (Node l x r', y))" 

fun delete :: "'a :: linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "delete x Leaf = Leaf" 
| "delete x (Node l y r) = (if x < y then Node (delete x l) y r
      else if x > y then Node l y (delete x r)
      else if l = Leaf then r else
        case delete_right l of (l',z) \<Rightarrow> Node l' z r)" 

lemma delete_right: "ordered t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> delete_right t = (t', x) \<Longrightarrow>
  ordered t' \<and> set_t t = insert x (set_t t') \<and> Ball (set_t t') (\<lambda> y. y < x)" 
proof (induction t arbitrary: t' x rule: ordered.induct)
  case (oNode l r x t' y)
  thus ?case
  proof (cases r)
    case Leaf
    thus ?thesis using oNode by auto
  next
    case Node
    from oNode.prems[unfolded Node, simplified, folded Node]
    obtain r' where dr: "delete_right r = (r',y)" and t': "t' = Node l x r'" 
      by (cases "delete_right r", auto)
    from Node have r: "r \<noteq> Leaf" by auto
    from oNode.IH(2)[OF r dr] oNode.hyps
    show ?thesis unfolding t'
      by (auto intro: ordered.intros)
  qed
qed auto

lemma delete: "ordered t \<Longrightarrow> ordered (delete x t) \<and> set_t (delete x t) = set_t t - {x}" 
proof (induction t rule: ordered.induct)
  case (oNode l r y)
  consider (LT) "x < y" | (EQ) "x = y" "l = Leaf" | (EQ2) "x = y" "l \<noteq> Leaf" | (GT) "x > y" 
    by fastforce
  then show ?case
  proof cases
    case LT
    hence id: "delete x (Node l y r) = Node (delete x l) y r" by simp
    from oNode.IH(1) 
    show ?thesis using oNode.hyps LT unfolding id
      by (auto intro: ordered.intros)
  next
    case EQ
    then show ?thesis using oNode.hyps by auto
  next
    case EQ2
    obtain l' z where del: "delete_right l = (l',z)" by force
    from del EQ2 have id: "delete x (Node l y r) = Node l' z r" by auto
    from delete_right[OF _ EQ2(2) del] oNode.hyps
    have "ordered l' \<and> set_t l = insert z (set_t l') \<and> (\<forall>y\<in>set_t l'. y < z)" by auto
    with oNode.hyps EQ2 show ?thesis unfolding id
      by (auto intro!: ordered.intros)
  next
    case GT
    hence id: "delete x (Node l y r) = Node l y (delete x r)" by auto
    from oNode.IH(2) 
    show ?thesis using oNode.hyps GT unfolding id
      by (auto intro: ordered.intros)
  qed
qed (auto intro: ordered.intros)



subsection \<open>Example: Type of Ordered Binary Trees\<close>

(* (overloaded) is required since type-variable has class-constraint *)
typedef (overloaded) ('a :: linorder) otree = "{t :: 'a tree. ordered t}" 
  by (intro exI[of _ Leaf], auto intro: ordered.intros)
  
setup_lifting type_definition_otree

lift_definition empty_o :: "('a :: linorder) otree" is Leaf
  by (auto intro: ordered.intros)

lift_definition insert_o :: "'a :: linorder \<Rightarrow> 'a otree \<Rightarrow> 'a otree" is insert_t
  by (rule ordered_insert_t)

lift_definition delete_o :: "'a :: linorder \<Rightarrow> 'a otree \<Rightarrow> 'a otree" is delete 
  using delete by blast

lift_definition member_o :: "'a :: linorder \<Rightarrow> 'a otree \<Rightarrow> bool" is member .

lift_definition set_o :: "'a :: linorder otree \<Rightarrow> 'a set" is set_t .

lemma empty_o: "set_o empty_o = {}" 
  apply transfer 
  by auto

lemma insert_o: "set_o (insert_o x t) = insert x (set_o t)" 
  apply transfer
  using set_insert_t by auto

lemma delete_o: "set_o (delete_o x t) = (set_o t) - {x}" 
  apply transfer
  using delete by auto

lemma member_o: "member_o x t = (x \<in> set_o t)" 
  apply transfer
  using member_correct by auto

end