theory "Nominal-HOLCF"
imports
  "../Nominal2/Nominal2" "Nominal-Utils" "~~/src/HOL/HOLCF/HOLCF"
begin

subsubsection {* Type class of continous permutations and variations thereof *}

class cont_pt =
  cpo +
  pt +
  assumes perm_cont: "\<And>p. cont ((permute p) :: 'a::{cpo,pt} \<Rightarrow> 'a)"

class discr_pt =
  discrete_cpo +
  pt

class pcpo_pt =
  cont_pt +
  pcpo

instance pcpo_pt \<subseteq> cont_pt
 by (default, auto intro: perm_cont)

instance discr_pt \<subseteq> cont_pt
 by (default, auto)

lemma (in cont_pt) perm_cont_simp[simp]: "\<pi> \<bullet> x \<sqsubseteq> \<pi> \<bullet> y \<longleftrightarrow> x \<sqsubseteq> y"
  apply rule
  apply (drule cont2monofunE[OF perm_cont, of _ _ "-\<pi>"], simp)[1]
  apply (erule cont2monofunE[OF perm_cont, of _ _ "\<pi>"])
  done

lemma perm_is_ub_simp[simp]: "\<pi> \<bullet> S <| \<pi> \<bullet> (x::'a::cont_pt) \<longleftrightarrow> S <| x"
  by (auto simp add: is_ub_def permute_set_def)

lemma perm_is_ub_eqvt[simp,eqvt]: "S <| (x::'a::cont_pt) \<Longrightarrow> \<pi> \<bullet> S <| \<pi> \<bullet> x"
  by simp

lemma perm_is_lub_simp[simp]: "\<pi> \<bullet> S <<| \<pi> \<bullet> (x::'a::cont_pt) \<longleftrightarrow> S <<| x"
  apply (rule perm_rel_lemma)
  by (metis is_lubI is_lubD1 is_lubD2 perm_cont_simp perm_is_ub_simp)

lemma perm_is_lub_eqvt[simp,eqvt]: "S <<| (x::'a::cont_pt) ==> \<pi> \<bullet> S <<| \<pi> \<bullet> x"
  by simp

lemmas perm_cont2cont[simp,cont2cont] = cont_compose[OF perm_cont]

lemma perm_still_cont: "cont (\<pi> \<bullet> f) = cont (f :: ('a :: cont_pt) \<Rightarrow> ('b :: cont_pt))"
proof
  have imp:"\<And> (f :: 'a \<Rightarrow> 'b) \<pi>. cont f \<Longrightarrow> cont (\<pi> \<bullet> f)"
    unfolding permute_fun_def
    by (metis cont_compose perm_cont)
  show "cont f \<Longrightarrow> cont (\<pi> \<bullet> f)" using imp[of "f" "\<pi>"].
  show "cont (\<pi> \<bullet> f) \<Longrightarrow> cont (f)" using imp[of "\<pi> \<bullet> f" "-\<pi>"] by simp
qed

lemma perm_bottom[simp,eqvt]: "\<pi> \<bullet> \<bottom> = (\<bottom>::'a::{cont_pt,pcpo})"
  proof-
  have "\<bottom> \<sqsubseteq> -\<pi> \<bullet> (\<bottom>::'a::{cont_pt,pcpo})" by simp
  hence "\<pi> \<bullet> \<bottom> \<sqsubseteq> \<pi> \<bullet> (-\<pi> \<bullet> (\<bottom>::'a::{cont_pt,pcpo}))" by(rule cont2monofunE[OF perm_cont])
  hence "\<pi> \<bullet> \<bottom> \<sqsubseteq> (\<bottom>::'a::{cont_pt,pcpo})" by simp
  thus "\<pi> \<bullet> \<bottom> = (\<bottom>::'a::{cont_pt,pcpo})" by simp
qed

lemma bot_supp[simp]: "supp (\<bottom> :: 'a :: pcpo_pt) = {}"
  by (rule supp_fun_eqvt) (simp add: eqvt_def)

