(*  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


(* *)
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
(*>*)