(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HeapList.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>Paths and Lists in the Heap\<close>
theory HeapList
imports Simpl_Heap
begin

text \<open>Adapted from 'HOL/Hoare/Heap.thy'.\<close>

subsection "Paths in The Heap"

primrec
 Path :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref \<Rightarrow>  ref list  \<Rightarrow> bool"
where
"Path x h y [] = (x = y)" |
"Path x h y (p#ps) = (x = p \<and> x \<noteq> Null \<and> Path (h x) h y ps)"

lemma Path_Null_iff [iff]: "Path Null h y xs  = (xs = [] \<and> y = Null)"
apply(case_tac xs)
apply fastforce
apply fastforce
done

lemma Path_not_Null_iff [simp]: "p\<noteq>Null \<Longrightarrow>
  Path p h q as = (as = [] \<and> q = p  \<or>  (\<exists>ps. as = p#ps \<and> Path (h p) h q ps ))"
apply(case_tac as)
apply fastforce
apply fastforce
done

lemma Path_append [simp]:
  "\<And>p. Path p f q (as@bs)  = (\<exists>y. Path p f y as \<and> Path y f q bs)"
by(induct as, simp+)

lemma notin_Path_update[simp]:
 "\<And>p. u \<notin> set ps \<Longrightarrow> Path p (f(u := v)) q ps  = Path p f q ps "
by(induct ps, simp, simp add:eq_sym_conv)

lemma Path_upd_same [simp]:
  "Path p (f(p:=p)) q qs =
      ((p=Null \<and> q=Null \<and> qs = []) \<or> (p\<noteq>Null \<and> q=p \<and> (\<forall>x\<in>set qs. x=p)))"
by (induct qs) auto

text \<open>@{thm[source] Path_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> Path p (f(p:=p)) q qs = X"} from looping, because of
@{thm[source] Path_not_Null_iff} and @{thm[source]fun_upd_apply}.
\<close>

lemma notin_Path_updateI [intro]:
 "\<lbrakk>Path p h q ps ; r \<notin> set ps\<rbrakk> \<Longrightarrow> Path p (h(r := y)) q ps "
by simp

lemma Path_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> Path p (f(new (set alloc) := x)) q ps  = Path p f q ps "
  by (rule notin_Path_update) fastforce

lemma Null_notin_Path [simp,intro]:
"\<And>p. Path p f q ps \<Longrightarrow> Null \<notin> set ps"
by(induct ps) auto

lemma Path_snoc:
 "\<lbrakk>Path p (f(a := q)) a as ; a\<noteq>Null\<rbrakk> \<Longrightarrow> Path p (f(a := q)) q (as @ [a])"
by simp

subsection "Lists on The Heap"

subsubsection "Relational Abstraction"

definition
 List :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list \<Rightarrow> bool" where
"List p h ps = Path p h Null ps "

lemma List_empty [simp]: "List p h [] = (p = Null)"
by(simp add:List_def)

lemma List_cons [simp]: "List p h (a#ps) = (p = a \<and> p\<noteq>Null \<and> List (h p) h ps)"
by(simp add:List_def)

lemma List_Null [simp]: "List Null h ps = (ps = [])"
by(case_tac ps, simp_all)

lemma List_not_Null [simp]: "p\<noteq>Null \<Longrightarrow>
  List p h as = (\<exists>ps. as = p#ps \<and> List (h p) h ps)"
by(case_tac as, simp_all, fast)

lemma Null_notin_List [simp,intro]: "\<And>p. List p h ps \<Longrightarrow> Null \<notin> set ps"
by (simp add : List_def)

lemma List_upd_same_lemma: "\<And>p.  p \<noteq> Null \<Longrightarrow> \<not> List p (h(p := p)) ps"
apply (induct ps)
apply  simp
apply (simp (no_asm_simp) del: fun_upd_apply)
apply (simp (no_asm_simp) only: fun_upd_apply refl if_True)
apply blast
done

lemma List_upd_same [simp]: "List p (h(p:=p)) ps = (p = Null \<and> ps = [])"
apply (cases "p=Null")
apply  simp
apply (fast dest: List_upd_same_lemma)
done

text \<open>@{thm[source] List_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> List p (h(p:=p)) as = X"} from looping, because of
@{thm[source] List_not_Null} and @{thm[source] fun_upd_apply}.
\<close>

lemma  List_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> List p (h(new (set alloc) := x)) ps = List p h ps"
by (rule notin_List_update) fastforce

lemma List_updateI [intro]:
 "\<lbrakk>List p h ps; q \<notin> set ps\<rbrakk> \<Longrightarrow> List p (h(q := y)) ps"
by simp

lemma List_unique: "\<And>p bs. List p h as \<Longrightarrow> List p h bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List p h as \<Longrightarrow> \<exists>!as. List p h as"
by(blast intro:List_unique)

lemma List_app: "\<And>p. List p h (as@bs) = (\<exists>y. Path p h y as \<and> List y h bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List (h p) h ps \<Longrightarrow> p \<notin> set ps"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>p. List p h ps \<Longrightarrow> distinct ps"
apply(induct ps, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma heap_eq_List_eq:
  "\<And>p. \<forall>x \<in> set ps. h x = g x \<Longrightarrow> List p h ps = List p g ps"
  by (induct ps) auto

lemma heap_eq_ListI:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. h x = g x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

lemma heap_eq_ListI1:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. g x = h x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

text \<open>The following lemmata are usefull for the simplifier to instantiate
bound variables in the assumptions resp. conclusion, using the uniqueness
of the List predicate\<close>

lemma conj_impl_simp: "(P \<and> Q \<longrightarrow> K) = (P \<longrightarrow> Q \<longrightarrow> K)"
by auto

lemma  List_unique_all_impl_simp [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. List p h ps \<longrightarrow> P ps) = P ps"
by (auto dest: List_unique)

(*
lemma  List_unique_all_impl_simp1 [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. Q ps \<longrightarrow> List p h ps \<longrightarrow> P ps) = Q ps \<longrightarrow> P ps"
by (auto dest: List_unique)
*)
lemma List_unique_ex_conj_simp [simp]:
"List p h ps \<Longrightarrow> (\<exists>ps. List p h ps \<and> P ps) = P ps"
by (auto dest: List_unique)

subsection "Functional abstraction"

definition
 islist :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool" where
"islist p h = (\<exists>ps. List p h ps)"

definition
 list :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list" where
"list p h = (THE ps. List p h ps)"

lemma List_conv_islist_list: "List p h ps = (islist p h \<and> ps = list p h)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst the1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply (clarify)
apply (rule theI)
apply  assumption
by (rule List_unique)

lemma List_islist [intro]:
  "List p h ps \<Longrightarrow> islist p h"
  apply (simp add: List_conv_islist_list)
  done

lemma List_list:
  "List p h ps \<Longrightarrow> list p h = ps"
  apply (simp only: List_conv_islist_list)
  done

lemma [simp]: "p\<noteq>Null \<Longrightarrow> islist (h p) h = islist p h"
by(simp add:islist_def)

lemma [simp]: "list Null h = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk>islist (h p) h; p\<noteq>Null \<rbrakk> \<Longrightarrow> list p h = p # list (h p) h"
apply(insert List_not_Null[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist (h p) h \<Longrightarrow> p \<notin> set(list (h p) h)"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> list p (h(y := q)) = list p h"
apply(drule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> islist p (h(y := q))"
apply(frule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma list_distinct[simp]: "islist p h \<Longrightarrow> distinct (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

lemma Null_notin_list [simp,intro]: "islist p h \<Longrightarrow> Null \<notin> set (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

end


theory PriorityQueue
imports Main
begin

subsection {* Generic Lemmas *}

lemma tl_set:
  "distinct q \<Longrightarrow> set (tl q) = set q - {hd q}"
  by (cases q) simp_all

subsection {* Type of abstract priority queues *}

typedef (overloaded) ('a, 'b::linorder) pri_queue =
  "{xs :: ('a \<times> 'b) list. distinct (map fst xs) \<and> sorted (map snd xs)}"
  morphisms alist_of Abs_pq
proof -
  have "[] \<in> ?pri_queue" by simp
  then show ?thesis by blast
qed

lemma alist_of_Abs_pq:
  assumes "distinct (map fst xs)"
    and "sorted (map snd xs)"
  shows "alist_of (Abs_pq xs) = xs"
  by (rule Abs_pq_inverse) (simp add: assms)

lemma [code abstype]:
  "Abs_pq (alist_of q) = q"
  by (fact alist_of_inverse)

lemma distinct_fst_alist_of [simp]:
  "distinct (map fst (alist_of q))"
  using alist_of [of q] by simp

lemma distinct_alist_of [simp]:
  "distinct (alist_of q)"
  using distinct_fst_alist_of [of q] by (simp add: distinct_map)

lemma sorted_snd_alist_of [simp]:
  "sorted (map snd (alist_of q))"
  using alist_of [of q] by simp

lemma alist_of_eqI:
  "alist_of p = alist_of q \<Longrightarrow> p = q"
proof -
  assume "alist_of p = alist_of q"
  then have "Abs_pq (alist_of p) = Abs_pq (alist_of q)" by simp
  thus "p = q" by (simp add: alist_of_inverse)
qed

definition "values" :: "('a, 'b::linorder) pri_queue \<Rightarrow> 'a list" ("|(_)|") where
  "values q = map fst (alist_of q)"

definition priorities :: "('a, 'b::linorder) pri_queue \<Rightarrow> 'b list" ("\<parallel>(_)\<parallel>") where
  "priorities q = map snd (alist_of q)"

lemma values_set:
  "set |q| = fst ` set (alist_of q)"
  by (simp add: values_def)

lemma priorities_set:
  "set \<parallel>q\<parallel> = snd ` set (alist_of q)"
  by (simp add: priorities_def)

definition is_empty :: "('a, 'b::linorder) pri_queue \<Rightarrow> bool" where
  "is_empty q \<equiv> alist_of q = []"

definition priority :: "('a, 'b::linorder) pri_queue \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "priority q \<equiv> map_of (alist_of q)"

definition min :: "('a, 'b::linorder) pri_queue \<Rightarrow> 'a" where
  "min q \<equiv> fst (hd (alist_of q))"

definition empty :: "('a, 'b::linorder) pri_queue" where
  "empty \<equiv> Abs_pq []"

lemma is_empty_alist_of [dest]:
  "is_empty q \<Longrightarrow> alist_of q = []"
  by (simp add: is_empty_def)

lemma not_is_empty_alist_of [dest]:
  "\<not> is_empty q \<Longrightarrow> alist_of q \<noteq> []"
  by (simp add: is_empty_def)

lemma alist_of_empty [simp, code abstract]:
  "alist_of empty = []"
  by (simp add: empty_def Abs_pq_inverse)

lemma values_empty [simp]:
  "|empty| = []"
  by (simp add: values_def)

lemma priorities_empty [simp]:
  "\<parallel>empty\<parallel> = []"
  by (simp add: priorities_def)

lemma values_empty_nothing [simp]:
  "\<forall>k. k \<notin> set |empty|"
  by (simp add: values_def)

lemma is_empty_empty:
  "is_empty q \<longleftrightarrow> q = empty"
proof (rule iffI)
  assume "is_empty q"
  then have "alist_of q = []" by (simp add: is_empty_alist_of)
  then have "Abs_pq (alist_of q) = Abs_pq []" by simp
  then show "q = empty" by (simp add: empty_def alist_of_inverse)
qed (simp add: is_empty_def)

lemma is_empty_empty_simp [simp]:
  "is_empty empty"
by (simp add: is_empty_empty)

lemma map_snd_alist_of:
  "map (the \<circ> priority q) (values q) = map snd (alist_of q)"
  by (auto simp add: values_def priority_def)

lemma image_snd_alist_of:
  "the ` priority q ` set (values q) = snd ` set (alist_of q)"
proof -
  from map_snd_alist_of [of q]
    have "set (map (the \<circ> priority q) (values q)) = set (map snd (alist_of q))"
      by (simp only:)
  then show ?thesis by (simp add: image_comp)
qed

lemma Min_snd_alist_of:
  assumes "\<not> is_empty q"
  shows "Min (snd ` set (alist_of q)) = snd (hd (alist_of q))"
proof -
  from assms obtain ps p where q: "map snd (alist_of q) = p # ps"
    by (cases "map snd (alist_of q)") auto
  then have "hd (map snd (alist_of q)) = p" by simp
  with assms have p: "snd (hd (alist_of q)) = p" by (auto simp add: hd_map)
  have "sorted (map snd (alist_of q))" by simp
  with q have "sorted (p # ps)" by simp
  then have "\<forall>p'\<in>set ps. p' \<ge> p" by simp
  then have "Min (set (p # ps)) = p" by (auto intro: Min_eqI)
  with p q have "Min (set (map snd (alist_of q))) = snd (hd (alist_of q))"
    by simp
  then show ?thesis by simp
qed

lemma priority_fst:
  assumes "xp \<in> set (alist_of q)"
  shows "priority q (fst xp) = Some (snd xp)"
  using assms by (simp add: priority_def)

lemma priority_Min:
  assumes "\<not> is_empty q"
  shows "priority q (min q) = Some (Min (the ` priority q ` set (values q)))"
  using assms
    by (auto simp add: min_def image_snd_alist_of Min_snd_alist_of priority_fst)

lemma priority_Min_priorities:
  assumes "\<not> is_empty q"
  shows "priority q (min q) = Some (Min (set \<parallel>q\<parallel>))"
  using assms
    by (simp add: priority_Min image_snd_alist_of priorities_def)

definition push :: "'a \<Rightarrow> 'b::linorder \<Rightarrow> ('a, 'b) pri_queue \<Rightarrow> ('a, 'b) pri_queue" where
  "push k p q \<equiv> Abs_pq (if k \<notin> set (values q)
           then insort_key snd (k, p) (alist_of q)
           else alist_of q)"

lemma Min_snd_hd:
  "q \<noteq> [] \<Longrightarrow> sorted (map snd q) \<Longrightarrow> Min (snd ` set q) = snd (hd q)"
proof (induct q)
  case (Cons x xs) then show ?case by (cases xs) (auto simp add: ord_class.min_def)
qed simp

lemma hd_construct:
  assumes "\<not> is_empty q"
  shows "hd (alist_of q) = (min q, the (priority q (min q)))"
proof -
  from assms have "the (priority q (min q)) = snd (hd (alist_of q))"
    using Min_snd_hd [of "alist_of q"]
      by (auto simp add: priority_Min_priorities priorities_def)
  then show ?thesis by (simp add: min_def)
qed

lemma not_in_first_image:
  "x \<notin> fst ` s \<Longrightarrow> (x, p) \<notin> s"
  by (auto simp add: image_def)

lemma alist_of_push [simp, code abstract]:
  "alist_of (push k p q) =
    (if k \<notin> set (values q) then insort_key snd (k, p) (alist_of q) else alist_of q)"
  using distinct_fst_alist_of [of q]
    by (auto simp add: distinct_map set_insort_key distinct_insort not_in_first_image
      push_def values_def sorted_insort_key intro: alist_of_Abs_pq)

lemma push_values [simp]:
  "set |push k p q| = set |q| \<union> {k}"
  by (auto simp add: values_def set_insort_key)

lemma push_priorities [simp]:
  "k \<notin> set |q| \<Longrightarrow> set \<parallel>push k p q\<parallel> = set \<parallel>q\<parallel> \<union> {p}"
  "k \<in> set |q| \<Longrightarrow> set \<parallel>push k p q\<parallel> = set \<parallel>q\<parallel>"
  by (auto simp add: priorities_def set_insort_key)

lemma "k \<notin> set |q| \<Longrightarrow> priority (push k p q) k = Some p"
  apply(simp add:priority_def)
  by (metis alist_of_push fst_conv insertCI priority_def priority_fst set_insort_key snd_conv)

lemma "k \<in> set |q| \<Longrightarrow> priority (push k p q) k = priority q k"
  by (simp add:priority_def)

lemma not_is_empty_push [simp]:
  "\<not> is_empty (push k p q)"
  by (auto simp add: values_def is_empty_def)

lemma push_commute:
  assumes "a \<noteq> b" and "v \<noteq> w"
  shows "push w b (push v a q) = push v a (push w b q)"
  using assms by (auto intro!: alist_of_eqI insort_key_left_comm)

definition remove_min :: "('a, 'b::linorder) pri_queue \<Rightarrow> ('a, 'b::linorder) pri_queue" where
  "remove_min q \<equiv> (if is_empty q then empty else Abs_pq (tl (alist_of q)))"

lemma alift_of_remove_min_if [code abstract]:
  "alist_of (remove_min q) = (if is_empty q then [] else tl (alist_of q))"
  by (auto simp add: remove_min_def map_tl sorted_tl distinct_tl alist_of_Abs_pq)

lemma remove_min_empty [simp]:
  "is_empty q \<Longrightarrow> remove_min q = empty"
  by (simp add: remove_min_def)

lemma alist_of_remove_min [simp]:
  "\<not> is_empty q \<Longrightarrow> alist_of (remove_min q) = tl (alist_of q)"
  by (simp add: alift_of_remove_min_if)

lemma values_remove_min [simp]:
  "\<not> is_empty q \<Longrightarrow> values (remove_min q) = tl (values q)"
  by (simp add: values_def map_tl)

lemma set_alist_of_remove_min:
  "\<not> is_empty q \<Longrightarrow> set (alist_of (remove_min q)) =
    set (alist_of q) - {(min q, the (priority q (min q)))}"
  by (simp add: tl_set hd_construct)

definition pop :: "('a, 'b::linorder) pri_queue \<Rightarrow> ('a \<times> ('a, 'b) pri_queue) option" where
  "pop q = (if is_empty q then None else Some (min q, remove_min q))"

lemma "\<lbrakk> \<not> is_empty q; v \<in> set |q| \<rbrakk>
   \<Longrightarrow> the (priority q (min q)) \<le> the (priority q v)"
  apply(simp add:min_def priority_def is_empty_def values_def)
  apply auto
  apply(cases "alist_of q") apply simp
  apply simp
  using alist_of[of q] mem_Collect_eq apply simp
  apply(case_tac "(v, b) = a") apply auto[1]
  apply simp
  by (metis snd_conv)

lemma "pop q = Some (v, q1) \<Longrightarrow> v = min q"
  apply(simp add:pop_def) apply(cases "is_empty q")
    apply simp
  by(simp add:min_def is_empty_def remove_min_def)

lemma "pop q = Some (v, q1) \<Longrightarrow> v \<notin> set |q1|"
  apply(simp add:pop_def) apply(cases "is_empty q")
    apply simp
  apply(simp add:min_def is_empty_def remove_min_def values_def)
  apply(cases "alist_of q") apply simp
  using alist_of_Abs_pq alist_of[of q] mem_Collect_eq apply simp
  apply(subgoal_tac "sorted (map snd list)")
    prefer 2 apply simp
  apply(subgoal_tac "alist_of (Abs_pq list) = list")
    by auto

lemma pop_simps [simp]:
  "is_empty q \<Longrightarrow> pop q = None"
  "\<not> is_empty q \<Longrightarrow> pop q = Some (min q, remove_min q)"
  by (simp_all add: pop_def)

hide_const (open) Abs_pq alist_of "values" priority empty is_empty push min pop

no_notation
  "PriorityQueue.values" ("|(_)|")
  and "PriorityQueue.priorities" ("\<parallel>(_)\<parallel>")

value "PriorityQueue.values (PriorityQueue.push (4::int) (0::nat) PriorityQueue.empty)"

end


section \<open>\isaheader{Set Interface}\<close>
theory Intf_Set
imports "../../../Refine_Monadic/Refine_Monadic"
begin
consts i_set :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of set_rel i_set]

definition [simp]: "op_set_delete x s \<equiv> s - {x}"
definition [simp]: "op_set_isEmpty s \<equiv> s = {}"
definition [simp]: "op_set_isSng s \<equiv> card s = 1"
definition [simp]: "op_set_size_abort m s \<equiv> min m (card s)"
definition [simp]: "op_set_disjoint a b \<equiv> a\<inter>b={}"
definition [simp]: "op_set_filter P s \<equiv> {x\<in>s. P x}"
definition [simp]: "op_set_sel P s \<equiv> SPEC (\<lambda>x. x\<in>s \<and> P x)"
definition [simp]: "op_set_pick s \<equiv> SPEC (\<lambda>x. x\<in>s)"
definition [simp]: "op_set_to_sorted_list ordR s
  \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_wrt ordR l)"
definition [simp]: "op_set_to_list s \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l)"
definition [simp]: "op_set_cart x y \<equiv> x \<times> y"

(* TODO: Do op_set_pick_remove (like op_map_pick_remove) *)

context begin interpretation autoref_syn .

  "s = {} \<equiv> op_set_isEmpty$s"
  "{}=s \<equiv> op_set_isEmpty$s"

  "card s = 1 \<equiv> op_set_isSng$s"
  "\<exists>x. s={x} \<equiv> op_set_isSng$s"
  "\<exists>x. {x}=s \<equiv> op_set_isSng$s"

  "min m (card s) \<equiv> op_set_size_abort$m$s"
  "min (card s) m \<equiv> op_set_size_abort$m$s"

  "a\<inter>b={} \<equiv> op_set_disjoint$a$b"

  "{x\<in>s. P x} \<equiv> op_set_filter$P$s"

  "SPEC (\<lambda>x. x\<in>s \<and> P x) \<equiv> op_set_sel$P$s"
  "SPEC (\<lambda>x. P x \<and> x\<in>s) \<equiv> op_set_sel$P$s"

  "SPEC (\<lambda>x. x\<in>s) \<equiv> op_set_pick$s"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "a \<times> b \<equiv> op_set_cart a b"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "SPEC (\<lambda>(u,v). (u,v)\<in>s) \<equiv> op_set_pick$s"
  "SPEC (\<lambda>(u,v). P u v \<and> (u,v)\<in>s) \<equiv> op_set_sel$(case_prod P)$s"
  "SPEC (\<lambda>(u,v). (u,v)\<in>s \<and> P u v) \<equiv> op_set_sel$(case_prod P)$s"
  by (auto intro!: eq_reflection)

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. set l = s \<and> sorted_wrt ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_wrt ordR l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> distinct l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> set l = s \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. s = set l \<and> sorted_wrt ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_wrt ordR l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> distinct l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> s = set l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. set l = s \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s) \<equiv> op_set_to_list$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l) \<equiv> op_set_to_list$s"
    by (auto intro!: eq_reflection)

end

lemma [autoref_itype]:
  "{} ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "insert ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_delete ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(\<in>) ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isEmpty ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isSng ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "(\<union>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(\<inter>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "((-) :: 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "((=) :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "(\<subseteq>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_disjoint ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "Ball ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "Bex ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_set_filter ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "card ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "op_set_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "set ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_sel ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "op_set_pick ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Sigma ::\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (Ia \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i \<langle>\<langle>Ia,Ib\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_set"
  "(`) ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set"
  "op_set_cart ::\<^sub>i \<langle>Ix\<rangle>\<^sub>iIsx \<rightarrow>\<^sub>i \<langle>Iy\<rangle>\<^sub>iIsy \<rightarrow>\<^sub>i \<langle>\<langle>Ix, Iy\<rangle>\<^sub>ii_prod\<rangle>\<^sub>iIsp"
  "Union ::\<^sub>i \<langle>\<langle>I\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "atLeastLessThan ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>i_nat\<rangle>\<^sub>ii_set"
  by simp_all

lemma hom_set1[autoref_hom]:
  "CONSTRAINT {} (\<langle>R\<rangle>Rs)"
  "CONSTRAINT insert (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (\<in>) (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT (\<union>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (\<inter>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (-) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (=) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT (\<subseteq>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT Ball (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT Bex (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT card (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT set (\<langle>R\<rangle>Rl\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (`) ((Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>Rs\<rightarrow>\<langle>Rb\<rangle>Rs)"
  "CONSTRAINT Union (\<langle>\<langle>R\<rangle>Ri\<rangle>Ro \<rightarrow> \<langle>R\<rangle>Ri)"
  by simp_all

lemma hom_set2[autoref_hom]:
  "CONSTRAINT op_set_delete (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_isEmpty (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_isSng (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_size_abort (Id\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_disjoint (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_filter ((R\<rightarrow>Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_sel ((R \<rightarrow> Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  "CONSTRAINT op_set_pick (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  by simp_all

lemma hom_set_Sigma[autoref_hom]:
  "CONSTRAINT Sigma (\<langle>Ra\<rangle>Rs \<rightarrow> (Ra \<rightarrow> \<langle>Rb\<rangle>Rs) \<rightarrow> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>Rs2)"
  by simp_all

definition "finite_set_rel R \<equiv> Range R \<subseteq> Collect (finite)"

lemma finite_set_rel_trigger: "finite_set_rel R \<Longrightarrow> finite_set_rel R" .

declaration \<open>Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_set_rel_trigger}\<close>

end


theory list_return_2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun return :: "'a => 'a list" where
"return x = Cons2 x (Nil2)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun bind :: "'a list => ('a => 'b list) => 'b list" where
"bind (Nil2) y = Nil2"
| "bind (Cons2 z xs) y = append (y z) (bind xs y)"

(*hipster return append bind *)

theorem x0 :
  "!! (xs :: 'a list) . (bind xs (% (x :: 'a) => return x)) = xs"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Misc_Luby_Rackoff
  imports Compressed_Oracles.CO_Invariants
begin

definition cnot :: \<open>('a::ab_group_add \<times> 'a) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('a \<times> 'a) ell2\<close> where
  \<open>cnot = classical_operator (Some o (\<lambda>(x,y). (x, y+x)))\<close>

lemma cnot_apply: \<open>cnot *\<^sub>V ket (x,y) = ket (x, y+x)\<close>
  apply (simp add: cnot_def)
  apply (subst classical_operator_ket)
   apply (rule classical_operator_exists_inj)
  by (auto intro: injI)

lemma unitary_cnot[simp]: \<open>unitary cnot\<close>
  by (auto simp: cnot_def intro!: unitary_classical_operator o_bij[where g=\<open>\<lambda>(x,y). (x, y-x)\<close>])

lemma norm_cnot[simp]: \<open>norm cnot = 1\<close>
  using norm_isometry unitary_cnot unitary_isometry by blast

fun the_default where
  \<open>the_default d (Some x) = x\<close>
| \<open>the_default d None = d\<close>

lemma sum_of_bool1: \<open>(\<Sum>x::_::finite|P x. of_bool (f x) *\<^sub>C g x) = (\<Sum>x|P x \<and> f x. g x)\<close>
  for g :: \<open>_ \<Rightarrow> 'a::complex_vector\<close>
  by (rule sum.mono_neutral_cong_right, auto)

lemma sum_of_bool2: \<open>(\<Sum>(x::_::finite)\<in>P. of_bool (f x) *\<^sub>C g x) = (\<Sum>x|x\<in>P \<and> f x. g x)\<close>
  for g :: \<open>_ \<Rightarrow> 'a::complex_vector\<close>
  by (rule sum.mono_neutral_cong_right, auto)

lemma ket_eq_scaleC_ket[simp]: \<open>(ket x = c *\<^sub>C ket y) \<longleftrightarrow> (c = 1 \<and> x = y)\<close>
  by (metis cinner_scaleC_right mult_cancel_left1 orthogonal_ket scaleC_cancel_right scaleC_one)

lemma ket_cinner': \<open>cinner (ket x) (ket y) = of_bool (x=y)\<close>
  by (simp add: cinner_ket)

lemma tensor_ell2_ket_split: \<open>ket xy = ket (fst xy) \<otimes>\<^sub>s ket (snd xy)\<close>
  by auto

lemma explicit_pair:
  fixes f g \<alpha> F G U
  assumes [simp]: \<open>compatible F G\<close>
  assumes U: \<open>\<And>x y. U *\<^sub>V ket (x,y) = of_bool (h x y) *\<^sub>C ket (f x y, g x y)\<close>
  shows \<open>(F;G) U *\<^sub>V \<psi> = (\<Sum>(x,y)|h x y. F (butterket (f x y) x)
               *\<^sub>V (G (butterket (g x y) y) *\<^sub>V \<psi>))\<close>
proof -
  have \<open>U *\<^sub>V ket (x,y) = (\<Sum>(x,y)\<in>UNIV. of_bool (h x y) *\<^sub>C butterket (f x y, g x y) (x, y)) *\<^sub>V ket (x,y)\<close> for x y
    apply (subst U)
    apply (auto simp: cblinfun.sum_left case_prod_beta ket_cinner' split del: split_of_bool)
    apply (subst sum_single[where i=\<open>(x,y)\<close>])
    by auto
  then have U2: \<open>U = (\<Sum>(x,y)\<in>UNIV. of_bool (h x y) *\<^sub>C butterket (f x y, g x y) (x, y))\<close>
    apply (rule_tac equal_ket, case_tac x) by simp
  show ?thesis
    by (simp add: U2 complex_vector.linear_sum clinear.scaleC tensor_ell2_ket_split
        register_pair_apply sum_of_bool2 cblinfun.sum_left case_prod_unfold
        flip: tensor_butterfly cinner_ket tensor_ell2_ket)
qed

lemma standard_query1_apply: \<open>standard_query1 *\<^sub>V ket (x, d) = ket (x + the_default 0 d, d)\<close>
  apply (cases d) by auto

lemma function_at_selfbutterket_apply: \<open>function_at x (selfbutterket y) *\<^sub>V ket h = of_bool (h x = y) *\<^sub>C ket h\<close>
  apply (simp add: function_at_def Let_def sandwich_def classical_operator_ket classical_operator_adjoint
      bij_fix_punctured_function bij_is_inj bij_is_surj inv_map_total Fst_def tensor_ell2_ket_split
      tensor_op_ell2 tensor_ell2_scaleC1 ket_cinner'
      flip: tensor_ell2_ket
      split del: split_of_bool)
  apply (simp add: classical_operator_ket tensor_op_ell2 tensor_ell2_scaleC1
      split del: split_of_bool)
  apply transfer
  apply (auto intro!: ext simp: o_def)
  apply (metis transpose_apply_second transpose_involutory)
  by (metis transpose_apply_second transpose_involutory)

lemma l4: \<open>(Fst;Snd \<circ> function_at x) standard_query1 *\<^sub>V ket (y, h) = ket (y + the_default 0 (h x), h)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (simp add: standard_query1_apply split del: split_of_bool)
  apply (simp add: complex_vector.linear_sum clinear.scaleC tensor_ell2_ket_split
        register_pair_apply sum_of_bool2 cblinfun.sum_left case_prod_unfold
        Fst_def tensor_op_ell2 ket_cinner' function_at_selfbutterket_apply
        flip: tensor_butterfly cinner_ket tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(y, h x)\<close>])
  by auto

lemma standard_query_apply:
  \<open>standard_query (ket (x,y,d)) = ket (x, y + the_default 0 (d x), d)\<close>
  by (simp add: standard_query_def l4)

lemma standard_query_apply':
  \<open>standard_query (ket xyd) = ket
       ((case xyd of (x,y,d) \<Rightarrow> x),
        (case xyd of (x,y,d) \<Rightarrow> y + the_default 0 (d x)),
        (case xyd of (x,y,d) \<Rightarrow> d))\<close>
  by (cases xyd, simp add: standard_query_apply)

lemma compress_square: \<open>compress o\<^sub>C\<^sub>L compress = id_cblinfun\<close>
  by (simp add: compress_def apply_every_mult compress1_square)

end


(* The definitions for a challenge suggested by Adam Chlipala *)

theory Compile
imports "HOL-Nominal.Nominal"
begin

atom_decl name

nominal_datatype data =
    DNat
  | DProd "data" "data"
  | DSum "data" "data"

nominal_datatype ty =
    Data "data"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
  Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"
  | Const "nat"
  | Pr "trm" "trm"
  | Fst "trm"
  | Snd "trm"
  | InL "trm"
  | InR "trm"
  | Case "trm" "\<guillemotleft>name\<guillemotright>trm" "\<guillemotleft>name\<guillemotright>trm"
          ("Case _ of inl _ \<rightarrow> _ | inr _ \<rightarrow> _" [100,100,100,100,100] 100)

nominal_datatype dataI = OneI | NatI

nominal_datatype tyI =
    DataI "dataI"
  | ArrowI "tyI" "tyI" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trmI =
    IVar "name"
  | ILam "\<guillemotleft>name\<guillemotright>trmI" ("ILam [_]._" [100,100] 100)
  | IApp "trmI" "trmI"
  | IUnit
  | INat "nat"
  | ISucc "trmI"
  | IAss "trmI" "trmI" ("_\<mapsto>_" [100,100] 100)
  | IRef "trmI"
  | ISeq "trmI" "trmI" ("_;;_" [100,100] 100)
  | Iif "trmI" "trmI" "trmI"

text \<open>valid contexts\<close>

inductive
  valid :: "(name\<times>'a::pt_name) list \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)" (* maybe dom of \<Gamma> *)

text \<open>typing judgements for trms\<close>

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> \<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) \<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : Data(DNat)"
| t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : Data(\<sigma>1); \<Gamma> \<turnstile> e2 : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Pr e1 e2 : Data (DProd \<sigma>1 \<sigma>2)"
| t5[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Fst e : Data(\<sigma>1)"
| t6[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Snd e : Data(\<sigma>2)"
| t7[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>1)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InL e : Data(DSum \<sigma>1 \<sigma>2)"
| t8[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InR e : Data(DSum \<sigma>1 \<sigma>2)"
| t9[intro]: "\<lbrakk>x1\<sharp>\<Gamma>; x2\<sharp>\<Gamma>; \<Gamma> \<turnstile> e: Data(DSum \<sigma>1 \<sigma>2);
             ((x1,Data(\<sigma>1))#\<Gamma>) \<turnstile> e1 : \<tau>; ((x2,Data(\<sigma>2))#\<Gamma>) \<turnstile> e2 : \<tau>\<rbrakk>
             \<Longrightarrow> \<Gamma> \<turnstile> (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) : \<tau>"

text \<open>typing judgements for Itrms\<close>

inductive
  Ityping :: "(name\<times>tyI) list\<Rightarrow>trmI\<Rightarrow>tyI\<Rightarrow>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IVar x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> I\<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IApp e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) I\<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> ILam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> IUnit : DataI(OneI)"
| t4[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> INat(n) : DataI(NatI)"
| t5[intro]: "\<Gamma> I\<turnstile> e : DataI(NatI) \<Longrightarrow> \<Gamma> I\<turnstile> ISucc(e) : DataI(NatI)"
| t6[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> IRef e : DataI (NatI)"
| t7[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1\<mapsto>e2 : DataI(OneI)"
| t8[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1;;e2 : \<tau>"
| t9[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e: DataI(NatI); \<Gamma> I\<turnstile> e1 : \<tau>; \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> Iif e e1 e2 : \<tau>"

text \<open>capture-avoiding substitution\<close>

class subst =
  fixes subst :: "'a \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> 'a"  ("_[_::=_]" [100,100,100] 100)

instantiation trm :: subst
begin

nominal_primrec subst_trm
where
  "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
| "(Const n)[y::=t'] = Const n"
| "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])"
| "(Fst e)[y::=t'] = Fst (e[y::=t'])"
| "(Snd e)[y::=t'] = Snd (e[y::=t'])"
| "(InL e)[y::=t'] = InL (e[y::=t'])"
| "(InR e)[y::=t'] = InR (e[y::=t'])"
| "\<lbrakk>z\<noteq>x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'\<rbrakk> \<Longrightarrow>
     (Case e of inl x \<rightarrow> e1 | inr z \<rightarrow> e2)[y::=t'] =
       (Case (e[y::=t']) of inl x \<rightarrow> (e1[y::=t']) | inr z \<rightarrow> (e2[y::=t']))"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

instantiation trmI :: subst
begin

nominal_primrec subst_trmI
where
  "(IVar x)[y::=t'] = (if x=y then t' else (IVar x))"
| "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])"
| "(INat n)[y::=t'] = INat n"
| "(IUnit)[y::=t'] = IUnit"
| "(ISucc e)[y::=t'] = ISucc (e[y::=t'])"
| "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])"
| "(IRef e)[y::=t'] = IRef (e[y::=t'])"
| "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])"
| "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

lemma Isubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "pi\<bullet>(t1[x::=t2]) = ((pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)])"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (simp_all add: subst_trmI.simps eqvts fresh_bij)
  done

lemma Isubst_supp:
  fixes t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "((supp (t1[x::=t2]))::name set) \<subseteq> (supp t2)\<union>((supp t1)-{x})"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (auto simp add: subst_trmI.simps trmI.supp supp_atm abs_supp supp_nat)
  apply blast+
  done

lemma Isubst_fresh:
  fixes x::"name"
  and   y::"name"
  and   t1::"trmI"
  and   t2::"trmI"
  assumes a: "x\<sharp>[y].t1" "x\<sharp>t2"
  shows "x\<sharp>(t1[y::=t2])"
using a
apply(auto simp add: fresh_def Isubst_supp)
apply(drule rev_subsetD)
apply(rule Isubst_supp)
apply(simp add: abs_supp)
done

text \<open>big-step evaluation for trms\<close>

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b0[intro]: "Lam [x].e \<Down> Lam [x].e"
| b1[intro]: "\<lbrakk>e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'\<rbrakk> \<Longrightarrow> App e1 e2 \<Down> e'"
| b2[intro]: "Const n \<Down> Const n"
| b3[intro]: "\<lbrakk>e1\<Down>e1'; e2\<Down>e2'\<rbrakk> \<Longrightarrow> Pr e1 e2 \<Down> Pr e1' e2'"
| b4[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Fst e\<Down>e1"
| b5[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Snd e\<Down>e2"
| b6[intro]: "e\<Down>e' \<Longrightarrow> InL e \<Down> InL e'"
| b7[intro]: "e\<Down>e' \<Longrightarrow> InR e \<Down> InR e'"
| b8[intro]: "\<lbrakk>e\<Down>InL e'; e1[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
| b9[intro]: "\<lbrakk>e\<Down>InR e'; e2[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"

inductive
  Ibig :: "((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>bool" ("_ I\<Down> _" [80,80] 80)
where
  m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)"
| m1[intro]: "\<lbrakk>(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)\<rbrakk>
            \<Longrightarrow> (m,IApp e1 e2) I\<Down> (m''',e4)"
| m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)"
| m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))"
| m4[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,ISucc(e))I\<Down>(m',INat(n+1))"
| m5[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,IRef(e))I\<Down>(m',INat(m' n))"
| m6[intro]: "\<lbrakk>(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))\<rbrakk> \<Longrightarrow> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)"
| m7[intro]: "\<lbrakk>(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,e1;;e2)I\<Down>(m'',e)"
| m8[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(n)); n\<noteq>0; (m',e1)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
| m9[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"

text \<open>Translation functions\<close>

nominal_primrec
  trans :: "trm \<Rightarrow> trmI"
where
  "trans (Var x) = (IVar x)"
| "trans (App e1 e2) = IApp (trans e1) (trans e2)"
| "trans (Lam [x].e) = ILam [x].(trans e)"
| "trans (Const n) = INat n"
| "trans (Pr e1 e2) =
       (let limit = IRef(INat 0) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        (((ISucc limit)\<mapsto>v1);;(ISucc(ISucc limit)\<mapsto>v2));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (Fst e) = IRef (ISucc (trans e))"
| "trans (Snd e) = IRef (ISucc (ISucc (trans e)))"
| "trans (InL e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(0));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (InR e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(1));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "\<lbrakk>x2\<noteq>x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1\<rbrakk> \<Longrightarrow>
   trans (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) =
       (let v = (trans e) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        Iif (IRef (ISucc v)) (v2[x2::=IRef (ISucc (ISucc v))]) (v1[x1::=IRef (ISucc (ISucc v))]))"
  apply(finite_guess add: Let_def)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh Isubst_fresh)+
  apply(fresh_guess add: Let_def)+
  done

nominal_primrec
  trans_type :: "ty \<Rightarrow> tyI"
where
  "trans_type (Data \<sigma>) = DataI(NatI)"
| "trans_type (\<tau>1\<rightarrow>\<tau>2) = (trans_type \<tau>1)\<rightarrow>(trans_type \<tau>2)"
  by (rule TrueI)+

end


theory regexp_RecEps
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'a list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 null eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (s :: A list) . (recognise Eps s) = (null s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

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

datatype Nat = Z | S "Nat"

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

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

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3 z y x))"
  oops

end


(* *)
theory Dagstuhl
  imports "$HIPSTER_HOME/IsaHipster"
begin

(* Hard exercise  *)
fun qrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "qrev [] acc  = acc"
| "qrev (x#xs) acc = qrev xs (x#acc)"

hipster rev qrev
lemma lemma_a [thy_expl]: "qrev (qrev z y) [] = qrev y z"
  apply (induct z arbitrary: y)
  apply simp
  apply simp
  done

lemma lemma_aa [thy_expl]: "rev y @ z = qrev y z"
  apply (induct y arbitrary: z)
apply simp
apply simp
apply (metis append_eq_append_conv2 rev.simps(2) rev_append rev_singleton_conv rev_swap)
done

theorem hardExercise: "rev xs = qrev xs []"
  sledgehammer
  apply (induct xs)
  apply auto
  sledgehammer
  by (metis lemma_aa)

end


theory HOL_base
imports OpenTheory
begin

lemma[opentheory] :
"\<forall>(e::'B) f::'A \<Rightarrow> 'B. \<exists>fn::'A option \<Rightarrow> 'B. fn None = e \<and> (\<forall>x::'A. fn (Some x) = f x)"
apply clarify
apply(rule_tac x="\<lambda>x. case x of
                       None \<Rightarrow> e
                     | Some z \<Rightarrow> f z" in exI)
by simp

lemma[opentheory] :
"\<forall>(f::'A \<Rightarrow> unit) g::'A \<Rightarrow> unit. f = g"
by(clarsimp, rule ext, simp)

lemma[opentheory] :
"\<forall>(P::bool) (Q::bool) R::bool. (P \<longrightarrow> Q \<and> R) = ((P \<longrightarrow> Q) \<and> (P \<longrightarrow> R))"
by fastforce

lemma[opentheory] :
"(\<circ>) = (\<lambda>(f::'B \<Rightarrow> 'C) (g::'A \<Rightarrow> 'B) x::'A. f (g x))"
by((rule ext)+, simp)

lemma[opentheory] :
"\<forall>x::'A + 'B. (\<exists>a::'A. x = Inl a) \<or> (\<exists>b::'B. x = Inr b)"
by(clarsimp, case_tac x, fastforce+)

fun destLeft :: "'A + 'B \<Rightarrow> 'A"
where "destLeft (Inl a) = a"

fun destRight :: "'A + 'B \<Rightarrow> 'B"
where "destRight (Inr a) = a"

fun isLeft :: "'A + 'B \<Rightarrow> bool"
where "isLeft (Inl a) = True"
    | "isLeft _ = False"

fun isRight :: "'A + 'B \<Rightarrow> bool"
where "isRight (Inr a) = True"
    | "isRight _ = False"

fun isSome :: "'A option \<Rightarrow> bool"
where "isSome (Some a) = True"
    | "isSome _ = False"

fun isNone :: "'A option \<Rightarrow> bool"
where "isNone None = True"
    | "isNone _ = False"

fun left_right :: "('A \<Rightarrow> 'C) \<Rightarrow> ('B \<Rightarrow> 'C) \<Rightarrow> 'A + 'B \<Rightarrow> 'C"
where "left_right l r (Inl x) = l x" |
      "left_right l r (Inr x) = r x"

definition "injective f = inj_on f UNIV"
declare injective_def[simp add]

definition "surjective f = surj f"
declare surjective_def[simp add]

lemma[opentheory] :
"\<forall>f::'A \<Rightarrow> 'B. surjective f = (\<forall>y::'B. \<exists>x::'A. y = f x)"
by force

lemma[opentheory] :
"\<forall>f::'A \<Rightarrow> 'B. injective f = (\<forall>(x1::'A) x2::'A. f x1 = f x2 \<longrightarrow> x1 = x2)"
apply clarsimp
apply(rule iffI)
apply(clarify, erule injD, assumption)
by(rule injI, simp)

lemma[opentheory] :
"\<exists>f::ind \<Rightarrow> ind. injective f \<and> \<not> surjective f"
apply simp
apply(rule_tac x=Suc_Rep in exI)
apply(rule conjI)
apply(rule injI)
apply(erule Suc_Rep_inject)
apply clarsimp
apply(drule_tac y="Zero_Rep" in surjD)
apply clarify
apply(drule sym)
apply(drule not_not[THEN iffD2])
apply(erule notE)
apply(rule Suc_Rep_not_Zero_Rep)
done

definition emptyR :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
where "emptyR = (\<lambda>a b. False)"

declare emptyR_def[simp add]

definition univR :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
where "univR = (\<lambda>a b. True)"

declare univR_def[simp add]

definition subrelation :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
where "subrelation S T = (\<forall>a b. S a b \<longrightarrow> T a b)"

lemma subrelation[simp] : "\<forall>r s. subrelation r s = (\<forall>x y. r x y \<longrightarrow> s x y)"
by(simp add: subrelation_def)

definition reflexive :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "reflexive T = (\<forall>a. T a a)"

lemma reflexive[simp] : "\<forall>r. reflexive r = (\<forall>x. r x x)"
by(simp add: reflexive_def)

definition irreflexive :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "irreflexive T = (\<forall>a. \<not> T a a)"

lemma irreflexive[simp] : "\<forall>r. irreflexive r = (\<forall>x. \<not> r x x)"
by(simp add: irreflexive_def)

definition transitive :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "transitive T = (\<forall>a b c. T a b \<longrightarrow> T b c \<longrightarrow> T a c)"

lemma transitive[where 'a="'A", opentheory] :
"\<forall>T. transitive T = (\<forall>a b c. T a b \<and> T b c \<longrightarrow> T a c)"
by(simp add: transitive_def, blast)

definition const :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
where "const a b = a"

lemma const[simp] : "const = (\<lambda>a b. a)" by(rule ext, rule ext, simp add: const_def)

definition "combinatorS f g = (\<lambda>x. f x (g x))"

lemma combinatorS[simp] : "combinatorS = (\<lambda>f g x. f x (g x))"
by(rule ext, rule ext, simp add: combinatorS_def)

lemma combinator_S_const[opentheory] : "\<forall>(x :: 'A \<Rightarrow> 'B). combinatorS const x = id"
by(simp add: const_def combinatorS_def id_def)

definition "combinatorW f = (\<lambda>x. f x x)"

lemma combinatorW[simp] : "combinatorW = (\<lambda>f x. f x x)"
by(rule ext, simp add: combinatorW_def)

definition "bigIntersectR s = (\<lambda>u v. \<forall>r \<in> s. r u v)"

lemma bigIntersectR[opentheory] :
"\<forall>(s::('A \<Rightarrow> 'B \<Rightarrow> bool) set) (x::'A) y::'B.
  bigIntersectR s x y = (\<forall>r::'A \<Rightarrow> 'B \<Rightarrow> bool. r \<in> s \<longrightarrow> r x y)"
by(clarsimp simp: bigIntersectR_def, fastforce)

definition "unionR s t = (\<lambda>a b. s a b \<or> t a b)"

declare unionR_def[simp add]

definition "interR s t = (\<lambda>a b. s a b \<and> t a b)"

declare interR_def[simp add]

definition "unionS s t = (s \<union> t)"

declare unionS_def[simp add]

definition "interS s t = (s \<inter> t)"

declare interS_def[simp add]

definition "fromPredicate p = Collect p"

declare fromPredicate_def[simp add]

definition "fromSet s = (\<lambda>a b. (a, b) \<in> s)"

declare fromSet_def[simp add]

definition "toSet t = {(a, b). t a b}"

declare toSet_def[simp add]

lemma[opentheory] :
"\<forall>p q r. (p \<and> q \<or> r) = ((p \<or> r) \<and> (q \<or> r))"
by force

lemma[opentheory] :
"\<forall>(f::'A \<Rightarrow> 'B) g::'A \<Rightarrow> 'B. (\<forall>x::'A. f x = g x) = (f = g)"
by force

lemma[opentheory] :
"\<forall>r::'A \<Rightarrow> 'A \<Rightarrow> bool.
 r\<^sup>+\<^sup>+ = bigIntersectR {s |s::'A \<Rightarrow> 'A \<Rightarrow> bool. subrelation r s \<and> transitive s}"
apply(clarsimp simp: bigIntersectR_def transitive_def)
apply(rule ext, rule ext)
apply(rule iffI)
apply(erule tranclp_induct)
apply fastforce
apply clarsimp
apply(rename_tac r')
apply(drule_tac x="r'" in spec)
apply(drule mp, fastforce)
apply force
apply(drule spec, erule mp)
by force

definition grN :: "nat \<Rightarrow> nat \<Rightarrow> bool"
where "grN n m = (n > m)"

declare grN_def[simp add]

definition gr_eqN :: "nat \<Rightarrow> nat \<Rightarrow> bool"
where "gr_eqN n m = (n \<ge> m)"

declare gr_eqN_def[simp add]

lemma[opentheory] :
"\<forall>(m::nat) n::nat. max m n = (if m \<le> n then n else m)"
by(simp add: max_def)

lemma[opentheory] :
"\<forall>(m::nat) n::nat. min m n = (if m \<le> n then m else n)"
by(simp add: min_def)

lemma[opentheory] :
"\<forall>p. p (0::nat) \<and> (\<forall>x. p x \<longrightarrow> p (Suc x)) \<longrightarrow> (\<forall>x. p x)"
by(clarsimp, induct_tac x, simp_all)

lemma[opentheory] :
"\<forall>m. \<not> m < (0::nat)"
by simp

lemma[opentheory] :
"\<forall>n. Suc n \<noteq> (0::nat)"
by simp

lemma[opentheory] :
"\<forall>m. m = (0::nat) \<or> (\<exists>n. m = Suc n)"
by(rule allI, case_tac m, simp_all)

lemma[opentheory] :
"\<not> Natural.odd (0::nat)"
apply(simp add: Natural.odd_def)
apply(rule_tac a=Parity.odd in someI2)
by simp_all

lemma[opentheory] :
"even (0::nat)"
apply(simp add: even_def)
apply(rule_tac a=Parity.even in someI2)
by simp_all

lemma[opentheory] :
"\<forall>n::nat. Natural.odd (Suc n) = (\<not> Natural.odd n)"
apply(clarsimp simp: Natural.odd_def)
apply(rule_tac a=Parity.odd in someI2)
by simp_all

lemma[opentheory] :
"\<forall>n::nat. Natural.even (Suc n) = (\<not> Natural.even n)"
apply(clarsimp simp: even_def)
apply(rule_tac a=Parity.even in someI2)
by simp_all

fun factorial :: "nat \<Rightarrow> nat"
where "factorial 0 = 1" |
      "factorial (Suc n) = Suc n * factorial n"

definition "flip f = (\<lambda>a b. f b a)"

declare flip_def[simp add]

fun null
where "null [] = True" |
      "null _ = False"

lemma[opentheory] :
"\<forall>l::'A list. null l = (l = [])"
by(rule allI, case_tac l, simp_all)

lemma[opentheory] :
"\<forall>(h::'A) t::'A list. last (h # t) = (if null t then h else last t)"
by(clarify, case_tac t, simp_all)

lemma[opentheory] :
"flip = (\<lambda>(f::'A \<Rightarrow> 'B \<Rightarrow> 'C) (x::'B) y::'A. f y x)"
by(rule ext, simp)

fun forall :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where "forall P [] = True" |
      "forall P (x#xs) = (P x \<and> forall P xs)"

fun exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where "exists P [] = False" |
      "exists P (x#xs) = (P x \<or> exists P xs)"

fun unzip
where "unzip [] = ([], [])"
    | "unzip ((a, b)#xs) = (let (l, r) = unzip xs in
                             (a#l, b#r))"

lemma[opentheory] :
"\<forall>(h::'A \<times> 'B) (x::'A) (y::'B) (t::('A \<times> 'B) list) (xs::'A list) ys::'B list.
                        (unzip (h # t) = (x # xs, y # ys)) = (h = (x, y) \<and> unzip t = (xs, ys))"
apply clarify
apply(simp add: Let_def split_def)
by fastforce

fun foldr' :: "'B \<Rightarrow> ('A \<Rightarrow> 'A list \<Rightarrow> 'B \<Rightarrow> 'B) \<Rightarrow> 'A list \<Rightarrow> 'B"
where "foldr' b f [] = b" |
      "foldr' b f (x#xs) = f x xs (foldr' b f xs)"

lemma[opentheory] :
"\<forall>(b::'B) f::'A \<Rightarrow> 'A list \<Rightarrow> 'B \<Rightarrow> 'B.
 \<exists>fn::'A list \<Rightarrow> 'B. fn [] = b \<and> (\<forall>(h::'A) t::'A list. fn (h # t) = f h t (fn t))"
apply clarsimp
apply(rule_tac x="foldr' b f" in exI)
apply clarsimp
done

setup \<open>
  fold OpenTheory.add_const
  [("select", @{const_name "Eps"}),
   ("Data.Unit.()", @{const_name "Product_Type.Unity"}),
   ("Function.o", @{const_name "Fun.comp"}),
   ("Function.const", @{const_name "const"}),
   ("Function.Combinator.s", @{const_name "combinatorS"}),
   ("Function.Combinator.w", @{const_name "combinatorW"}),
   ("Function.flip", @{const_name "flip"}),
   ("Function.injective", @{const_name "injective"}),
   ("Function.surjective", @{const_name "surjective"}),
   ("Relation.reflexive", @{const_name "reflexive"}),
   ("Relation.transitive", @{const_name "transitive"}),
   ("Relation.irreflexive", @{const_name "irreflexive"}),
   ("Relation.empty", @{const_name "emptyR"}),
   ("Relation.universe", @{const_name "univR"}),
   ("Relation.subrelation", @{const_name "subrelation"}),
   ("Relation.transitiveClosure", @{const_name "tranclp"}),
   ("Relation.union", @{const_name "unionR"}),
   ("Relation.intersect", @{const_name "interR"}),
   ("Relation.bigIntersect", @{const_name "bigIntersectR"}),
   ("Relation.fromSet", @{const_name "fromSet"}),
   ("Relation.toSet", @{const_name "toSet"}),
   ("Set.fromPredicate", @{const_name "Set.Collect"}),
   ("Set.member", @{const_name "Set.member"}),
   ("Set.union", @{const_name "sup"}),
   ("Set.intersect", @{const_name "inf"}),
   ("Data.Sum.left", @{const_name "Sum_Type.Inl"}),
   ("Data.Sum.right", @{const_name "Sum_Type.Inr"}),
   ("Data.Sum.case.left.right", @{const_name "left_right"}),
   ("Data.Sum.destLeft", @{const_name "destLeft"}),
   ("Data.Sum.destRight", @{const_name "destRight"}),
   ("Data.Sum.isLeft", @{const_name "isLeft"}),
   ("Data.Sum.isRight", @{const_name "isRight"}),
   ("Data.Option.isSome", @{const_name "isSome"}),
   ("Data.Option.isNone", @{const_name "isNone"}),
   ("Data.Option.map", @{const_name "map_option"}),
   ("Data.List.all", @{const_name "forall"}),
   ("Data.List.any", @{const_name "exists"}),
   ("Data.List.reverse", @{const_name "List.rev"}),
   ("Data.List.null", @{const_name "null"}),
   ("Data.List.last", @{const_name "List.last"}),
   ("Data.List.unzip", @{const_name "unzip"}),
   ("Data.List.head", @{const_name "List.hd"}),
   ("Data.List.tail", @{const_name "List.tl"}),
   ("Data.List.filter", @{const_name "List.filter"}),
   ("Number.Natural.zero", @{const_name "Groups.zero_class.zero"}),
   ("Number.Natural.bit0", @{const_name "OpenTheory.Number.Numeral.bit0"}),
   ("Number.Natural.bit1", @{const_name "OpenTheory.Number.Numeral.bit1"}),
   ("Number.Natural.^", @{const_name "power"}),
   ("Number.Natural.>", @{const_name "grN"}),
   ("Number.Natural.>=", @{const_name "gr_eqN"}),
   ("Number.Natural.mod", @{const_name "Rings.modulo_class.modulo"}),
   ("Number.Natural.div", @{const_name "Rings.divide_class.divide"}),
   ("Number.Natural.max", @{const_name "max"}),
   ("Number.Natural.min", @{const_name "min"}),
   ("Number.Natural.factorial", @{const_name "factorial"})]
\<close>

setup \<open>
  fold OpenTheory.add_tyop
  [("ind", @{type_name "ind"}),
   ("Set.set", @{type_name "set"}),
   ("Data.Unit.unit", @{type_name "Product_Type.unit"}),
   ("Data.Sum.+", @{type_name "Sum_Type.sum"})]
\<close>

art_file "hol-base-1.2.art"

art_file "hol-monad-1.1.art"

art_file "hol-sort-1.0.art"

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Streams
imports
  HOLCF
  Nats
  WorkerWrapper
begin
(*>*)

section{* Memoisation using streams. *}

text {*
\label{sec:memoisation-example} *}

subsection{* Streams. *}

text{* The type of infinite streams. *}

domain 'a Stream = stcons (lazy sthead :: "'a") (lazy sttail :: "'a Stream") (infixr "&&" 65)

(*<*)
lemma Stream_bisimI[intro]:
  "(\<And>xs ys. R xs ys
     \<Longrightarrow> (xs = \<bottom> \<and> ys = \<bottom>)
       \<or> (\<exists>h t t'. R t t' \<and> xs = h && t \<and> ys = h && t'))
  \<Longrightarrow> Stream_bisim R"
  unfolding Stream.bisim_def by blast
(*>*)

fixrec smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a Stream \<rightarrow> 'b Stream"
where
  "smap\<cdot>f\<cdot>(x && xs) = f\<cdot>x && smap\<cdot>f\<cdot>xs"

(*<*)
lemma smap_strict[simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp
(*>*)

lemma smap_smap: "smap\<cdot>f\<cdot>(smap\<cdot>g\<cdot>xs) = smap\<cdot>(f oo g)\<cdot>xs"
(*<*) by (induct xs, simp_all) (*>*)

fixrec i_th :: "'a Stream \<rightarrow> Nat \<rightarrow> 'a"
where
  "i_th\<cdot>(x && xs) = Nat_case\<cdot>x\<cdot>(i_th\<cdot>xs)"

abbreviation
  i_th_syn :: "'a Stream \<Rightarrow> Nat \<Rightarrow> 'a" (infixl "!!" 100) where
  "s !! i \<equiv> i_th\<cdot>s\<cdot>i"

(*<*)
lemma i_th_strict1[simp]: "\<bottom> !! i = \<bottom>"
by fixrec_simp

lemma i_th_strict2[simp]: "s !! \<bottom> = \<bottom>" by (subst i_th.unfold, cases s, simp_all)
lemma i_th_0[simp]: "(s !! 0) = sthead\<cdot>s" by (subst i_th.unfold, cases s, simp_all)
lemma i_th_suc[simp]: "i \<noteq> \<bottom> \<Longrightarrow> (x && xs) !! (i + 1) = xs !! i" by (subst i_th.unfold, simp)
(*>*)

text{* The infinite stream of natural numbers. *}

fixrec nats :: "Nat Stream"
where
  "nats = 0 && smap\<cdot>(\<Lambda> x. 1 + x)\<cdot>nats"

(*<*)
declare nats.simps[simp del]
(*>*)

subsection{* The wrapper/unwrapper functions. *}

definition
  unwrapS' :: "(Nat \<rightarrow> 'a) \<rightarrow> 'a Stream" where
  "unwrapS' \<equiv> \<Lambda> f . smap\<cdot>f\<cdot>nats"

lemma unwrapS'_unfold: "unwrapS'\<cdot>f = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats"
(*<*)by (unfold unwrapS'_def, subst nats.unfold, simp add: smap_smap)(*>*)

fixrec unwrapS :: "(Nat \<rightarrow> 'a) \<rightarrow> 'a Stream"
where
  "unwrapS\<cdot>f = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))"

(*<*)
declare unwrapS.simps[simp del]
(*>*)

text{* The two versions of @{term "unwrapS"} are equivalent. We could
try to fold some definitions here but it's easier if the stream
constructor is manifest. *}

lemma unwrapS_unwrapS'_eq: "unwrapS = unwrapS'" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix f show "?lhs\<cdot>f = ?rhs\<cdot>f"
  proof(coinduct rule: Stream.coinduct)
    let ?R = "\<lambda>s s'. (\<exists>f. s = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))
                        \<and> s' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)"
    show "Stream_bisim ?R"
    proof
      fix s s' assume "?R s s'"
      then obtain f where fs:  "s = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))"
                      and fs': "s' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats"
        by blast
      have "?R (unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))) (smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)"
        by ( rule exI[where x="f oo (\<Lambda> x. 1 + x)"]
           , subst unwrapS.unfold, subst nats.unfold, simp add: smap_smap)
      with fs fs'
      show "(s = \<bottom> \<and> s' = \<bottom>)
          \<or> (\<exists>h t t'.
              (\<exists>f. t = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))
                 \<and> t' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)
                 \<and> s = h && t \<and> s' = h && t')" by best
    qed
    show "?R (?lhs\<cdot>f) (?rhs\<cdot>f)"
    proof -
      have lhs: "?lhs\<cdot>f = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))" by (subst unwrapS.unfold, simp)
      have rhs: "?rhs\<cdot>f = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats" by (rule unwrapS'_unfold)
      from lhs rhs show ?thesis by best
    qed
  qed
qed

definition
  wrapS :: "'a Stream \<rightarrow> Nat \<rightarrow> 'a" where
  "wrapS \<equiv> \<Lambda> s i . s !! i"

text{* Note the identity requires that @{term "f"} be
strict. \citet[\S6.1]{GillHutton:2009} do not make this requirement,
an oversight on their part.

In practice all functions worth memoising are strict in the memoised
argument. *}

lemma wrapS_unwrapS_id':
  assumes strictF: "(f::Nat \<rightarrow> 'a)\<cdot>\<bottom> = \<bottom>"
  shows "unwrapS\<cdot>f !! n = f\<cdot>n"
using strictF
proof(induct n arbitrary: f rule: Nat_induct)
  case bottom with strictF show ?case by simp
next
  case zero thus ?case by (subst unwrapS.unfold, simp)
next
  case (Suc i f)
  have "unwrapS\<cdot>f !! (i + 1) = (f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))) !! (i + 1)"
    by (subst unwrapS.unfold, simp)
  also from Suc have "\<dots> = unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x)) !! i" by simp
  also from Suc have "\<dots> = (f oo (\<Lambda> x. 1 + x))\<cdot>i" by simp
  also have "\<dots> = f\<cdot>(i + 1)" by (simp add: plus_commute)
  finally show ?case .
qed

lemma wrapS_unwrapS_id: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> (wrapS oo unwrapS)\<cdot>f = f"
  by (rule cfun_eqI, simp add: wrapS_unwrapS_id' wrapS_def)

subsection{* Fibonacci example. *}

definition
  fib_body :: "(Nat \<rightarrow> Nat) \<rightarrow> Nat \<rightarrow> Nat" where
  "fib_body \<equiv> \<Lambda> r. Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n. r\<cdot>n + r\<cdot>(n + 1)))"

(*<*)
lemma fib_body_strict[simp]: "fib_body\<cdot>r\<cdot>\<bottom> = \<bottom>" by (simp add: fib_body_def)
(*>*)

definition
  fib :: "Nat \<rightarrow> Nat" where
  "fib \<equiv> fix\<cdot>fib_body"

(*<*)
lemma fib_strict[simp]: "fib\<cdot>\<bottom> = \<bottom>"
  by (unfold fib_def, subst fix_eq, fold fib_def, simp add: fib_body_def)
(*>*)

text{* Apply worker/wrapper. *}

definition
  fib_work :: "Nat Stream" where
  "fib_work \<equiv> fix\<cdot>(unwrapS oo fib_body oo wrapS)"

definition
  fib_wrap :: "Nat \<rightarrow> Nat" where
  "fib_wrap \<equiv> wrapS\<cdot>fib_work"

lemma wrapS_unwrapS_fib_body: "wrapS oo unwrapS oo fib_body = fib_body"
proof(rule cfun_eqI)
  fix r show "(wrapS oo unwrapS oo fib_body)\<cdot>r = fib_body\<cdot>r"
    using wrapS_unwrapS_id[where f="fib_body\<cdot>r"] by simp
qed

lemma fib_ww_eq: "fib = fib_wrap"
  using worker_wrapper_body[OF wrapS_unwrapS_fib_body]
  by (simp add: fib_def fib_wrap_def fib_work_def)

text{* Optimise. *}

fixrec
  fib_work_final :: "Nat Stream"
and
  fib_f_final :: "Nat \<rightarrow> Nat"
where
  "fib_work_final = smap\<cdot>fib_f_final\<cdot>nats"
| "fib_f_final = Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n'. fib_work_final !! n' + fib_work_final !! (n' + 1)))"

declare fib_f_final.simps[simp del] fib_work_final.simps[simp del]

definition
  fib_final :: "Nat \<rightarrow> Nat" where
  "fib_final \<equiv> \<Lambda> n. fib_work_final !! n"

text{*

This proof is only fiddly due to the way mutual recursion is encoded:
we need to use Beki\'{c}'s Theorem \citep{Bekic:1969}\footnote{The
interested reader can find some historical commentary in
\citet{Harel:1980, DBLP:journals/toplas/Sangiorgi09}.} to massage the
definitions into their final form.

*}

lemma fib_work_final_fib_work_eq: "fib_work_final = fib_work" (is "?lhs = ?rhs")
proof -
  let ?wb = "\<Lambda> r. Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n'. r !! n' + r !! (n' + 1)))"
  let ?mr = "\<Lambda> (fwf :: Nat Stream, fff). (smap\<cdot>fff\<cdot>nats, ?wb\<cdot>fwf)"
  have "?lhs = fst (fix\<cdot>?mr)"
    by (simp add: fib_work_final_def split_def csplit_def)
  also have "\<dots> = (\<mu> fwf. fst (?mr\<cdot>(fwf, \<mu> fff. snd (?mr\<cdot>(fwf, fff)))))"
    using fix_cprod[where F="?mr"] by simp
  also have "\<dots> = (\<mu> fwf. smap\<cdot>(\<mu> fff. ?wb\<cdot>fwf)\<cdot>nats)" by simp
  also have "\<dots> = (\<mu> fwf. smap\<cdot>(?wb\<cdot>fwf)\<cdot>nats)" by (simp add: fix_const)
  also have "\<dots> = ?rhs"
    unfolding fib_body_def fib_work_def unwrapS_unwrapS'_eq unwrapS'_def wrapS_def
    by (simp add: cfcomp1)
  finally show ?thesis .
qed

lemma fib_final_fib_eq: "fib_final = fib" (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<Lambda> n. fib_work_final !! n)" by (simp add: fib_final_def)
  also have "\<dots> = (\<Lambda> n. fib_work !! n)" by (simp only: fib_work_final_fib_work_eq)
  also have "\<dots> = fib_wrap" by (simp add: fib_wrap_def wrapS_def)
  also have "\<dots> = ?rhs" by (simp only: fib_ww_eq)
  finally show ?thesis .
qed

(*<*)
end
(*>*)