lemma bot_fresh[simp]: "a \<sharp> (\<bottom> :: 'a :: pcpo_pt)"
  by (simp add: fresh_def)

lemma bot_fresh_star[simp]: "a \<sharp>* (\<bottom> :: 'a :: pcpo_pt)"
  by (simp add: fresh_star_def)

lemma below_eqvt [eqvt]:
    "\<pi> \<bullet> (x \<sqsubseteq> y) = (\<pi> \<bullet> x \<sqsubseteq> \<pi> \<bullet> (y::'a::cont_pt))" by (auto simp add: permute_pure)

lemma lub_eqvt[simp]:
  "(\<exists> z. S <<| (z::'a::{cont_pt})) \<Longrightarrow> \<pi> \<bullet> lub S = lub (\<pi> \<bullet> S)"
  by (metis lub_eqI perm_is_lub_simp)

lemma chain_eqvt[eqvt]:
  fixes F :: "nat \<Rightarrow> 'a::cont_pt"
  shows "chain F \<Longrightarrow> chain (\<pi> \<bullet> F)"
  apply (rule chainI)
  apply (drule_tac i = i in chainE)
  apply (subst (asm) perm_cont_simp[symmetric, where \<pi> = \<pi>])
  by (metis permute_fun_app_eq permute_pure)

subsubsection {* Instance for @{type cfun} *}

instantiation "cfun" :: (cont_pt, cont_pt) pt
begin
  definition "p \<bullet> (f :: 'a  \<rightarrow> 'b) = (\<Lambda> x. p \<bullet> (f \<cdot> (- p \<bullet> x)))"

  instance
  apply(default)
  apply (simp add: permute_cfun_def eta_cfun)
  apply (simp add: permute_cfun_def cfun_eqI minus_add)
  done
end

lemma permute_cfun_eq: "permute p = (\<lambda> f. (Abs_cfun (permute p)) oo f oo (Abs_cfun (permute (-p))))"
  by (rule, rule cfun_eqI, auto simp add: permute_cfun_def)

lemma Cfun_app_eqvt[eqvt]:
  "\<pi> \<bullet> (f \<cdot> x) = (\<pi> \<bullet> f) \<cdot> (\<pi> \<bullet> x)"
  unfolding permute_cfun_def
  by auto

lemma permute_Lam: "cont f \<Longrightarrow> p \<bullet> (\<Lambda> x. f x) = (\<Lambda> x. (p \<bullet> f) x)"
  apply (rule cfun_eqI)
  unfolding permute_cfun_def
  by (metis Abs_cfun_inverse2 eqvt_lambda unpermute_def )

lemma Abs_cfun_eqvt: "cont f \<Longrightarrow> (p \<bullet> Abs_cfun) f = Abs_cfun f"
  apply (subst permute_fun_def)
  by (metis permute_Lam perm_still_cont permute_minus_cancel(1))

instance "cfun" :: (cont_pt, cont_pt) cont_pt
  by (default,subst permute_cfun_eq, auto)

instance "cfun" :: ("{pure,cont_pt}", "{pure,cont_pt}") pure
  by default (auto  simp add: permute_cfun_def permute_pure Cfun.cfun.Rep_cfun_inverse)

instance "cfun" :: (cont_pt, pcpo_pt) pcpo_pt
  by (default)

subsubsection {* Instance for @{type fun} *}

lemma permute_fun_eq: "permute p = (\<lambda> f. (permute p) \<circ> f \<circ> (permute (-p)))"
  by (rule, rule, metis comp_apply eqvt_lambda unpermute_def)

instance "fun" :: (pt, cont_pt) cont_pt
  apply (default)
  apply (rule cont2cont_lambda)
  apply (subst permute_fun_def)
  apply (rule perm_cont2cont)
  apply (rule cont_fun)
  done

lemma adm_subst2: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f (fst x) = g (snd x))"
  apply (rule admI)
  apply (simp add:
      cont2contlubE[where f = f]  cont2contlubE[where f = g]
      cont2contlubE[where f = snd]  cont2contlubE[where f = fst]
      )
  done

lemma fix_eqvt[eqvt]:
  "\<pi> \<bullet> fix = (fix :: ('a \<rightarrow> 'a) \<rightarrow> 'a::{cont_pt,pcpo})"
apply (rule cfun_eqI)
apply (subst permute_cfun_def)
apply simp
apply (rule parallel_fix_ind[OF adm_subst2])
apply (auto simp add: permute_self)
done

end


(*  Author:     Stefan Berghofer, TU Muenchen, 2005; Lukas Bulwahn, TU Muenchen, 2009
*)

theory Execute
imports POPLmarkRecord "~~/src/HOL/Library/Code_Target_Numeral"
begin

section {* Executing the specification *}

text {*
\label{sec:exec}
An important criterion that a solution to the {\sc PoplMark} Challenge should
fulfill is the possibility to {\it animate} the specification. For example,
it should be possible to apply the reduction relation for the calculus to
example terms. Since the reduction relations are defined inductively, they can
be interpreted as a logic program in the style of {\sc Prolog}.
The definition of the single-step evaluation relation presented in \secref{sec:evaluation}
and \secref{sec:evaluation-rcd} is directly executable.

In order to compute the normal form of a term using the one-step evaluation
relation @{text "\<longmapsto>"}, we introduce the inductive predicate @{text "t \<Down> u"},
denoting that @{text u} is a normal form of @{text t}.
*}

inductive norm :: "trm \<Rightarrow> trm \<Rightarrow> bool"  (infixl "\<Down>" 50)
where
  "t \<in> value \<Longrightarrow> t \<Down> t"
| "t \<longmapsto> s \<Longrightarrow> s \<Down> u \<Longrightarrow> t \<Down> u"

definition normal_forms where
  "normal_forms t \<equiv> {u. t \<Down> u}"

lemma [code_pred_intro Rcd_Nil]: "valuep (Rcd [])"
by (auto intro: valuep.intros)

lemma [code_pred_intro Rcd_Cons]: "valuep t \<Longrightarrow> valuep (Rcd fs) \<Longrightarrow> valuep (Rcd ((l, t) # fs))"
by (auto intro!: valuep.intros elim!: valuep.cases)

lemmas valuep.intros(1)[code_pred_intro Abs'] valuep.intros(2)[code_pred_intro TAbs']

code_pred (modes: i => bool) valuep
proof -
  case valuep
  from valuep.prems show thesis
  proof (cases rule: valuep.cases)
    case (Rcd fs)
    from this Rcd_Nil Rcd_Cons show thesis
      by (cases fs) (auto intro: valuep.intros)
  next
    case Abs
    with Abs' show thesis .
  next
    case TAbs
    with TAbs' show thesis .
  qed
qed

thm valuep.equation

code_pred (modes: i => i => bool, i => o => bool as normalize) norm .

thm norm.equation

lemma [code_unfold]: "x \<in> value \<longleftrightarrow> valuep x"
  by (simp add: value_def)

definition
  natT :: type where
  "natT \<equiv> \<forall><:Top. (\<forall><:TVar 0. (\<forall><:TVar 1. (TVar 2 \<rightarrow> TVar 1) \<rightarrow> TVar 0 \<rightarrow> TVar 1))"

definition
  fact2 :: trm where
  "fact2 \<equiv>
   LET PVar natT =
     (\<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1. \<lambda>: TVar 1. Var 1 \<bullet> Var 0)
   IN
   LET PRcd
     [(''pluspp'', PVar (natT \<rightarrow> natT \<rightarrow> natT)),
      (''multpp'', PVar (natT \<rightarrow> natT \<rightarrow> natT))] = Rcd
     [(''multpp'', \<lambda>:natT. \<lambda>:natT. \<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1.
        Var 5 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet>\<^sub>\<tau> TVar 1 \<bullet> (Var 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet>\<^sub>\<tau> TVar 1) \<bullet> Var 0),
      (''pluspp'', \<lambda>:natT. \<lambda>:natT. \<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1. \<lambda>:TVar 1.
        Var 6 \<bullet>\<^sub>\<tau> TVar 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 3 \<bullet> Var 1 \<bullet>
          (Var 5 \<bullet>\<^sub>\<tau> TVar 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet> Var 1 \<bullet> Var 0))]
   IN
     Var 0 \<bullet> (Var 1 \<bullet> Var 2 \<bullet> Var 2) \<bullet> Var 2"

value "normal_forms fact2"

text {*
Unfortunately, the definition based
on evaluation contexts from \secref{sec:evaluation-ctxt} is not directly executable.
The reason is that from the definition of evaluation contexts, the code generator
cannot immediately read off an algorithm that, given a term @{text t}, computes a context
@{text E} and a term @{text "t\<^sub>0"} such that @{text "t = E t\<^sub>0"}. In order to do this, one
would have to extract the algorithm contained in the proof of the {\it decomposition lemma}
from \secref{sec:evaluation-ctxt}.
*}

values "{u. norm fact2 u}"

end


theory SBDemo

imports bundle.SB sbElemDemo

begin

section \<open>SB examples\<close>
text \<open>This Theory gives a few examples for SB. First we will show how a SB can be defined, later we
      also test some SB functions. Some of these functions will also use sbElems.\<close>

subsection\<open>sbElem definition\<close>

lift_definition inSB::"inChan\<^sup>\<Omega>"is
"((\<lambda>c. fix\<cdot>(\<Lambda> s. (\<up>1) \<bullet> s)))"
  apply(auto simp add: sb_well_def sValues_def)
  apply(subgoal_tac "Rep c \<in>range (Rep::inChan \<Rightarrow>channel)")
  apply simp
  by blast

text \<open>inSB has a infinite stream of 1s on its channels.\<close>

lift_definition emptySB::"emptychan\<^sup>\<Omega>"is
"((\<lambda>c. \<epsilon>))"
  by(auto simp add: sb_well_def sValues_def)

subsection\<open>SB function tests\<close>

text \<open>First we take a look at the sbECons function, that prepends an sbElem to a SB.\<close>
lemma sbecons_none_test:"sbElemNone \<bullet>\<^sup>\<surd> (emptySB) = emptySB"
  apply(simp add: sbecons_insert sbe2sb_insert sbElemNone.rep_eq emptySB.rep_eq sbgetch_insert2 sbconc_insert)
  by (simp add: Rep_sb_strict emptySB.abs_eq)

text \<open>If we assume that the ctype of all channels is empty, we now that there can only be the None
      sbElem and the empty SB \<open>\<bottom> \<close>. Hence, prepending the None sbElem to a SB results in \<open>\<bottom> \<close>.\<close>
lemma sbecons_none_test2:"sbElemNone \<bullet>\<^sup>\<surd> (emptySB) = \<bottom>"
  apply(simp add: sbecons_insert sbe2sb_insert sbElemNone.rep_eq emptySB.rep_eq sbgetch_insert2 sbconc_insert)
  by (simp add: Rep_sb_inverse)

text \<open>The sbGetCh function retrieves the stream of a channel.\<close>
lemma "(inSB) \<^enum> (c::inChan) = fix\<cdot>(\<Lambda> s. \<up>1 \<bullet> s)"
  by(simp add: sbgetch_insert2 inSB.rep_eq)

text \<open>Now we take a look at the sbUnion function. The result of the union of the same SB is the SB
      itself.\<close>
lemma "sbUnion\<cdot>someSB\<cdot>someSB = someSB"
  by simp

text \<open>But if the union output type is different from the input type, the union of the same SB is
      equivalent to converting the input type to the output type.\<close>

lemma "inSB \<uplus> inSB = (inSB\<star>)"
  by simp

(*TODO: More tests*)