section "Completeness of the declarative semantics wrt. operational"

theory DenotCompleteFSet
  imports ChangeEnv SmallStepLam DenotSoundFSet
begin

subsection "Reverse substitution preserves denotation"

fun join :: "val \<Rightarrow> val \<Rightarrow> val option" (infix "\<squnion>" 60) where
  "(VNat n) \<squnion> (VNat n') = (if n = n' then Some (VNat n) else None)" |
  "(VFun f) \<squnion> (VFun f') = Some (VFun (f |\<union>| f'))" |
  "v \<squnion> v' = None"

lemma combine_values:
  assumes vv: "isval v" and v1v: "v1 \<in> E v \<rho>" and v2v: "v2 \<in> E v \<rho>"
  shows " \<exists> v3. v3 \<in> E v \<rho> \<and> (v1 \<squnion> v2 = Some v3)"
  using vv v1v v2v by (induction v arbitrary: v1 v2 \<rho>) auto

lemma le_union1: fixes v1::val assumes v12: "v1 \<squnion> v2 = Some v12" shows "v1 \<sqsubseteq> v12"
proof (cases v1)
  case (VNat n1) hence v1: "v1=VNat n1" by simp
  show ?thesis
  proof (cases v2)
    case (VNat n2) with v1 v12 show ?thesis by (cases "n1=n2") auto
  next
    case (VFun x2) with v1 v12 show ?thesis by auto
  qed
next
  case (VFun t2) from VFun have v1: "v1=VFun t2" by simp
  show ?thesis
  proof (cases v2)
    case (VNat n1) with v1 v12 show ?thesis by auto
  next
    case (VFun n2) with v1 v12 show ?thesis by auto
  qed
qed

lemma le_union2: "v1 \<squnion> v2 = Some v12 \<Longrightarrow> v2 \<sqsubseteq> v12"
  apply (cases v1)
   apply (cases v2)
    apply auto
   apply (rename_tac x1 x1')
   apply (case_tac "x1 = x1'")
    apply auto
  apply (cases v2)
   apply auto
  done

lemma le_union_left: "\<lbrakk> v1 \<squnion> v2 = Some v12; v1 \<sqsubseteq> v3; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v12 \<sqsubseteq> v3"
  apply (cases v1) apply (cases v2) apply force+ done

lemma e_val: "isval v \<Longrightarrow> \<exists> v'. v' \<in> E v \<rho>"
  apply (case_tac v) apply auto apply (rule_tac x="{||}" in exI) apply force done

lemma reverse_subst_lam:
  assumes fl: "VFun f \<in> E (ELam x e) \<rho>"
    and vv: "is_val v" and ls: "ELam x e = ELam x (subst y v e')" and xy: "x \<noteq> y"
    and IH: "\<forall> v1 v2. v2 \<in> E (subst y v e') ((x,v1)#\<rho>)
        \<longrightarrow> (\<exists> \<rho>' v'. v' \<in> E v [] \<and> v2 \<in> E e' \<rho>' \<and> \<rho>' \<approx> (y,v')#(x,v1)#\<rho>)"
  shows "\<exists> \<rho>' v''. v'' \<in> E v [] \<and> VFun f \<in> E (ELam x e') \<rho>' \<and> \<rho>' \<approx> ((y,v'')#\<rho>)"
  using fl vv ls IH xy
proof (induction f arbitrary: x e e' \<rho> v y)
  case empty
  from empty(2) is_val_def obtain v' where vp_v: "v' \<in> E v []" using e_val[of v "[]"] by blast
  let ?R = "(y,v')#\<rho>"
  have 1: "VFun {||} \<in> E (ELam x e') ?R" by simp
  have 2: "?R \<approx> (y, v') # \<rho>" by auto
  from vp_v 1 2 show ?case by blast
next
  case (insert a f x e e' \<rho> v y)
  from insert(3) have 1: "VFun f \<in> E (ELam x e) \<rho>" by auto
  obtain v1 v2 where a: "a = (v1,v2)" by (cases a) simp
  from insert 1 have "\<exists> \<rho>' v''. v'' \<in> E v [] \<and> VFun f \<in> E (ELam x e') \<rho>' \<and> \<rho>' \<approx> ((y,v'')#\<rho>)"
    by blast
  from this obtain \<rho>'' v'' where vpp_v: "v'' \<in> E v []" and f_l: "VFun f \<in> E (ELam x e') \<rho>''"
    and rpp_r: "\<rho>'' \<approx> ((y,v'')#\<rho>)" by blast
  from insert(3) a have v2_e: "v2 \<in> E e ((x,v1)#\<rho>)" using e_lam_elim2 by blast
  from insert v2_e have "\<exists>\<rho>'' v'. v' \<in> E v [] \<and> v2 \<in> E e' \<rho>'' \<and> \<rho>'' \<approx> (y, v')#(x, v1)#\<rho>" by auto
  from this obtain \<rho>3 v' where vp_v: "v' \<in> E v []" and v2_ep: "v2 \<in> E e' \<rho>3"
    and r3: "\<rho>3 \<approx> (y,v') # (x,v1) # \<rho>" by blast
  from insert(4) have "isval v" by auto
  from this vp_v vpp_v obtain v3 where v3_v: "v3 \<in> E v []" and vp_vpp: "v' \<squnion> v'' = Some v3"
    using combine_values by blast
  have 4: "VFun (finsert a f) \<in> E (ELam x e') ((y, v3) # \<rho>)"
  proof -
    from vp_vpp have v3_vpp: "v'' \<sqsubseteq> v3" using le_union2 by simp
    from rpp_r v3_vpp have "\<rho>'' \<sqsubseteq> (y,v3)#\<rho>" by (simp add: env_eq_def env_le_def)
    from f_l this have 2: "VFun f \<in> E (ELam x e') ((y, v3) # \<rho>)" by (rule raise_env)
    from vp_vpp have vp_v3: "v' \<sqsubseteq> v3" using le_union1 by simp
    from vp_v3 r3 insert have "\<rho>3 \<sqsubseteq> (x,v1)#(y,v3)#\<rho>" by (simp add: env_eq_def env_le_def)
    from v2_ep this have 3: "v2 \<in> E e' ((x,v1)#(y,v3)#\<rho>)" by (rule raise_env)
    from 2 3 a show "?thesis" using e_lam_intro2 by blast
  qed
  have 5: "(y, v3) # \<rho> \<approx> (y, v3) # \<rho>" by auto
  from v3_v 4 5 show ?case by blast
qed

lemma lookup_ext_none: "\<lbrakk> lookup \<rho> y = None; x \<noteq> y \<rbrakk> \<Longrightarrow> lookup ((x,v)#\<rho>) y = None"
  by auto

\<comment> \<open>For reverse subst lemma, the variable case shows up over and over, so we prove it as a lemma\<close>
lemma rev_subst_var:
  assumes ev: "e = EVar y \<and> v = e'" and vv: "is_val v" and vp_E: "v' \<in> E e' \<rho>"
  shows "\<exists> \<rho>' v''. v'' \<in> E v [] \<and> v' \<in> E e \<rho>' \<and> \<rho>' \<approx> ((y,v'')#\<rho>)"
proof -
  from vv have lx: "\<forall> x. x \<in> FV v \<longrightarrow> lookup [] x = lookup \<rho> x" by auto
  from ev vp_E lx env_strengthen[of v' v \<rho> "[]"] have n_Ev: "v' \<in> E v []" by blast
  have ly: "lookup ((y,v')#\<rho>) y = Some v'" by simp
  from env_eq_def have rr: "((y,v')#\<rho>) \<approx> ((y,v')#\<rho>)" by simp
  from ev ly have n_Ee: "v' \<in> E e ((y,v')#\<rho>)" by simp
  from n_Ev rr n_Ee show ?thesis by blast
qed

lemma reverse_subst_pres_denot:
  assumes vep: "v' \<in> E e' \<rho>" and vv: "is_val v" and ep: "e' = subst y v e"
  shows "\<exists> \<rho>' v''. v'' \<in> E v [] \<and> v' \<in> E e \<rho>' \<and> \<rho>' \<approx> ((y,v'')#\<rho>)"
  using vep vv ep
proof  (induction arbitrary: v' y v e rule: E.induct)
  case (1 n \<rho>) \<comment> \<open>e' = ENat n\<close>
  from 1(1) have vp: "v' = VNat n" by auto
  from 1(3) have "e = ENat n \<or> (e = EVar y \<and> v = ENat n)" by (cases e, auto)
  then show ?case
  proof
    assume e: "e = ENat n"
    from 1(2) e_val is_val_def obtain v'' where vpp_E: "v'' \<in> E v []" by force
    from env_eq_def have rr: "((y,v'')#\<rho>) \<approx> ((y,v'')#\<rho>)" by simp
    from vp e have vp_E: "v' \<in> E e ((y,v'')#\<rho>)" by simp
    from vpp_E vp_E rr show ?thesis by blast
  next
    assume ev: "e = EVar y \<and> v = ENat n"
    from ev 1(2) 1(1) rev_subst_var show ?thesis by blast
  qed
next
  case (2 x \<rho>) \<comment> \<open>e' = EVar x\<close>
  from 2 have e: "e = EVar x" by (cases e, auto)
  from 2 e have xy: "x \<noteq> y" by force
  from 2(2) e_val is_val_def obtain v'' where vpp_E: "v'' \<in> E v []" by force
  from env_eq_def have rr: "((y,v'')#\<rho>) \<approx> ((y,v'')#\<rho>)" by simp
  from 2(1) obtain vx where lx: "lookup \<rho> x = Some vx" and vp_vx: "v' \<sqsubseteq> vx" by auto
  from e lx vp_vx xy have vp_E: "v' \<in> E e ((y,v'')#\<rho>)" by simp
  from vpp_E rr vp_E show ?case by blast
next
  case (3 x eb \<rho>)
  { assume ev: "e = EVar y \<and> v = ELam x eb"
    from ev 3(3) 3(2) rev_subst_var have ?case by blast
  } also { assume ex: "e = ELam x eb \<and> x = y"
    from 3(3) e_val is_val_def obtain v'' where vpp_E: "v'' \<in> E v []" by force
    from env_eq_def have rr: "((y,v'')#\<rho>) \<approx> ((y,v'')#\<rho>)" by simp
    from ex have lz: "\<forall> z. z \<in> FV (ELam x eb) \<longrightarrow> lookup ((y,v'')#\<rho>) z = lookup \<rho> z" by auto
    from ex 3(2) lz env_strengthen[of v' "ELam x eb" \<rho> "(y,v'')#\<rho>"]
    have vp_E: "v' \<in> E e ((y,v'')#\<rho>)" by blast
    from vpp_E vp_E rr have ?case by blast
  } moreover { assume exb: "\<exists> e'. e = ELam x e' \<and> x \<noteq> y \<and> eb = subst y v e'"
    from exb obtain e'' where e: "e = ELam x e''" and xy: "x \<noteq> y"
      and eb: "eb = subst y v e''" by blast
    from 3(2) obtain f where vp: "v' = VFun f" by auto
    from 3(2) vp have f_E: "VFun f \<in> E (ELam x eb) \<rho>" by simp
    from 3(4) e xy have ls: "ELam x eb = ELam x (subst y v e'')" by simp
    from 3(3) eb have IH: "\<forall> v1 v2. v2 \<in> E (subst y v e'') ((x,v1)#\<rho>)
        \<longrightarrow> (\<exists> \<rho>' v'. v' \<in> E v [] \<and> v2 \<in> E e'' \<rho>' \<and> \<rho>' \<approx> (y,v')#(x,v1)#\<rho>)"
      apply clarify apply (subgoal_tac "(v1,v2) \<in> fset {|(v1,v2)|}") prefer 2 apply simp
      apply (rule 3(1)) apply assumption apply simp+ done
    from f_E 3(3) ls xy IH e vp have ?case apply clarify apply (rule reverse_subst_lam)
        apply blast+ done
  } moreover from 3(4) have "(e = EVar y \<and> v = ELam x eb)
      \<or> (e = ELam x eb \<and> x = y)
      \<or> (\<exists> e'. e = ELam x e' \<and> x \<noteq> y \<and> eb = subst y v e')" by (cases e) auto
  ultimately show ?case by blast
next
  case (4 e1 e2 \<rho>) \<comment> \<open>e' = EApp e1 e2\<close>
  from 4(4) 4(5) obtain e1' e2' where
    e: "e = EApp e1' e2'" and e1:"e1 = subst y v e1'" and e2: "e2 = subst y v e2'"
    apply (cases e) apply (rename_tac x) apply auto apply (case_tac "y = x") apply auto
    apply (rename_tac x1 x2) apply (case_tac "y = x1") apply auto done
  from 4(3) obtain f v2 and v2'::val and v3' where
    f_E: "VFun f \<in> E e1 \<rho>" and v2_E: "v2 \<in> E e2 \<rho>" and v23: "(v2',v3') \<in> fset f"
    and v2p_v2: "v2' \<sqsubseteq> v2" and vp_v3: "v' \<sqsubseteq> v3'" by blast
  from 4(1) f_E 4(4) e1 obtain \<rho>1 w1 where v1_Ev: "w1 \<in> E v []" and f_E1: "VFun f \<in> E e1' \<rho>1"
    and r1: "\<rho>1 \<approx> (y,w1)#\<rho>" by blast
  from 4(2) v2_E 4(4) e2 obtain \<rho>2 w2 where v2_Ev: "w2 \<in> E v []" and v2_E2: "v2 \<in> E e2' \<rho>2"
    and r2: "\<rho>2 \<approx> (y,w2)#\<rho>" by blast
  from 4(4) v1_Ev v2_Ev combine_values obtain w3 where
    w3_Ev: "w3 \<in> E v []" and w123: "w1 \<squnion> w2 = Some w3" by (simp only: is_val_def) blast
  from w123 le_union1 have w13: "w1 \<sqsubseteq> w3" by blast
  from w123 le_union2 have w23: "w2 \<sqsubseteq> w3" by blast
  from w13 have r13: "((y,w1)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
  from w23 have r23: "((y,w2)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
  from r1 f_E1 have f_E1b: "VFun f \<in> E e1' ((y,w1)#\<rho>)" by (rule env_swap)
  from f_E1b r13 have f_E1c: "VFun f \<in> E e1' ((y,w3)#\<rho>)" by (rule raise_env)
  from r2 v2_E2 have v2_E2b: "v2 \<in> E e2' ((y,w2)#\<rho>)" by (rule env_swap)
  from v2_E2b r23 have v2_E2c: "v2 \<in> E e2' ((y,w3)#\<rho>)" by (rule raise_env)
  from f_E1c v2_E2c v23 v2p_v2 vp_v3 have vp_E2: "v' \<in> E (EApp e1' e2') ((y,w3)#\<rho>)" by blast
  have rr3: "((y,w3)#\<rho>) \<approx> ((y,w3)#\<rho>)" by (simp add: env_eq_def)
  from w3_Ev vp_E2 rr3 e show ?case by blast
next
  case (5 f e1 e2 \<rho>) \<comment> \<open>e' = EPrim f e1 e2, very similar to case for EApp\<close>
  from 5(4) 5(5) obtain e1' e2' where
    e: "e = EPrim f e1' e2'" and e1:"e1 = subst y v e1'" and e2: "e2 = subst y v e2'"
    apply (cases e) apply auto apply (rename_tac x) apply (case_tac "y = x") apply auto
    apply (rename_tac x1 x2) apply (case_tac "y = x1") apply auto done
  from 5(3) obtain n1 n2 where
    n1_E: "VNat n1 \<in> E e1 \<rho>" and n2_E: "VNat n2 \<in> E e2 \<rho>" and vp: "v' = VNat (f n1 n2)" by blast
  from 5(1) n1_E 5(4) e1 obtain \<rho>1 w1 where v1_Ev: "w1 \<in> E v []" and n1_E1: "VNat n1 \<in> E e1' \<rho>1"
    and r1: "\<rho>1 \<approx> (y,w1)#\<rho>" by blast
  from 5(2) n2_E 5(4) e2 obtain \<rho>2 w2 where v2_Ev: "w2 \<in> E v []" and n2_E2: "VNat n2 \<in> E e2' \<rho>2"
    and r2: "\<rho>2 \<approx> (y,w2)#\<rho>" by blast
  from 5(4) v1_Ev v2_Ev combine_values obtain w3 where
    w3_Ev: "w3 \<in> E v []" and w123: "w1 \<squnion> w2 = Some w3" by (simp only: is_val_def) blast
  from w123 le_union1 have w13: "w1 \<sqsubseteq> w3" by blast
  from w123 le_union2 have w23: "w2 \<sqsubseteq> w3" by blast
  from w13 have r13: "((y,w1)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
  from w23 have r23: "((y,w2)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
  from r1 n1_E1 have n1_E1b: "VNat n1 \<in> E e1' ((y,w1)#\<rho>)" by (rule env_swap)
  from n1_E1b r13 have n1_E1c: "VNat n1 \<in> E e1' ((y,w3)#\<rho>)" by (rule raise_env)
  from r2 n2_E2 have n2_E2b: "VNat n2 \<in> E e2' ((y,w2)#\<rho>)" by (rule env_swap)
  from n2_E2b r23 have v2_E2c: "VNat n2 \<in> E e2' ((y,w3)#\<rho>)" by (rule raise_env)
  from n1_E1c v2_E2c vp have vp_E2: "v' \<in> E (EPrim f e1' e2') ((y,w3)#\<rho>)" by blast
  have rr3: "((y,w3)#\<rho>) \<approx> ((y,w3)#\<rho>)" by (simp add: env_eq_def)
  from w3_Ev vp_E2 rr3 e show ?case by blast
next
  case (6 e1 e2 e3 \<rho>) \<comment> \<open>e' = EIf e1 e2 e3\<close>
  from 6(5) 6(6) obtain e1' e2' e3' where
    e: "e = EIf e1' e2' e3'" and e1:"e1 = subst y v e1'" and e2: "e2 = subst y v e2'"
    and e3: "e3 = subst y v e3'"
    apply (cases e) apply auto apply (case_tac "y=x1") apply auto apply (case_tac "y=x31") by auto
  from 6(4) e_if_elim obtain n where n_E: "VNat n \<in> E e1 \<rho>" and
    els: "n = 0 \<longrightarrow> v' \<in> E e3 \<rho>" and thn: "n \<noteq> 0 \<longrightarrow> v' \<in> E e2 \<rho>" by blast
  from 6 n_E e1 obtain \<rho>1 w1 where w1_Ev: "w1 \<in> E v []" and n_E2: "VNat n \<in> E e1' \<rho>1"
    and r1: "\<rho>1 \<approx> (y,w1)#\<rho>" by blast
  show ?case
  proof (cases "n = 0")
    case True with els have vp_E2: "v' \<in> E e3 \<rho>" by simp
    from 6 vp_E2 e3 obtain \<rho>2 w2 where w2_Ev: "w2 \<in> E v []" and vp_E2: "v' \<in> E e3' \<rho>2"
    and r2: "\<rho>2 \<approx> (y,w2)#\<rho>" by blast
    from 6(5) w1_Ev w2_Ev combine_values obtain w3 where
      w3_Ev: "w3 \<in> E v []" and w123: "w1 \<squnion> w2 = Some w3" by (simp only: is_val_def) blast
    from w123 le_union1 have w13: "w1 \<sqsubseteq> w3" by blast
    from w123 le_union2 have w23: "w2 \<sqsubseteq> w3" by blast
    from w13 have r13: "((y,w1)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
    from w23 have r23: "((y,w2)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
    from r1 n_E2 have n_E1b: "VNat n \<in> E e1' ((y,w1)#\<rho>)" by (rule env_swap)
    from n_E1b r13 have n_E1c: "VNat n \<in> E e1' ((y,w3)#\<rho>)" by (rule raise_env)
    from r2 vp_E2 have vp_E2b: "v' \<in> E e3' ((y,w2)#\<rho>)" by (rule env_swap)
    from vp_E2b r23 have vp_E2c: "v' \<in> E e3' ((y,w3)#\<rho>)" by (rule raise_env)
    have rr3: "((y,w3)#\<rho>) \<approx> ((y,w3)#\<rho>)" by (simp add: env_eq_def)
    from True n_E1c vp_E2c e have vp_E3: "v' \<in> E e ((y,w3)#\<rho>)" by auto
    from w3_Ev rr3 vp_E3 show ?thesis by blast
  next
    case False with thn have vp_E2: "v' \<in> E e2 \<rho>" by simp
    from 6 vp_E2 e2 obtain \<rho>2 w2 where w2_Ev: "w2 \<in> E v []" and vp_E2: "v' \<in> E e2' \<rho>2"
    and r2: "\<rho>2 \<approx> (y,w2)#\<rho>" by blast
    from 6(5) w1_Ev w2_Ev combine_values obtain w3 where
      w3_Ev: "w3 \<in> E v []" and w123: "w1 \<squnion> w2 = Some w3" by (simp only: is_val_def) blast
    from w123 le_union1 have w13: "w1 \<sqsubseteq> w3" by blast
    from w123 le_union2 have w23: "w2 \<sqsubseteq> w3" by blast
    from w13 have r13: "((y,w1)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
    from w23 have r23: "((y,w2)#\<rho>) \<sqsubseteq> ((y,w3)#\<rho>)" by (simp add: env_le_def)
    from r1 n_E2 have n_E1b: "VNat n \<in> E e1' ((y,w1)#\<rho>)" by (rule env_swap)
    from n_E1b r13 have n_E1c: "VNat n \<in> E e1' ((y,w3)#\<rho>)" by (rule raise_env)
    from r2 vp_E2 have vp_E2b: "v' \<in> E e2' ((y,w2)#\<rho>)" by (rule env_swap)
    from vp_E2b r23 have vp_E2c: "v' \<in> E e2' ((y,w3)#\<rho>)" by (rule raise_env)
    have rr3: "((y,w3)#\<rho>) \<approx> ((y,w3)#\<rho>)" by (simp add: env_eq_def)
    from False n_E1c vp_E2c e have vp_E3: "v' \<in> E e ((y,w3)#\<rho>)" by auto
    from w3_Ev rr3 vp_E3 show ?thesis by blast
  qed
qed

subsection "Reverse reduction preserves denotation"

lemma reverse_step_pres_denot:
  fixes e::exp assumes e_ep: "e \<longrightarrow> e'" and v_ep: "v \<in> E e' \<rho>"
  shows "v \<in> E e \<rho>"
  using e_ep v_ep
proof (induction arbitrary: v \<rho> rule: reduce.induct)
  case (beta v x e v' \<rho>)
  from beta obtain \<rho>' v'' where 1: "v'' \<in> E v []" and 2: "v' \<in> E e \<rho>'" and 3: "\<rho>' \<approx> (x, v'') # \<rho>"
    using reverse_subst_pres_denot[of v' "subst x v e" \<rho> v x e] by blast
  from beta 1 2 3 show ?case
    apply simp apply (rule_tac x="{|(v'',v')|}" in exI) apply (rule conjI)
     apply clarify apply simp apply clarify apply (rule env_swap) apply blast apply blast
    apply (rule_tac x=v'' in exI) apply (rule conjI) apply (rule env_strengthen)
      apply assumption apply force apply force done
qed auto

lemma reverse_multi_step_pres_denot:
  fixes e::exp assumes e_ep: "e \<longrightarrow>* e'" and v_ep: "v \<in> E e' \<rho>" shows "v \<in> E e \<rho>"
  using e_ep v_ep reverse_step_pres_denot
  by (induction arbitrary: v \<rho> rule: multi_step.induct) auto

subsection "Completeness"

theorem completeness:
  assumes ev: "e \<longrightarrow>* v"and vv: "is_val v"
  shows "\<exists> v'. v' \<in> E e \<rho> \<and> v' \<in> E v []"
proof -
  from vv have "\<exists> v'. v' \<in> E v []" using e_val by auto
  from this obtain v' where vp_v: "v' \<in> E v []" by blast
  from vp_v vv have vp_v2: "v' \<in> E v \<rho>" using env_strengthen by force
  from ev vp_v2 reverse_multi_step_pres_denot[of e v v' \<rho>]
  have "v' \<in> E e \<rho>" by simp
  from this vp_v show ?thesis by blast
qed

theorem reduce_pres_denot: fixes e::exp assumes r: "e \<longrightarrow> e'" shows "E e = E e'"
  apply (rule ext) apply (rule equalityI) apply (rule subsetI)
   apply (rule subject_reduction) apply assumption using r apply assumption
  apply (rule subsetI)
  using r apply (rule reverse_step_pres_denot) apply assumption
  done

theorem multi_reduce_pres_denot: fixes e::exp assumes r: "e \<longrightarrow>* e'" shows "E e = E e'"
  using r reduce_pres_denot by induction auto

theorem complete_wrt_op_sem:
  assumes e_n: "e \<Down> ONat n" shows "E e [] = E (ENat n) []"
proof -
  from e_n have 1: "e \<longrightarrow>* ENat n"
    unfolding run_def apply simp apply (erule exE)
    apply (rename_tac v) apply (case_tac v) apply auto done
  from 1 show ?thesis using multi_reduce_pres_denot by simp
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Equivalence between Separation Algebra Formulations"

theory Sep_Eq
imports
  Separation_Algebra
  Separation_Algebra_Alt
begin

text {*
  In this theory we show that our total formulation of separation algebra is
  equivalent in strength to Calcagno et al's original partial one.

  This theory is not intended to be included in own developments.
*}

no_notation map_add (infixl "++" 100)
declare [[syntax_ambiguity_warning = false]]

section "Total implies Partial"

definition add2 :: "'a::sep_algebra => 'a => 'a option" where
  "add2 x y \<equiv> if x ## y then Some (x + y) else None"

lemma add2_zero: "add2 x 0 = Some x"
  by (simp add: add2_def)

lemma add2_assoc:
  "lift2 add2 a (lift2 add2 b c) = lift2 add2 (lift2 add2 a b) c"
  by (auto simp: add2_def lift2_def sep_add_assoc
              dest: sep_disj_addD sep_disj_addI3
                    sep_add_disjD sep_disj_addI2 sep_disj_commuteI
              split: option.splits)

interpretation total_partial: sep_algebra_alt 0 add2
  by (unfold_locales) (auto intro: add2_zero add2_comm add2_assoc)

section "Partial implies Total"

definition
  sep_add' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a :: sep_algebra_alt" where
  "sep_add' x y \<equiv> if disjoint x y then the (add x y) else undefined"

lemma sep_disj_zero':
  "disjoint x 0"
  by simp

lemma sep_disj_commuteI':
  "disjoint x y \<Longrightarrow> disjoint y x"
  by (clarsimp simp: disjoint_def add_comm)

lemma sep_add_zero':
  "sep_add' x 0 = x"
  by (simp add: sep_add'_def)

lemma sep_add_commute':
  "disjoint x y \<Longrightarrow> sep_add' x y = sep_add' y x"
  by (clarsimp simp: sep_add'_def disjoint_def add_comm)

lemma sep_add_assoc':
  "\<lbrakk> disjoint x y; disjoint y z; disjoint x z \<rbrakk> \<Longrightarrow>
  sep_add' (sep_add' x y) z = sep_add' x (sep_add' y z)"
  using add_assoc [of "Some x" "Some y" "Some z"]
  by (clarsimp simp: disjoint_def sep_add'_def lift2_def
               split: option.splits)

lemma sep_disj_addD1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint x y"
proof (clarsimp simp: disjoint_def sep_add'_def)
  fix a assume a: "y \<oplus> z = Some a"
  fix b assume b: "x \<oplus> a = Some b"
  with a have "Some x ++ (Some y ++ Some z) = Some b" by (simp add: lift2_def)
  hence "(Some x ++ Some y) ++ Some z = Some b" by (simp add: add_assoc)
  thus "\<exists>b. x \<oplus> y = Some b" by (simp add: lift2_def split: option.splits)
qed

lemma sep_disj_addI1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint (sep_add' x y) z"
  apply (clarsimp simp: disjoint_def sep_add'_def)
  apply (rule conjI)
   apply clarsimp
   apply (frule lift_to_add2, assumption)
   apply (simp add: add_assoc)
   apply (clarsimp simp: lift2_def add_comm)
  apply clarsimp
  apply (frule lift_to_add2, assumption)
  apply (simp add: add_assoc)
  apply (clarsimp simp: lift2_def)
  done

interpretation partial_total: sep_algebra sep_add' 0 disjoint
  apply (unfold_locales)
        apply (rule sep_disj_zero')
       apply (erule sep_disj_commuteI')
      apply (rule sep_add_zero')
     apply (erule sep_add_commute')
    apply (erule (2) sep_add_assoc')
   apply (erule (1) sep_disj_addD1')
  apply (erule (1) sep_disj_addI1')
  done

end


(*  Title:       Interuptible Fold
    Author:      Thomas Tuerk <tuerk@in.tum.de>
*)
section {* Interuptible Fold *}
theory Foldi
imports Main
begin

subsection {* Left folding *}

primrec foldli where
   "foldli [] c f \<sigma> = \<sigma>"
 | "foldli (x#xs) c f \<sigma> =
    (if c \<sigma> then foldli xs c f (f x \<sigma>) else \<sigma>)"

lemma foldli_not_cond [simp] :
   "\<not>(c \<sigma>) \<Longrightarrow>foldli xs c f \<sigma> = \<sigma>"
by (cases xs, simp_all)

lemma foldli_cong [fundef_cong]:
  assumes "l = l'" "\<sigma> = \<sigma>'" "c = c'"
  and ff': "\<And>\<sigma> x. \<lbrakk> x \<in> set l'; c' \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> = f' x \<sigma>"
  shows "foldli l c f \<sigma> = foldli l' c' f' \<sigma>'"
unfolding assms using ff'
by(induct l' arbitrary: \<sigma>') auto

text {* Notice that @{term foldli} is a generalisation of folding that respects the abortion condition. *}
lemma foldli_foldl :
  "foldli xs (\<lambda>_. True) f \<sigma> = foldl (\<lambda>\<sigma> x. f x \<sigma>) \<sigma> xs"
by (induct xs arbitrary: \<sigma>) simp_all

lemma foldli_append :
   "foldli (xs1 @ xs2) c f \<sigma> =
    foldli xs2 c f (foldli xs1 c f \<sigma>)"
by (induct xs1 arbitrary: \<sigma>, simp_all)

lemma foldli_concat :
   "foldli (concat xs) c f \<sigma> =
    foldli xs c (\<lambda>x. foldli x c f) \<sigma>"
by (induct xs arbitrary: \<sigma>, simp_all add: foldli_append)

lemma foldli_map :
  "foldli (map f1 xs) c f2 \<sigma> =
   foldli xs c (f2 \<circ> f1) \<sigma>"
by (induct xs arbitrary: \<sigma>, simp_all)

lemma foldli_snoc :
   "foldli (xs @ [x]) c f \<sigma> =
    (if c (foldli xs c f \<sigma>) then
     f x (foldli xs c f \<sigma>) else (foldli xs c f \<sigma>))"
by (induct xs arbitrary: \<sigma>, simp_all)

lemma foldli_snoc_id[simp]: "foldli l (\<lambda>_. True) (\<lambda>x l. l@[x]) l0 = l0@l"
  by (induct l arbitrary: l0) (auto)

subsection {* Right folding *}

definition foldri :: "'x list \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> ('x \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"  where
  "foldri l = foldli (rev l)"

lemma foldri_simp[simp] :
  "foldri [] c f \<sigma> = \<sigma>"
  "foldri (l@[x]) c f \<sigma> = (if c \<sigma> then foldri l c f (f x \<sigma>) else \<sigma>)"
  unfolding foldri_def by simp_all

lemma foldri_simp_Cons[simp] :
  "foldri (x # l) c f \<sigma> = (if (c (foldri l c f \<sigma>)) then  f x (foldri l c f \<sigma>) else (foldri l c f \<sigma>))"
  unfolding foldri_def by (simp add: foldli_append)

lemma foldri_code[code] :
  "foldri [] c f \<sigma> = \<sigma>"
  "foldri (x # l) c f \<sigma> = (let \<sigma>' = foldri l c f \<sigma> in if c \<sigma>' then  f x \<sigma>' else \<sigma>')"
  by simp_all

lemma foldri_not_cond [simp] :
   "\<not>(c \<sigma>) \<Longrightarrow>foldri xs c f \<sigma> = \<sigma>"
unfolding foldri_def by simp

lemma foldri_cong [fundef_cong]:
  assumes "l = l'" "\<sigma> = \<sigma>'" "c = c'"
  and ff': "\<And>\<sigma> x. \<lbrakk> x \<in> set l'; c' \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> = f' x \<sigma>"
  shows "foldri l c f \<sigma> = foldri l' c' f' \<sigma>'"
unfolding assms using ff'
by(induct l' arbitrary: \<sigma>') auto

text {* Notice that @{term foldli} is a generalisation of folding that respects the abortion condition. *}
lemma foldri_foldr :
  "foldri xs (\<lambda>_. True) f \<sigma> = foldr (\<lambda>x \<sigma>. f x \<sigma>) xs \<sigma>"
by (induct xs arbitrary: \<sigma>) simp_all

lemma foldri_append :
   "foldri (xs1 @ xs2) c f \<sigma> =
    foldri xs1 c f (foldri xs2 c f \<sigma>)"
unfolding foldri_def
by (simp add: foldli_append)

lemma foldri_concat :
   "foldri (concat xs) c f \<sigma> =
    foldri xs c (\<lambda>x. foldri x c f) \<sigma>"
unfolding foldri_def
by (simp add: rev_concat foldli_concat foldli_map o_def)

lemma foldri_map :
  "foldri (map f1 xs) c f2 \<sigma> =
   foldri xs c (f2 \<circ> f1) \<sigma>"
unfolding foldri_def
by (simp add: rev_map foldli_map)

lemma foldri_cons_id[simp]: "foldri l (\<lambda>_. True) (\<lambda>x l. x#l) [] = l"
  by (induct l) (auto)

end


(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory List_local
imports Extra "~~/src/HOL/Library/While_Combinator"
begin

text{* Partition a list with respect to an equivalence relation. *}

text{* First up: split a list according to a relation. *}

abbreviation "rel_ext r \<equiv> { x . r x }"

definition
  partition_split_body :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list \<times> 'a list \<Rightarrow> 'a list \<times> 'a list"
where
  [code]: "partition_split_body r x \<equiv> \<lambda>y (X', xc).
            if r (x, y) then (X', List.insert y xc) else (List.insert y X', xc)"

definition
  partition_split :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list"
where
  [code]: "partition_split r x xs \<equiv> foldr (partition_split_body r x) xs ([], [])"

lemma partition_split:
  shows "set (fst (partition_split r x xs)) = set xs - (rel_ext r `` {x})"
    and "set (snd (partition_split r x xs)) = set xs \<inter> (rel_ext r `` {x})"
using assms
proof(induct xs)
  case Nil
  { case 1 with Nil show ?case
      unfolding partition_split_def by simp }
  { case 2 with Nil show ?case
      unfolding partition_split_def by simp }
next
  case (Cons x xs)
  { case 1 with Cons show ?case
      unfolding partition_split_def
      apply simp
      apply (subst partition_split_body_def)
      apply (split split_split)
      apply clarsimp
      apply rule
       apply clarsimp
      apply clarsimp
      unfolding Image_def
      apply auto
      done }
  { case 2 with Cons show ?case
      unfolding partition_split_def
      apply simp
      apply (subst partition_split_body_def)
      apply (split split_split)
      apply clarsimp
      apply rule
       apply clarsimp
      apply clarsimp
      done }
qed

lemma partition_split':
  assumes "partition_split r x xs = (xxs', xec)"
  shows "set xxs' = set xs - (rel_ext r `` {x})"
    and "set xec = set xs \<inter> (rel_ext r `` {x})"
  using assms partition_split[where r=r and x=x and xs=xs]
  by simp_all

text{* Next, split an list on each of its members. For this to be
unambiguous @{term "r"} must be an equivalence relation. *}

definition
  partition_aux_body :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<times> 'a list list \<Rightarrow> 'a list \<times> 'a list list"
where
  "partition_aux_body \<equiv> \<lambda>r (xxs, ecs). case xxs of [] \<Rightarrow> ([], []) | x # xs \<Rightarrow>
                           let (xxs', xec) = partition_split r x xs
                            in (xxs', (x # xec) # ecs)"

definition
  partition_aux :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list list"
where
  [code]: "partition_aux r xs \<equiv>
             while (Not \<circ> List.null \<circ> fst) (partition_aux_body r) (xs, [])"

(* FIXME move these. *)

lemma equiv_subseteq_in_sym:
  "\<lbrakk> r `` X \<subseteq> X;  (x, y) \<in> r; y \<in> X; equiv Y r; X \<subseteq> Y \<rbrakk> \<Longrightarrow> x \<in> X"
  unfolding equiv_def by (auto dest: symD)

lemma FIXME_refl_on_insert_absorb[simp]:
  "\<lbrakk> refl_on A r; x \<in> A \<rbrakk> \<Longrightarrow> insert x (r `` {x}) = r `` {x}"
  by (auto dest: refl_onD)

lemma equiv_subset[intro]:
  "\<lbrakk> equiv A r; B \<subseteq> A \<rbrakk> \<Longrightarrow> equiv B (r \<inter> B \<times> B)"
  unfolding equiv_def by (auto intro: refl_onI symI transI dest: refl_onD symD transD)

lemma FIXME_fiddle1: "\<lbrakk> x \<in> Y; X \<subseteq> Y; refl_on Y r \<rbrakk> \<Longrightarrow> insert x (X \<inter> r `` {x}) = (insert x X) \<inter> r `` {x}"
  by (auto dest: refl_onD)

lemma FIXME_second_fiddle:
  "\<lbrakk> (r \<inter> Y \<times> Y) `` X \<subseteq> X; refl_on Z r; x \<in> X; X \<subseteq> Y; Y \<subseteq> Z \<rbrakk>
     \<Longrightarrow> (r \<inter> (Y - (X - r `` {x})) \<times> (Y - (X - r `` {x}))) `` {x}
       = (r \<inter> X \<times> X) `` {x}"
  by (blast dest: refl_onD)

lemma FIXME_third_fiddle:
  "\<lbrakk> (r \<inter> Y \<times> Y) `` X \<subseteq> X; X \<subseteq> Y; x \<in> X; y \<in> Y - X    ;    r `` {y} \<inter> X = {} \<rbrakk>
     \<Longrightarrow> (r \<inter> (Y - (X - r `` {x})) \<times> (Y - (X - r `` {x}))) `` {y}
       = (r \<inter> (Y - X) \<times> (Y - X)) `` {y}"
  by auto

lemma partition_aux:
  assumes equiv: "equiv X (rel_ext r)"
      and XZ: "set xs \<subseteq> X"
  shows "fst (partition_aux r xs) = []
       \<and> set ` set (snd (partition_aux r xs))
       = (set xs // (rel_ext r \<inter> set xs \<times> set xs))"
proof -
  let ?b = "Not \<circ> List.null \<circ> fst"
  let ?c = "partition_aux_body r"
  let ?r' = "\<lambda>A. rel_ext r \<inter> A \<times> A"
  let ?P1 = "\<lambda>(A, B). set A \<subseteq> set xs"
  let ?P2 = "\<lambda>(A, B). ?r' (set xs) `` set A \<subseteq> set A"
  let ?P3 = "\<lambda>(A, B). set ` set B = ((set xs - set A) // ?r' (set xs - set A))"
  let ?P = "\<lambda>AB. ?P1 AB \<and> ?P2 AB \<and> ?P3 AB"
  let ?wfr = "inv_image finite_psubset (set \<circ> fst)"
  show ?thesis
  unfolding partition_aux_def
  proof(rule while_rule[where P="?P" and r="?wfr"])
    from equiv XZ show "?P (xs, [])" by auto
  next
    fix s assume P: "?P s" and b: "?b s"

    obtain A B where s: "s = (A, B)" by (cases s) blast

    moreover
    from XZ P s have "?P1 (?c (A, B))"
      unfolding partition_aux_body_def
      apply clarsimp
      apply (cases A)
       apply simp
      apply simp
      apply (case_tac "partition_split r aa list")
      apply (simp add: partition_split')
      apply auto
      done

    moreover
    from equiv XZ P s have "?P2 (?c s)"
      unfolding partition_aux_body_def
      apply clarsimp
      apply (cases A)
       apply simp
      apply simp
      apply (case_tac "partition_split r aa list")
      apply (simp add: partition_split')
      unfolding equiv_def
      apply (auto dest: symD transD elim: quotientE)
      done

    moreover
    have "?P3 (?c s)"
    proof -
      from b s obtain x where x: "x \<in> set A" by (cases A) (auto iff: null_def)
      with XZ equiv P b s x
      show ?thesis
        unfolding partition_aux_body_def
        apply clarsimp
        apply (erule equivE)
        apply (cases A)
         apply simp
        apply simp
        apply (case_tac "partition_split r aa list")
        apply clarsimp
        apply (simp add: partition_split')

        apply (subst FIXME_fiddle1[where Y=X])
           apply blast
          apply auto[1]
         apply blast

        apply rule
         apply clarsimp
         apply rule
          apply (rule_tac x=aa in quotientI2)
           apply (blast dest: refl_onD)
          using XZ
          apply (auto dest: refl_onD)[1]
         apply clarsimp
         apply (erule quotientE)
         apply clarsimp
         apply (rule_tac x=xa in quotientI2)
          apply (blast dest: refl_onD)
         apply rule
          apply clarsimp
         apply clarsimp
         apply rule
          apply rule
          apply clarsimp
          apply (cut_tac X="insert aa (set list)" and Y="set xs" and x=xa and y=aa and r="rel_ext r \<inter> set xs \<times> set xs" in equiv_subseteq_in_sym)
          apply simp_all
          using equiv
          apply blast
         apply clarsimp
         apply (cut_tac X="insert aa (set list)" and Y="set xs" and x=xa and y=xb and r="rel_ext r \<inter> set xs \<times> set xs" in equiv_subseteq_in_sym)
         apply simp_all
         using equiv
         apply blast

        apply (rule subsetI)
        apply (erule quotientE)
        apply (case_tac "xaa = aa")
         apply auto[1]
        apply clarsimp

        apply (case_tac "xa \<in> set list")
         apply clarsimp
         apply rule
          apply (auto dest: transD)[1]
         apply (auto dest: symD transD)[1]

        unfolding quotient_def
        apply clarsimp
        apply (erule_tac x=xa in ballE)
         unfolding Image_def
         apply clarsimp
        apply (auto dest: symD transD)  (* SLOW *)
        done
    qed

    ultimately show "?P (?c s)" by auto
  next
    fix s assume P: "?P s" and b: "\<not> (?b s)"
    from b have F: "fst s = []"
      apply (cases s)
      apply simp
      apply (case_tac a)
      apply (simp_all add: List.null_def)
      done
    from equiv P F have S: "set ` set (snd s) = (set xs // ?r' (set xs))"
      apply (cases s)
      unfolding Image_def
      apply simp
      done
    from F S show "fst s = [] \<and> set ` set (snd s) = (set xs // ?r' (set xs))"
      by (simp add: prod_eqI)
  next
    show "wf ?wfr" by (blast intro: wf_finite_psubset Int_lower2 [THEN [2] wf_subset])
  next
    fix s assume P: "?P s" and b: "?b s"
    from equiv XZ P b have "set (fst (?c s)) \<subset> set (fst s)"
      apply -
      apply (cases s)
      apply (simp add: Let_def)
      unfolding partition_aux_body_def
      apply clarsimp
      apply (case_tac a)
       apply (simp add: List.null_def)
      apply simp
      apply (case_tac "partition_split r aa list")
      apply (simp add: partition_split')

      unfolding equiv_def
      apply (auto dest: refl_onD)
      done
    thus "(?c s, s) \<in> ?wfr" by auto
  qed
qed

definition
  partition :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list list"
where
  [code]: "partition r xs \<equiv> snd (partition_aux r xs)"

lemma partition:
  assumes equiv: "equiv X (rel_ext r)"
      and xs: "set xs \<subseteq> X"
  shows "set ` set (partition r xs) = set xs // ((rel_ext r) \<inter> set xs \<times> set xs)"
  unfolding partition_def
  using partition_aux[OF equiv xs] by simp

(* **************************************** *)

fun
  odlist_equal :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "odlist_equal [] [] = True"
| "odlist_equal [] ys = False"
| "odlist_equal xs [] = False"
| "odlist_equal (x # xs) (y # ys) = (x = y \<and> odlist_equal xs ys)"

declare odlist_equal.simps [code]

lemma equal_odlist_equal[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> odlist_equal xs ys \<longleftrightarrow> (xs = ys)"
  by (induct xs ys rule: odlist_equal.induct) (auto iff: sorted_Cons)

fun
  difference :: "('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "difference [] ys = []"
| "difference xs [] = xs"
| "difference (x # xs) (y # ys) =
     (if x = y then difference xs ys
               else if x < y then x # difference xs (y # ys)
                             else difference (x # xs) ys)"

declare difference.simps [code]

lemma set_difference[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> set (difference xs ys) = set xs - set ys"
  by (induct xs ys rule: difference.induct) (auto iff: sorted_Cons)

lemma distinct_sorted_difference[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> distinct (difference xs ys) \<and> sorted (difference xs ys)"
  by (induct xs ys rule: difference.induct) (auto iff: sorted_Cons)

fun
  intersection :: "('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "intersection [] ys = []"
| "intersection xs [] = []"
| "intersection (x # xs) (y # ys) =
     (if x = y then x # intersection xs ys
               else if x < y then intersection xs (y # ys)
                             else intersection (x # xs) ys)"

declare intersection.simps [code]

lemma set_intersection[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> set (intersection xs ys) = set xs \<inter> set ys"
  by (induct xs ys rule: intersection.induct) (auto iff: sorted_Cons)

lemma distinct_sorted_intersection[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> distinct (intersection xs ys) \<and> sorted (intersection xs ys)"
  by (induct xs ys rule: intersection.induct) (auto iff: sorted_Cons)

(* This is a variant of zipWith *)
fun
  image :: "('a :: linorder \<times> 'b :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'b list"
where
  "image [] xs = []"
| "image R []  = []"
| "image ((x, y) # rs) (z # zs) =
     (if x = z then y # image rs (z # zs)
               else if x < z then image rs (z # zs)
                             else image ((x, y) # rs) zs)"

declare image.simps [code]

lemma set_image[simp]:
  "\<lbrakk> distinct R; distinct xs; sorted R; sorted xs \<rbrakk>
     \<Longrightarrow> set (image R xs) = set R `` set xs"
  by (induct R xs rule: image.induct) (auto iff: less_eq_prod_def simp: sorted_Cons)

(* Extra lemmas that really belong in List.thy *)

lemma sorted_filter[simp]:
  "sorted xs \<Longrightarrow> sorted (filter P xs)"
  by (induct xs) (auto iff: sorted_Cons)

lemma map_prod_eq:
  assumes f: "map fst xs = map fst ys"
      and s: "map snd xs = map snd ys"
  shows "xs = ys"
  using assms by (induct rule: list_induct2[OF map_eq_imp_length_eq[OF f]]) (simp_all add: prod_eqI)

lemma list_choose_hd:
  assumes "\<forall>x \<in> set xs. P x"
      and "x \<in> set xs"
  shows "P (List.hd xs)"
  using assms by (induct xs arbitrary: x) auto

end


section \<open>Examples\<close>

subsection \<open>Monadic interpreter\<close>

theory Interpreter imports Monomorphic_Monad begin

declare [[show_variants]]

definition "apply" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where "apply f x = f x"

lemma apply_eq_onp: includes lifting_syntax shows "(eq_onp P ===> (=) ===> (=)) apply apply"
by(simp add: rel_fun_def eq_onp_def)

subsubsection \<open>Basic interpreter\<close>

datatype (vars: 'v) exp = Var 'v | Const int | Plus "'v exp" "'v exp" | Div "'v exp" "'v exp"

lemma rel_exp_simps [simp]:
  "rel_exp V (Var x) e' \<longleftrightarrow> (\<exists>y. e' = Var y \<and> V x y)"
  "rel_exp V (Const n) e' \<longleftrightarrow> e' = Const n"
  "rel_exp V (Plus e1 e2) e' \<longleftrightarrow> (\<exists>e1' e2'. e' = Plus e1' e2' \<and> rel_exp V e1 e1' \<and> rel_exp V e2 e2')"
  "rel_exp V (Div e1 e2) e' \<longleftrightarrow> (\<exists>e1' e2'. e' = Div e1' e2' \<and> rel_exp V e1 e1' \<and> rel_exp V e2 e2')"
  "rel_exp V e (Var y) \<longleftrightarrow> (\<exists>x. e = Var x \<and> V x y)"
  "rel_exp V e (Const n) \<longleftrightarrow> e = Const n"
  "rel_exp V e (Plus e1' e2') \<longleftrightarrow> (\<exists>e1 e2. e = Plus e1 e2 \<and> rel_exp V e1 e1' \<and> rel_exp V e2 e2')"
  "rel_exp V e (Div e1' e2') \<longleftrightarrow> (\<exists>e1 e2. e = Div e1 e2 \<and> rel_exp V e1 e1' \<and> rel_exp V e2 e2')"
by(auto elim: exp.rel_cases)

lemma finite_vars [simp]: "finite (vars e)"
by induction auto

locale exp_base = monad_fail_base return bind fail
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
begin

context fixes E :: "'v \<Rightarrow> 'm" begin
primrec eval :: "'v exp \<Rightarrow> 'm"
where
  "eval (Var x) = E x"
| "eval (Const i) = return i"
| "eval (Plus e1 e2) = bind (eval e1) (\<lambda>i. bind (eval e2) (\<lambda>j. return (i + j)))"
| "eval (Div e1 e2) = bind (eval e1) (\<lambda>i. bind (eval e2) (\<lambda>j. if j = 0 then fail else return (i div j)))"

end

context fixes \<sigma> :: "'v \<Rightarrow> 'w exp" begin
primrec subst :: "'v exp \<Rightarrow> 'w exp"
where
  "subst (Const n) = Const n"
| "subst (Var x) = \<sigma> x"
| "subst (Plus e1 e2) = Plus (subst e1) (subst e2)"
| "subst (Div e1 e2) = Div (subst e1) (subst e2)"
end

lemma compositional: "eval E (subst \<sigma> e) = eval (eval E \<circ> \<sigma>) e"
by induction simp_all

end

lemma eval_parametric [transfer_rule]:
  includes lifting_syntax shows
  "(((=) ===> M) ===> (M ===> ((=) ===> M) ===> M) ===> M ===> (V ===> M) ===> rel_exp V ===> M)
   exp_base.eval exp_base.eval"
unfolding exp_base.eval_def by transfer_prover

declare exp_base.eval.simps [code]

context exp_base begin

lemma eval_cong:
  assumes "\<And>x. x \<in> vars e \<Longrightarrow> E x = E' x"
  shows "eval E e = eval E' e"
  including lifting_syntax
proof -
  define V where "V \<equiv> eq_onp (\<lambda>x. x \<in> vars e)"
  have [transfer_rule]: "rel_exp V e e" by(rule exp.rel_refl_strong)(simp add: V_def eq_onp_def)
  have [transfer_rule]: "(V ===> (=)) E E'" using assms by(auto simp add: V_def rel_fun_def eq_onp_def)
  show ?thesis by transfer_prover
qed

end

subsubsection \<open>Memoisation\<close>

lemma case_option_apply: "case_option none some x y = case_option (none y) (\<lambda>a. some a y) x"
by(simp split: option.split)

lemma (in monad_base) bind_if2:
  "bind m (\<lambda>x. if b then t x else e x) = (if b then bind m t else bind m e)"
by simp

lemma (in monad_base) bind_case_option2:
  "bind m (\<lambda>x. case_option (none x) (some x) y) = case_option (bind m none) (\<lambda>a. bind m (\<lambda>x. some x a)) y"
by(simp split: option.split)

locale memoization_base = monad_state_base return bind get put
  for return :: "('a, 'm) return"
  and bind :: "('a, 'm) bind"
  and get :: "('k \<rightharpoonup> 'a, 'm) get"
  and put :: "('k \<rightharpoonup> 'a, 'm) put"
begin

definition memo :: "('k \<Rightarrow> 'm) \<Rightarrow> 'k \<Rightarrow> 'm"
where
  "memo f x =
   get (\<lambda>table.
   case table x of Some y \<Rightarrow> return y
   | None \<Rightarrow> bind (f x) (\<lambda>y. update (\<lambda>m. m(x \<mapsto> y)) (return y)))"

lemma memo_cong [cong, fundef_cong]: "\<lbrakk> x = y; f y = g y \<rbrakk> \<Longrightarrow> memo f x = memo g y"
by(simp add: memo_def cong del: option.case_cong_weak)

end

declare memoization_base.memo_def [code]

locale memoization = memoization_base return bind get put + monad_state return bind get put
  for return :: "('a, 'm) return"
  and bind :: "('a, 'm) bind"
  and get :: "('k \<rightharpoonup> 'a, 'm) get"
  and put :: "('k \<rightharpoonup> 'a, 'm) put"
begin

lemma memo_idem: "memo (memo f) x = memo f x"
proof -
  have "memo (memo f) x = get
    (\<lambda>table. case table x of
       None \<Rightarrow> get (\<lambda>table'. bind (case table' x of None \<Rightarrow> bind (f x) (\<lambda>y. update (\<lambda>m. m(x \<mapsto> y)) (return y))
                                                | Some x \<Rightarrow> return x)
                             (\<lambda>y. update (\<lambda>m. m ++ [x \<mapsto> y]) (return y)))
      | Some y \<Rightarrow> get (\<lambda>_. return y))"
    by(simp add: memo_def get_const bind_get cong del: option.case_cong_weak)
  also have "\<dots> = memo f x"
    by(simp add: option.case_distrib[where h="get", symmetric] get_get case_option_apply bind_assoc update_update bind_update return_bind o_def memo_def cong: option.case_cong)
  finally show ?thesis .
qed

lemma memo_same:
  "bind (memo f x) (\<lambda>a. bind (memo f x) (g a)) = bind (memo f x) (\<lambda>a. g a a)"
apply(simp cong: option.case_cong add: memo_def bind_get option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc bind_update return_bind update_get o_def get_const)
apply(subst (3) get_const[symmetric])
apply(subst option.case_distrib[where h=get, symmetric])
apply(subst get_get)
apply(simp add: case_option_apply cong: option.case_cong)
done

lemma memo_commute:
  assumes f_bind: "\<And>m x g. bind m (\<lambda>a. bind (f x) (g a)) = bind (f x) (\<lambda>b. bind m (\<lambda>a. g a b))"
    and f_get: "\<And>x g. get (\<lambda>s. bind (f x) (g s)) = bind (f x) (\<lambda>a. get (\<lambda>s. g s a))"
  shows "bind (memo f x) (\<lambda>a. bind (memo f y) (g a)) = bind (memo f y) (\<lambda>b. bind (memo f x) (\<lambda>a. g a b))"
proof -
  note option.case_cong[cong]
  have update_f: "update F (bind (f x) g) = bind (f x) (\<lambda>a. update F (g a))" for F x g
  proof -
    fix UU
    have "update F (bind (f x) g) = bind (update F (return UU)) (\<lambda>_. bind (f x) g)"
      by(simp add: bind_update return_bind)
    also have "\<dots> = bind (f x) (\<lambda>a. bind (update F (return UU)) (\<lambda>_. g a))"
      by(rule f_bind)
    also have "\<dots> = bind (f x) (\<lambda>a. update F (g a))"
      by(simp add: bind_update return_bind)
    finally show ?thesis .
  qed
  show ?thesis
    apply(clarsimp simp add: memo_def bind_get option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc bind_update return_bind update_get o_def f_get[symmetric] option.case_distrib[where h="get", symmetric] get_get case_option_apply if_distrib[where f="case_option _ _"] if_distrib[where f="update _"] option.case_distrib[where h="update _"] update_f update_update cong: if_cong)
    apply(clarsimp intro!: arg_cong[where f="get"] ext split!: option.split simp add: bind_if2)
    apply(subst f_bind)
    apply(simp add: fun_upd_twist)
    done
qed

end

subsubsection \<open>Probabilistic interpreter\<close>

locale memo_exp_base =
  exp_base return bind fail +
  memoization_base return bind get put
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
begin

definition lookup :: "'v \<Rightarrow> 'm"
where "lookup x = get (\<lambda>s. case s x of None \<Rightarrow> fail | Some y \<Rightarrow> return y)"

lemma lookup_alt_def: "lookup x = get (\<lambda>s. case apply s x of None \<Rightarrow> fail | Some y \<Rightarrow> return y)"
by(simp add: apply_def lookup_def)

end

locale prob_exp_base =
  memo_exp_base return bind fail get put +
  monad_prob_base return bind sample
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and sample :: "(int, 'm) sample"
begin

definition sample_var :: "('v \<Rightarrow> int pmf) \<Rightarrow> 'v \<Rightarrow> 'm"
where "sample_var X x = sample (X x) return"

definition lazy :: "('v \<Rightarrow> int pmf) \<Rightarrow> 'v exp \<Rightarrow> 'm"
where "lazy X \<equiv> eval (memo (sample_var X))"

definition sample_vars :: "('v \<Rightarrow> int pmf) \<Rightarrow> 'v set \<Rightarrow> 'm \<Rightarrow> 'm"
where "sample_vars X A m = Finite_Set.fold (\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m)) m A"

definition eager :: "('v \<Rightarrow> int pmf) \<Rightarrow> 'v exp \<Rightarrow> 'm" where
  "eager p e = sample_vars p (vars e) (eval lookup e)"

end

lemmas [code] =
  prob_exp_base.sample_var_def
  prob_exp_base.lazy_def
  prob_exp_base.eager_def

locale prob_exp = prob_exp_base return bind fail get put sample +
  memoization return bind get put +
  monad_state_prob return bind get put sample +
  monad_fail return bind fail
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and sample :: "(int, 'm) sample"
begin

lemma comp_fun_commute_sample_var: "comp_fun_commute (\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m))"
by unfold_locales(auto intro!: memo_commute simp add: fun_eq_iff sample_var_def bind_sample1 bind_sample2 return_bind sample_get)

interpretation sample_var: comp_fun_commute "\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m)"
  rewrites "\<And>X m A. Finite_Set.fold (\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m)) m A \<equiv> sample_vars X A m"
  for X
by(rule comp_fun_commute_sample_var)(simp add: sample_vars_def)

lemma comp_fun_idem_sample_var: "comp_fun_idem (\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m))"
by unfold_locales(simp add: fun_eq_iff memo_same)

interpretation sample_var: comp_fun_idem "\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m)"
  rewrites "\<And>X m A. Finite_Set.fold (\<lambda>x m. bind (memo (sample_var X) x) (\<lambda>_. m)) m A \<equiv> sample_vars X A m"
  for X
  by(rule comp_fun_idem_sample_var)(simp add: sample_vars_def)

lemma sample_vars_empty [simp]: "sample_vars X {} m = m"
by(simp add: sample_vars_def)

lemma sample_vars_insert:
  "finite A \<Longrightarrow> sample_vars X (insert x A) m = bind (memo (sample_var X) x) (\<lambda>_. sample_vars X A m)"
by(fact sample_var.fold_insert_idem)

lemma sample_vars_insert2:
  "finite A \<Longrightarrow> sample_vars X (insert x A) m = sample_vars X A (bind (memo (sample_var X) x) (\<lambda>_. m))"
by(fact sample_var.fold_insert_idem2)

lemma sample_vars_union:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> sample_vars X (A \<union> B) m = sample_vars X A (sample_vars X B m)"
by(subst Un_commute)(rule sample_var.fold_set_union)

lemma memo_lookup:
  "bind (memo f x) (\<lambda>i. bind (lookup x) (g i)) = bind (memo f x) (\<lambda>i. g i i)"
apply(simp cong del: option.case_cong_weak add: lookup_def memo_def bind_get option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc bind_update return_bind update_get o_def get_const)
apply(subst (3) get_const[symmetric])
apply(subst option.case_distrib[where h=get, symmetric])
apply(simp add: get_get case_option_apply cong: option.case_cong)
done

lemma lazy_eq_eager:
  assumes put_fail: "\<And>s. put s fail = fail"
  shows "lazy X e = eager X e"
proof -
  note option.case_cong [cong]
  have sample_var_get: "bind (sample_var X x) (\<lambda>i. get (f i)) = get (\<lambda>s. bind (sample_var X x) (\<lambda>i. f i s))" for x f
    by(simp add: sample_var_def bind_sample1 return_bind sample_get)
  have update_fail [simp]: "update f fail = fail" for f
    by(simp add: update_def put_fail get_const)
  have sample_vars_fail: "sample_vars X A fail = fail" if "finite A" for A using that
    by induction(simp_all add: memo_def bind_get option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc bind_update return_bind sample_var_def bind_sample1 sample_const case_option_collapse get_const cong del: option.case_cong_weak)
  have sample_var_const: "bind (sample_var X x) (\<lambda>_. m) = m" for x m
    by(simp add: sample_var_def bind_sample1 return_bind sample_const)
  have sample_var_lookup_same: "bind (memo (sample_var X) x) (\<lambda>i. bind (lookup x) (f i)) = bind (memo (sample_var X) x) (\<lambda>i. f i i)" for x f
    by(simp add: lookup_def bind_get memo_def option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc bind_update return_bind update_get sample_var_get option.case_distrib[where h=get, symmetric] get_get case_option_apply)
  have sample_var_lookup_other: "bind (memo (sample_var X) y) (\<lambda>i. bind (lookup x) (f i)) = bind (lookup x) (\<lambda>j. bind (memo (sample_var X) y) (\<lambda>i. f i j))"
    if "x \<noteq> y" for x y f using that
    apply(simp add: lookup_def memo_def bind_get option.case_distrib[where h="\<lambda>x. bind x _"] bind_assoc return_bind bind_update update_get sample_var_get fail_bind option.case_distrib[where h=get, symmetric] get_get case_option_apply)
    apply(subst (13) get_const[symmetric])
    apply(clarsimp simp add: option.case_distrib[where h=get, symmetric] get_get case_option_apply fun_eq_iff sample_var_const intro!: arg_cong[where f=get] split: option.split)
    done
  have sample_vars_lookup: "sample_vars X V (bind (lookup x) f) = bind (lookup x) (\<lambda>i. sample_vars X V (f i))"
    if "finite V" "x \<notin> V" for V x f using that
    by(induction)(auto simp add: sample_var_lookup_other bind_return)

  have lazy_sample_vars: "sample_vars X V (bind (lazy X e) f) = bind (lazy X e) (\<lambda>i. sample_vars X V (f i))"
    if "finite V" for f e V using that unfolding lazy_def
  proof(induction e arbitrary: f)
    case (Var x)
    have "bind (memo (sample_var X) x) (\<lambda>i. sample_vars X V (f i)) = sample_vars X V (bind (memo (sample_var X) x) f)" (is "?lhs V = ?rhs V")
      using Var
    proof(cases "x \<in> V")
      { fix V
        assume False: "x \<notin> V" and fin: "finite V"
        have "?lhs V = bind (memo (sample_var X) x) (\<lambda>_. bind (lookup x) (\<lambda>i. sample_vars X V (f i)))"
          by(simp add: sample_var_lookup_same)
        also have "\<dots> = bind (memo (sample_var X) x) (\<lambda>_. sample_vars X V (bind (lookup x) f))"
          using fin False by(simp add: sample_vars_lookup)
        also have "\<dots> = sample_vars X (insert x V) (bind (lookup x) f)" using fin
          by(simp add: sample_vars_insert)
        also have "\<dots> = sample_vars X V (bind (memo (sample_var X) x) (\<lambda>_. bind (lookup x) f))" using fin
          by(simp only: sample_vars_insert2)
        also have "\<dots> = ?rhs V"
          by(simp add: sample_var_lookup_same)
        finally show "?lhs V = ?rhs V" . }
      note False = this

      case True
      hence V: "V = insert x (V - {x})" by auto
      have "?lhs V = bind (memo (sample_var X) x) (\<lambda>i. bind (memo (sample_var X) x) (\<lambda>_. sample_vars X (V - {x}) (f i)))"
        using Var by(subst V)(simp add: sample_vars_insert del: Diff_insert0 insert_Diff_single)
      also have "\<dots> = bind (memo (sample_var X) x) (\<lambda>_. bind (memo (sample_var X) x) (\<lambda>i. sample_vars X (V - {x}) (f i)))"
        by(simp add: memo_same)
      also have "\<dots> = bind (memo (sample_var X) x) (\<lambda>_. sample_vars X (V - {x}) (bind (memo (sample_var X) x) f))"
        using Var by(subst False)(simp_all)
      also have "\<dots> = ?rhs V" using Var
        by(rewrite in "_ = \<hole>" V)(simp add: sample_vars_insert del: Diff_insert0 insert_Diff_single)
      finally show ?thesis .
    qed
    then show ?case by simp
  next
    case (Const x)
    then show ?case by(simp add: return_bind)
  next
    case (Plus e1 e2)
    then show ?case
      by(simp add: bind_assoc return_bind)
  next
    case (Div e1 e2)
    then show ?case
      apply(simp add: bind_assoc if_distrib[where f="\<lambda>x. bind x _"] fail_bind return_bind cong del: if_weak_cong)
      apply(subst (6) sample_vars_fail[OF \<open>finite V\<close>, symmetric])
      apply(simp add: if_distrib[where f="sample_vars _ _", symmetric])
      done
  qed

  define V where "V \<equiv> vars e"
  then have "vars e \<subseteq> V" "finite V" by simp_all
  then have "sample_vars X V (bind (eval lookup e) f) = sample_vars X V (bind (lazy X e) f)" for f
    unfolding lazy_def
  proof(induction e arbitrary: f)
    case (Var x)
    then have V: "V = insert x (V - {x})" by auto
    show ?case using Var
      apply(subst (1 2) V)
      apply(subst (1 2) sample_vars_insert2)
      apply(simp_all add: memo_same memo_lookup)
      done
  qed(simp_all add: bind_assoc lazy_sample_vars[unfolded lazy_def])
  note this[of return, unfolded V_def]
  also have "sample_vars X (vars e) (bind (lazy X e) f) = bind (lazy X e) f" for f unfolding lazy_def
  proof(induction e arbitrary: f)
    { case Var   show ?case by(simp add: memo_same bind_return) }
    { case Const show ?case by(simp add: bind_return) }
    { case Plus  show ?case
        by(simp add: bind_assoc sample_vars_union lazy_sample_vars[unfolded lazy_def] Plus.IH) }
    { case Div   show ?case
        by(simp add: bind_assoc sample_vars_union lazy_sample_vars[unfolded lazy_def] Div.IH) }
  qed
  finally show ?thesis by(simp add: bind_return V_def eager_def)
qed

end

interpretation F: exp_base
  "return_option return_id"
  "bind_option return_id bind_id"
  "fail_option return_id"
.

value [code] "F.eval (\<lambda>x. return_option return_id 5) (Plus (Var ''a'') (Const 7))"

subsubsection \<open>Moving between monad instances\<close>

global_interpretation SFI: memo_exp_base
  "return_state (return_option (return_id :: ((int \<times> ('b \<rightharpoonup> int)) option, _) return))"
  "bind_state (bind_option return_id bind_id)"
  "fail_state (fail_option return_id)"
  "get_state"
  "put_state"
  defines SFI_lookup = SFI.lookup
.

interpretation SFI: memoization
  "return_state (return_option (return_id :: ((int \<times> ('b \<rightharpoonup> int)) option, _) return))"
  "bind_state (bind_option return_id bind_id)"
  "get_state"
  "put_state"
..

global_interpretation SFP: prob_exp
  "return_state (return_option return_pmf)"
  "bind_state (bind_option return_pmf bind_pmf)"
  "fail_state (fail_option return_pmf)"
  "get_state"
  "put_state"
  "sample_state (sample_option bind_pmf)"
  defines SFP_lookup = SFP.lookup
..

interpretation FSP: prob_exp
  "return_option (return_state (return_pmf :: (int option \<times> ('b \<rightharpoonup> int), _) return))"
  "bind_option (return_state return_pmf) (bind_state bind_pmf)"
  "fail_option (return_state return_pmf)"
  "get_option get_state"
  "put_option put_state"
  "sample_option (sample_state bind_pmf)"
..

locale reader_exp_base = exp_base return bind fail + monad_reader_base return bind ask
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and ask :: "('v \<rightharpoonup> int, 'm) ask"
begin

definition lookup :: "'v \<Rightarrow> 'm" where
  "lookup x = ask (\<lambda>s. case s x of None \<Rightarrow> fail | Some y \<Rightarrow> return y)"

lemma lookup_alt_def:
  "lookup x = ask (\<lambda>s. case apply s x of None \<Rightarrow> fail | Some y \<Rightarrow> return y)"
by(simp add: lookup_def apply_def)

end

locale exp_commute = exp_base return bind fail + monad_commute return bind
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
begin

lemma eval_reverse:
  "eval E (Var x) = E x"
  "eval E (Const i) = return i"
  "eval E (Plus e1 e2) = bind (eval E e2) (\<lambda>j. bind (eval E e1) (\<lambda>i. return (i + j)))"
  "eval E (Div e1 e2) = bind (eval E e2) (\<lambda>j. bind (eval E e1) (\<lambda>i. if j = 0 then fail else return (i div j)))"
by(simp; rule bind_commute)+

end

global_interpretation RFI: reader_exp_base
  "return_env (return_option return_id)"
  "bind_env (bind_option return_id bind_id)"
  "fail_env (fail_option return_id)"
  ask_env
  defines RFI_lookup = RFI.lookup
.

context includes lifting_syntax begin

lemma cr_id_prob_eval:
  notes [transfer_rule] = cr_id_prob_transfer shows
  "rel_stateT (=) (rel_optionT (cr_id_prob (=)))
     (SFI.eval SFI_lookup e)
     (SFP.eval SFP_lookup e)"
unfolding SFP.lookup_def SFI.lookup_def by transfer_prover

lemma cr_envT_stateT_lookup':
  notes [transfer_rule] = cr_envT_stateT_transfer apply_eq_onp shows
  "((=) ===> cr_envT_stateT X (rel_optionT (rel_id (rel_option (cr_prod1 X (=))))))
   RFI_lookup SFI_lookup"
unfolding RFI.lookup_alt_def SFI.lookup_alt_def by transfer_prover

lemma cr_envT_stateT_eval':
  notes [transfer_rule] = cr_envT_stateT_transfer cr_envT_stateT_lookup' shows
  "((=) ===> cr_envT_stateT X (rel_optionT (rel_id (rel_option (cr_prod1 X (=))))))
  (RFI.eval RFI_lookup) (SFI.eval SFI_lookup)"
by transfer_prover

lemma cr_envT_stateT_lookup [cr_envT_stateT_transfer]:
  notes [transfer_rule] = cr_id_prob_transfer cr_envT_stateT_transfer apply_eq_onp shows
  "((=) ===> cr_envT_stateT X (rel_optionT (cr_id_prob (rel_option (cr_prod1 X (=))))))
   RFI_lookup SFP_lookup"
unfolding RFI.lookup_alt_def SFP.lookup_alt_def by transfer_prover

lemma cr_envT_stateT_eval [cr_envT_stateT_transfer]:
  notes [transfer_rule] = cr_id_prob_transfer cr_envT_stateT_transfer shows
  "((=) ===> cr_envT_stateT X (rel_optionT (cr_id_prob (rel_option (cr_prod1 X (=))))))
  (RFI.eval RFI_lookup) (SFP.eval SFP_lookup)"
by transfer_prover

lemma prob_eval_lookup:
  "run_state (SFP.eval SFP_lookup e) E =
   map_optionT (return_pmf \<circ> map_option (\<lambda>b. (b, E)) \<circ> extract) (run_env (RFI.eval RFI_lookup e) E)"
by(rule cr_envT_stateT_eval[of E, THEN rel_funD, OF refl, unfolded eq_alt, unfolded cr_prod1_Grp option.rel_Grp cr_id_prob_Grp rel_optionT_Grp, simplified, THEN cr_envT_stateTD, unfolded BNF_Def.Grp_def, THEN conjunct1])

end

subsection \<open>Non-deterministic interpreter\<close>

locale choose_base = monad_altc_base return bind altc
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and altc :: "(int, 'm) altc"
begin

definition choose_var :: "('v \<Rightarrow> int cset) \<Rightarrow> 'v \<Rightarrow> 'm" where
  "choose_var X x = altc (X x) return"

end

declare choose_base.choose_var_def [code]

locale nondet_exp_base = choose_base return bind altc
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and altc :: "(int, 'm) altc"
begin

sublocale memo_exp_base return bind fail get put .

definition lazy where "lazy X = eval (memo (choose_var X))"

end

locale nondet_exp =
  monad_state_altc return bind get put altc +
  nondet_exp_base return bind get put altc +
  memoization return bind get put
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and altc :: "(int, 'm) altc"
begin

sublocale monad_fail return bind fail by(rule monad_fail)

end

global_interpretation NI: cset_nondetM return_id bind_id merge_id merge_id
  defines NI_return = NI.return_nondet
    and NI_bind = NI.bind_nondet
    and NI_altc = NI.altc_nondet
  ..

global_interpretation SNI: nondet_exp
  "return_state NI_return"
  "bind_state NI_bind"
  "get_state"
  "put_state"
  "altc_state NI_altc"
  defines SNI_lazy = SNI.lazy
  ..

value "run_state (SNI_lazy (\<lambda>x. cinsert 0 (cinsert 1 cempty)) (Div (Const 2) (Var (CHR ''x'')))) Map.empty"

locale nondet_fail_exp_base = choose_base return bind altc
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and altc :: "(int, 'm) altc"
begin

sublocale memo_exp_base return bind fail get put .

definition lazy where "lazy X = eval (memo (choose_var X))"

end

locale nondet_fail_exp =
  monad_state_altc return bind get put altc +
  nondet_fail_exp_base return bind fail get put altc +
  memoization return bind get put +
  fail: monad_fail return bind fail
  for return :: "(int, 'm) return"
  and bind :: "(int, 'm) bind"
  and fail :: "'m fail"
  and get :: "('v \<rightharpoonup> int, 'm) get"
  and put :: "('v \<rightharpoonup> int, 'm) put"
  and altc :: "(int, 'm) altc"

global_interpretation SFNI: nondet_fail_exp
  "return_state (return_option NI_return)"
  "bind_state (bind_option NI_return NI_bind)"
  "fail_state (fail_option NI_return)"
  "get_state"
  "put_state"
  "altc_state (altc_option NI_altc)"
  defines SFNI_lazy = SFNI.lazy
  ..

value "run_state (SFP.lazy (\<lambda>x. pmf_of_set {0, 1}) (Div (Const 2) (Var (CHR ''x'')))) Map.empty"

value "run_state (SFNI_lazy (\<lambda>x. cinsert 0 (cinsert 1 cempty)) (Div (Const 2) (Var (CHR ''x'')))) Map.empty"

end


(*  File:       Maximum_Aggregator.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Maximum Aggregator\<close>

theory Maximum_Aggregator
  imports Aggregator
begin

text
\<open>The max(imum) aggregator takes two partitions of an alternative set A as
input. It returns a partition where every alternative receives the maximum
result of the two input partitions.\<close>

subsection \<open>Definition\<close>

fun max_aggregator :: "'a Aggregator" where
  "max_aggregator A (e1, r1, d1) (e2, r2, d2) =
    (e1 \<union> e2,
     A - (e1 \<union> e2 \<union> d1 \<union> d2),
     (d1 \<union> d2) - (e1 \<union> e2))"

subsection \<open>Auxiliary Lemma\<close>

lemma max_agg_rej_set: "(well_formed A (e1, r1, d1) \<and>
                          well_formed A (e2, r2, d2)) \<longrightarrow>
           reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) = r1 \<inter> r2"
proof -
  have "well_formed A (e1, r1, d1) \<longrightarrow>  A - (e1 \<union> d1) = r1"
    by (simp add: result_imp_rej)
  moreover have
    "well_formed A (e2, r2, d2) \<longrightarrow>  A - (e2 \<union> d2) = r2"
    by (simp add: result_imp_rej)
  ultimately have
    "(well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
        A - (e1 \<union> e2 \<union> d1 \<union> d2) = r1 \<inter> r2"
    by blast
  moreover have
    "{l \<in> A. l \<notin> e1 \<union> e2 \<union> d1 \<union> d2} = A - (e1 \<union> e2 \<union> d1 \<union> d2)"
    by (simp add: set_diff_eq)
  ultimately show ?thesis
    by simp
qed

subsection \<open>Soundness\<close>

theorem max_agg_sound[simp]: "aggregator max_aggregator"
  unfolding aggregator_def
proof (simp, safe)
  fix
    A :: "'a set" and
    e1 :: "'a set" and
    e2 :: "'a set" and
    d1 :: "'a set" and
    d2 :: "'a set" and
    r1 :: "'a set" and
    r2 :: "'a set" and
    x :: "'a"
  assume
    asm1: "e2 \<union> r2 \<union> d2 = e1 \<union> r1 \<union> d1" and
    asm2: "x \<notin> d1" and
    asm3: "x \<notin> r1" and
    asm4: "x \<in> e2"
  show "x \<in> e1"
    using asm1 asm2 asm3 asm4
    by auto
next
  fix
    A :: "'a set" and
    e1 :: "'a set" and
    e2 :: "'a set" and
    d1 :: "'a set" and
    d2 :: "'a set" and
    r1 :: "'a set" and
    r2 :: "'a set" and
    x :: "'a"
  assume
    asm1: "e2 \<union> r2 \<union> d2 = e1 \<union> r1 \<union> d1" and
    asm2: "x \<notin> d1" and
    asm3: "x \<notin> r1" and
    asm4: "x \<in> d2"
  show "x \<in> e1"
    using asm1 asm2 asm3 asm4
    by auto
qed

subsection \<open>Properties\<close>

(*The max-aggregator is conservative.*)
theorem max_agg_consv[simp]: "agg_conservative max_aggregator"
proof -
  have
    "\<forall>A e1 e2 d1 d2 r1 r2.
          (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
      reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) = r1 \<inter> r2"
    using max_agg_rej_set
    by blast
  hence
    "\<forall>A e1 e2 d1 d2 r1 r2.
            (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
        reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> r1 \<inter> r2"
    by blast
  moreover have
    "\<forall>A e1 e2 d1 d2 r1 r2.
        (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
            elect_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (e1 \<union> e2)"
    by (simp add: subset_eq)
  ultimately have
    "\<forall>A e1 e2 d1 d2 r1 r2.
        (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
            (elect_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (e1 \<union> e2) \<and>
             reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (r1 \<union> r2))"
    by blast
  moreover have
    "\<forall>A e1 e2 d1 d2 r1 r2.
        (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
            defer_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (d1 \<union> d2)"
    by auto
  ultimately have
    "\<forall>A e1 e2 d1 d2 r1 r2.
        (well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2)) \<longrightarrow>
            (elect_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (e1 \<union> e2) \<and>
            reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (r1 \<union> r2) \<and>
            defer_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) \<subseteq> (d1 \<union> d2))"
    by blast
  thus ?thesis
    by (simp add: agg_conservative_def)
qed

(*The max-aggregator is commutative.*)
theorem max_agg_comm[simp]: "agg_commutative max_aggregator"
  unfolding agg_commutative_def
proof (safe)
  show "aggregator max_aggregator"
    by simp
next
  fix
    A :: "'a set" and
    e1 :: "'a set" and
    e2 :: "'a set" and
    d1 :: "'a set" and
    d2 :: "'a set" and
    r1 :: "'a set" and
    r2 :: "'a set"
  show
    "max_aggregator A (e1, r1, d1) (e2, r2, d2) =
      max_aggregator A (e2, r2, d2) (e1, r1, d1)"
  by auto
qed

end


theory AOT_Definitions
  imports AOT_semantics
begin

section\<open>Definitions of AOT\<close>

AOT_theorem "conventions:1": \<open>\<phi> & \<psi> \<equiv>\<^sub>d\<^sub>f \<not>(\<phi> \<rightarrow> \<not>\<psi>)\<close>
  using AOT_conj.
AOT_theorem "conventions:2": \<open>\<phi> \<or> \<psi> \<equiv>\<^sub>d\<^sub>f \<not>\<phi> \<rightarrow> \<psi>\<close>
  using AOT_disj.
AOT_theorem "conventions:3": \<open>\<phi> \<equiv> \<psi> \<equiv>\<^sub>d\<^sub>f (\<phi> \<rightarrow> \<psi>) & (\<psi> \<rightarrow> \<phi>)\<close>
  using AOT_equiv.
AOT_theorem "conventions:4": \<open>\<exists>\<alpha> \<phi>{\<alpha>} \<equiv>\<^sub>d\<^sub>f \<not>\<forall>\<alpha> \<not>\<phi>{\<alpha>}\<close>
  using AOT_exists.
AOT_theorem "conventions:5": \<open>\<diamond>\<phi> \<equiv>\<^sub>d\<^sub>f \<not>\<box>\<not>\<phi>\<close>
  using AOT_dia.

declare "conventions:1"[AOT_defs] "conventions:2"[AOT_defs]
        "conventions:3"[AOT_defs] "conventions:4"[AOT_defs]
        "conventions:5"[AOT_defs]

notepad
begin
  fix \<phi> \<psi> \<chi>
  text\<open>\linelabel{precedence}\<close>
  have "conventions3[1]": \<open>\<guillemotleft>\<phi> \<rightarrow> \<psi> \<equiv> \<not>\<psi> \<rightarrow> \<not>\<phi>\<guillemotright> = \<guillemotleft>(\<phi> \<rightarrow> \<psi>) \<equiv> (\<not>\<psi> \<rightarrow> \<not>\<phi>)\<guillemotright>\<close>
    by blast
  have "conventions3[2]": \<open>\<guillemotleft>\<phi> & \<psi> \<rightarrow> \<chi>\<guillemotright> = \<guillemotleft>(\<phi> & \<psi>) \<rightarrow> \<chi>\<guillemotright>\<close>
                   and \<open>\<guillemotleft>\<phi> \<or> \<psi> \<rightarrow> \<chi>\<guillemotright> = \<guillemotleft>(\<phi> \<or> \<psi>) \<rightarrow> \<chi>\<guillemotright>\<close>
    by blast+
  have "conventions3[3]": \<open>\<guillemotleft>\<phi> \<or> \<psi> & \<chi>\<guillemotright> = \<guillemotleft>(\<phi> \<or> \<psi>) & \<chi>\<guillemotright>\<close>
                   and \<open>\<guillemotleft>\<phi> & \<psi> \<or> \<chi>\<guillemotright> = \<guillemotleft>(\<phi> & \<psi>) \<or> \<chi>\<guillemotright>\<close>
     by blast+ \<comment> \<open>Note that PLM instead generally uses parenthesis in these cases.\<close>
end

AOT_theorem "existence:1": \<open>\<kappa>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>F [F]\<kappa>\<close>
  by (simp add: AOT_sem_denotes AOT_sem_exists AOT_model_equiv_def)
     (metis AOT_sem_denotes AOT_sem_exe AOT_sem_lambda_beta AOT_sem_lambda_denotes)
AOT_theorem "existence:2": \<open>\<Pi>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>x\<^sub>1...\<exists>x\<^sub>n x\<^sub>1...x\<^sub>n[\<Pi>]\<close>
  using AOT_sem_denotes AOT_sem_enc_denotes AOT_sem_universal_encoder
  by (simp add: AOT_sem_denotes AOT_sem_exists AOT_model_equiv_def) blast
AOT_theorem "existence:2[1]": \<open>\<Pi>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>x x[\<Pi>]\<close>
  using "existence:2"[of \<Pi>] by simp
AOT_theorem "existence:2[2]": \<open>\<Pi>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>x\<exists>y xy[\<Pi>]\<close>
  using "existence:2"[of \<Pi>]
  by (simp add: AOT_sem_denotes AOT_sem_exists AOT_model_equiv_def
                AOT_model_denotes_prod_def)
AOT_theorem "existence:2[3]": \<open>\<Pi>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>x\<exists>y\<exists>z xyz[\<Pi>]\<close>
  using "existence:2"[of \<Pi>]
  by (simp add: AOT_sem_denotes AOT_sem_exists AOT_model_equiv_def
                AOT_model_denotes_prod_def)
AOT_theorem "existence:2[4]": \<open>\<Pi>\<down> \<equiv>\<^sub>d\<^sub>f \<exists>x\<^sub>1\<exists>x\<^sub>2\<exists>x\<^sub>3\<exists>x\<^sub>4 x\<^sub>1x\<^sub>2x\<^sub>3x\<^sub>4[\<Pi>]\<close>
  using "existence:2"[of \<Pi>]
  by (simp add: AOT_sem_denotes AOT_sem_exists AOT_model_equiv_def
                AOT_model_denotes_prod_def)

AOT_theorem "existence:3": \<open>\<phi>\<down> \<equiv>\<^sub>d\<^sub>f [\<lambda>x \<phi>]\<down>\<close>
  by (simp add: AOT_sem_denotes AOT_model_denotes_\<o>_def AOT_model_equiv_def
                AOT_model_lambda_denotes)

declare "existence:1"[AOT_defs] "existence:2"[AOT_defs] "existence:2[1]"[AOT_defs]
        "existence:2[2]"[AOT_defs] "existence:2[3]"[AOT_defs]
        "existence:2[4]"[AOT_defs] "existence:3"[AOT_defs]

AOT_theorem "oa:1": \<open>O! =\<^sub>d\<^sub>f [\<lambda>x \<diamond>E!x]\<close> using AOT_ordinary .
AOT_theorem "oa:2": \<open>A! =\<^sub>d\<^sub>f [\<lambda>x \<not>\<diamond>E!x]\<close> using AOT_abstract .

declare "oa:1"[AOT_defs] "oa:2"[AOT_defs]

AOT_theorem "identity:1":
  \<open>x = y \<equiv>\<^sub>d\<^sub>f ([O!]x & [O!]y & \<box>\<forall>F ([F]x \<equiv> [F]y)) \<or>
             ([A!]x & [A!]y & \<box>\<forall>F (x[F] \<equiv> y[F]))\<close>
  unfolding AOT_model_equiv_def
  using AOT_sem_ind_eq[of _ x y]
  by (simp add: AOT_sem_ordinary AOT_sem_abstract AOT_sem_conj
                AOT_sem_box AOT_sem_equiv AOT_sem_forall AOT_sem_disj AOT_sem_eq
                AOT_sem_denotes)

AOT_theorem "identity:2":
  \<open>F = G \<equiv>\<^sub>d\<^sub>f F\<down> & G\<down> & \<box>\<forall>x(x[F] \<equiv> x[G])\<close>
  using AOT_sem_enc_eq[of _ F G]
  by (auto simp: AOT_model_equiv_def AOT_sem_imp AOT_sem_denotes AOT_sem_eq
                 AOT_sem_conj AOT_sem_forall AOT_sem_box AOT_sem_equiv)

AOT_theorem "identity:3[2]":
  \<open>F = G \<equiv>\<^sub>d\<^sub>f F\<down> & G\<down> & \<forall>y([\<lambda>z [F]zy] = [\<lambda>z [G]zy] & [\<lambda>z [F]yz] = [\<lambda>z [G]yz])\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_proj_id_prop[of _ F G]
                 AOT_sem_proj_id_prod_def AOT_sem_conj AOT_sem_denotes
                 AOT_sem_forall AOT_sem_unary_proj_id AOT_model_denotes_prod_def)
AOT_theorem "identity:3[3]":
  \<open>F = G \<equiv>\<^sub>d\<^sub>f F\<down> & G\<down> & \<forall>y\<^sub>1\<forall>y\<^sub>2([\<lambda>z [F]zy\<^sub>1y\<^sub>2] = [\<lambda>z [G]zy\<^sub>1y\<^sub>2] &
                              [\<lambda>z [F]y\<^sub>1zy\<^sub>2] = [\<lambda>z [G]y\<^sub>1zy\<^sub>2] &
                              [\<lambda>z [F]y\<^sub>1y\<^sub>2z] = [\<lambda>z [G]y\<^sub>1y\<^sub>2z])\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_proj_id_prop[of _ F G]
                 AOT_sem_proj_id_prod_def AOT_sem_conj AOT_sem_denotes
                 AOT_sem_forall AOT_sem_unary_proj_id AOT_model_denotes_prod_def)
AOT_theorem "identity:3[4]":
  \<open>F = G \<equiv>\<^sub>d\<^sub>f F\<down> & G\<down> & \<forall>y\<^sub>1\<forall>y\<^sub>2\<forall>y\<^sub>3([\<lambda>z [F]zy\<^sub>1y\<^sub>2y\<^sub>3] = [\<lambda>z [G]zy\<^sub>1y\<^sub>2y\<^sub>3] &
                                [\<lambda>z [F]y\<^sub>1zy\<^sub>2y\<^sub>3] = [\<lambda>z [G]y\<^sub>1zy\<^sub>2y\<^sub>3] &
                                [\<lambda>z [F]y\<^sub>1y\<^sub>2zy\<^sub>3] = [\<lambda>z [G]y\<^sub>1y\<^sub>2zy\<^sub>3] &
                                [\<lambda>z [F]y\<^sub>1y\<^sub>2y\<^sub>3z] = [\<lambda>z [G]y\<^sub>1y\<^sub>2y\<^sub>3z])\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_proj_id_prop[of _ F G]
                 AOT_sem_proj_id_prod_def AOT_sem_conj AOT_sem_denotes
                 AOT_sem_forall AOT_sem_unary_proj_id AOT_model_denotes_prod_def)
AOT_theorem "identity:3":
  \<open>F = G \<equiv>\<^sub>d\<^sub>f F\<down> & G\<down> & \<forall>x\<^sub>1...\<forall>x\<^sub>n \<guillemotleft>AOT_sem_proj_id x\<^sub>1x\<^sub>n (\<lambda> \<tau> . AOT_exe F \<tau>)
                                                      (\<lambda> \<tau> . AOT_exe G \<tau>)\<guillemotright>\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_proj_id_prop[of _ F G]
                 AOT_sem_proj_id_prod_def AOT_sem_conj AOT_sem_denotes
                 AOT_sem_forall AOT_sem_unary_proj_id AOT_model_denotes_prod_def)

AOT_theorem "identity:4":
  \<open>p = q \<equiv>\<^sub>d\<^sub>f p\<down> & q\<down> & [\<lambda>x p] = [\<lambda>x q]\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_eq AOT_sem_denotes AOT_sem_conj
                 AOT_model_lambda_denotes AOT_sem_lambda_eq_prop_eq)

declare "identity:1"[AOT_defs] "identity:2"[AOT_defs] "identity:3[2]"[AOT_defs]
        "identity:3[3]"[AOT_defs] "identity:3[4]"[AOT_defs] "identity:3"[AOT_defs]
        "identity:4"[AOT_defs]

AOT_define AOT_nonidentical :: \<open>\<tau> \<Rightarrow> \<tau> \<Rightarrow> \<phi>\<close> (infixl "\<noteq>" 50)
  "=-infix": \<open>\<tau> \<noteq> \<sigma> \<equiv>\<^sub>d\<^sub>f \<not>(\<tau> = \<sigma>)\<close>

context AOT_meta_syntax
begin
notation AOT_nonidentical (infixl "\<^bold>\<noteq>" 50)
end
context AOT_no_meta_syntax
begin
no_notation AOT_nonidentical (infixl "\<^bold>\<noteq>" 50)
end

text\<open>The following are purely technical pseudo-definitions required due to
     our internal implementation of n-ary relations and ellipses using tuples.\<close>
AOT_theorem tuple_denotes: \<open>\<guillemotleft>(\<tau>,\<tau>')\<guillemotright>\<down> \<equiv>\<^sub>d\<^sub>f \<tau>\<down> & \<tau>'\<down>\<close>
  by (simp add: AOT_model_denotes_prod_def AOT_model_equiv_def
                AOT_sem_conj AOT_sem_denotes)
AOT_theorem tuple_identity_1: \<open>\<guillemotleft>(\<tau>,\<tau>')\<guillemotright> = \<guillemotleft>(\<sigma>, \<sigma>')\<guillemotright> \<equiv>\<^sub>d\<^sub>f (\<tau> = \<sigma>) & (\<tau>' = \<sigma>')\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_conj AOT_sem_eq
                 AOT_model_denotes_prod_def AOT_sem_denotes)
AOT_theorem tuple_forall: \<open>\<forall>\<alpha>\<^sub>1...\<forall>\<alpha>\<^sub>n \<phi>{\<alpha>\<^sub>1...\<alpha>\<^sub>n} \<equiv>\<^sub>d\<^sub>f \<forall>\<alpha>\<^sub>1(\<forall>\<alpha>\<^sub>2...\<forall>\<alpha>\<^sub>n \<phi>{\<guillemotleft>(\<alpha>\<^sub>1, \<alpha>\<^sub>2\<alpha>\<^sub>n)\<guillemotright>})\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_forall AOT_sem_denotes
                 AOT_model_denotes_prod_def)
AOT_theorem tuple_exists: \<open>\<exists>\<alpha>\<^sub>1...\<exists>\<alpha>\<^sub>n \<phi>{\<alpha>\<^sub>1...\<alpha>\<^sub>n} \<equiv>\<^sub>d\<^sub>f \<exists>\<alpha>\<^sub>1(\<exists>\<alpha>\<^sub>2...\<exists>\<alpha>\<^sub>n \<phi>{\<guillemotleft>(\<alpha>\<^sub>1, \<alpha>\<^sub>2\<alpha>\<^sub>n)\<guillemotright>})\<close>
  by (auto simp: AOT_model_equiv_def AOT_sem_exists AOT_sem_denotes
                 AOT_model_denotes_prod_def)
declare tuple_denotes[AOT_defs] tuple_identity_1[AOT_defs] tuple_forall[AOT_defs]
        tuple_exists[AOT_defs]

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Big sum and product over function bodies\<close>

theory Groups_Big_Fun
imports
  Main
  "~~/src/Tools/Permanent_Interpretation"
begin

subsection \<open>Abstract product\<close>

no_notation times (infixl "*" 70)
no_notation Groups.one ("1")

locale comm_monoid_fun = comm_monoid
begin

definition G :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a"
where
  expand_set: "G g = comm_monoid_set.F f 1 g {a. g a \<noteq> 1}"

interpretation F!: comm_monoid_set f 1
  ..

lemma expand_superset:
  assumes "finite A" and "{a. g a \<noteq> 1} \<subseteq> A"
  shows "G g = F.F g A"
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply (simp_all add: assms)
  done

lemma conditionalize:
  assumes "finite A"
  shows "F.F g A = G (\<lambda>a. if a \<in> A then g a else 1)"
  using assms
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply auto
  done

lemma neutral [simp]:
  "G (\<lambda>a. 1) = 1"
  by (simp add: expand_set)

lemma update [simp]:
  assumes "finite {a. g a \<noteq> 1}"
  assumes "g a = 1"
  shows "G (g(a := b)) = b * G g"
proof (cases "b = 1")
  case True with `g a = 1` show ?thesis
    by (simp add: expand_set) (rule F.cong, auto)
next
  case False
  moreover have "{a'. a' \<noteq> a \<longrightarrow> g a' \<noteq> 1} = insert a {a. g a \<noteq> 1}"
    by auto
  moreover from `g a = 1` have "a \<notin> {a. g a \<noteq> 1}"
    by simp
  moreover have "F.F (\<lambda>a'. if a' = a then b else g a') {a. g a \<noteq> 1} = F.F g {a. g a \<noteq> 1}"
    by (rule F.cong) (auto simp add: `g a = 1`)
  ultimately show ?thesis using `finite {a. g a \<noteq> 1}` by (simp add: expand_set)
qed

lemma infinite [simp]:
  "\<not> finite {a. g a \<noteq> 1} \<Longrightarrow> G g = 1"
  by (simp add: expand_set)

lemma cong:
  assumes "\<And>a. g a = h a"
  shows "G g = G h"
  using assms by (simp add: expand_set)

lemma strong_cong [cong]:
  assumes "\<And>a. g a = h a"
  shows "G (\<lambda>a. g a) = G (\<lambda>a. h a)"
  using assms by (fact cong)

lemma not_neutral_obtains_not_neutral:
  assumes "G g \<noteq> 1"
  obtains a where "g a \<noteq> 1"
  using assms by (auto elim: F.not_neutral_contains_not_neutral simp add: expand_set)

lemma reindex_cong:
  assumes "bij l"
  assumes "g \<circ> l = h"
  shows "G g = G h"
proof -
  from assms have unfold: "h = g \<circ> l" by simp
  from `bij l` have "inj l" by (rule bij_is_inj)
  then have "inj_on l {a. h a \<noteq> 1}" by (rule subset_inj_on) simp
  moreover from `bij l` have "{a. g a \<noteq> 1} = l ` {a. h a \<noteq> 1}"
    by (auto simp add: image_Collect unfold elim: bij_pointE)
  moreover have "\<And>x. x \<in> {a. h a \<noteq> 1} \<Longrightarrow> g (l x) = h x"
    by (simp add: unfold)
  ultimately have "F.F g {a. g a \<noteq> 1} = F.F h {a. h a \<noteq> 1}"
    by (rule F.reindex_cong)
  then show ?thesis by (simp add: expand_set)
qed

lemma distrib:
  assumes "finite {a. g a \<noteq> 1}" and "finite {a. h a \<noteq> 1}"
  shows "G (\<lambda>a. g a * h a) = G g * G h"
proof -
  from assms have "finite ({a. g a \<noteq> 1} \<union> {a. h a \<noteq> 1})" by simp
  moreover have "{a. g a * h a \<noteq> 1} \<subseteq> {a. g a \<noteq> 1} \<union> {a. h a \<noteq> 1}"
    by auto (drule sym, simp)
  ultimately show ?thesis
    using assms
    by (simp add: expand_superset [of "{a. g a \<noteq> 1} \<union> {a. h a \<noteq> 1}"] F.distrib)
qed

lemma commute:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> 1} \<times> {b. \<exists>a. g a b \<noteq> 1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>b. G (\<lambda>a. g a b))"
proof -
  from `finite C` subset
    have "finite ({a. \<exists>b. g a b \<noteq> 1} \<times> {b. \<exists>a. g a b \<noteq> 1})"
    by (rule rev_finite_subset)
  then have fins:
    "finite {b. \<exists>a. g a b \<noteq> 1}" "finite {a. \<exists>b. g a b \<noteq> 1}"
    by (auto simp add: finite_cartesian_product_iff)
  have subsets: "\<And>a. {b. g a b \<noteq> 1} \<subseteq> {b. \<exists>a. g a b \<noteq> 1}"
    "\<And>b. {a. g a b \<noteq> 1} \<subseteq> {a. \<exists>b. g a b \<noteq> 1}"
    "{a. F.F (g a) {b. \<exists>a. g a b \<noteq> 1} \<noteq> 1} \<subseteq> {a. \<exists>b. g a b \<noteq> 1}"
    "{a. F.F (\<lambda>aa. g aa a) {a. \<exists>b. g a b \<noteq> 1} \<noteq> 1} \<subseteq> {b. \<exists>a. g a b \<noteq> 1}"
    by (auto elim: F.not_neutral_contains_not_neutral)
  from F.commute have
    "F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> 1}) {a. \<exists>b. g a b \<noteq> 1} =
      F.F (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> 1}) {b. \<exists>a. g a b \<noteq> 1}" .
  with subsets fins have "G (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> 1}) =
    G (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> 1})"
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> 1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> 1}"])
  with subsets fins show ?thesis
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> 1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> 1}"])
qed

lemma cartesian_product:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> 1} \<times> {b. \<exists>a. g a b \<noteq> 1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>(a, b). g a b)"
proof -
  from subset `finite C` have fin_prod: "finite (?A \<times> ?B)"
    by (rule finite_subset)
  from fin_prod have "finite ?A" and "finite ?B"
    by (auto simp add: finite_cartesian_product_iff)
  have *: "G (\<lambda>a. G (g a)) =
    (F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> 1}) {a. \<exists>b. g a b \<noteq> 1})"
    apply (subst expand_superset [of "?B"])
    apply (rule `finite ?B`)
    apply auto
    apply (subst expand_superset [of "?A"])
    apply (rule `finite ?A`)
    apply auto
    apply (erule F.not_neutral_contains_not_neutral)
    apply auto
    done
  have "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> 1} \<subseteq> ?A \<times> ?B"
    by auto
  with subset have **: "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> 1} \<subseteq> C"
    by blast
  show ?thesis
    apply (simp add: *)
    apply (simp add: F.cartesian_product)
    apply (subst expand_superset [of C])
    apply (rule `finite C`)
    apply (simp_all add: **)
    apply (rule F.same_carrierI [of C])
    apply (rule `finite C`)
    apply (simp_all add: subset)
    apply auto
    done
qed

lemma cartesian_product2:
  assumes fin: "finite D"
  assumes subset: "{(a, b). \<exists>c. g a b c \<noteq> 1} \<times> {c. \<exists>a b. g a b c \<noteq> 1} \<subseteq> D" (is "?AB \<times> ?C \<subseteq> D")
  shows "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>(a, b, c). g a b c)"
proof -
  have bij: "bij (\<lambda>(a, b, c). ((a, b), c))"
    by (auto intro!: bijI injI simp add: image_def)
  have "{p. \<exists>c. g (fst p) (snd p) c \<noteq> 1} \<times> {c. \<exists>p. g (fst p) (snd p) c \<noteq> 1} \<subseteq> D"
    by auto (insert subset, auto)
  with fin have "G (\<lambda>p. G (g (fst p) (snd p))) = G (\<lambda>(p, c). g (fst p) (snd p) c)"
    by (rule cartesian_product)
  then have "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>((a, b), c). g a b c)"
    by (auto simp add: split_def)
  also have "G (\<lambda>((a, b), c). g a b c) = G (\<lambda>(a, b, c). g a b c)"
    using bij by (rule reindex_cong [of "\<lambda>(a, b, c). ((a, b), c)"]) (simp add: fun_eq_iff)
  finally show ?thesis .
qed

lemma delta [simp]:
  "G (\<lambda>b. if b = a then g b else 1) = g a"
proof -
  have "{b. (if b = a then g b else 1) \<noteq> 1} \<subseteq> {a}" by auto
  then show ?thesis by (simp add: expand_superset [of "{a}"])
qed

lemma delta' [simp]:
  "G (\<lambda>b. if a = b then g b else 1) = g a"
proof -
  have "(\<lambda>b. if a = b then g b else 1) = (\<lambda>b. if b = a then g b else 1)"
    by (simp add: fun_eq_iff)
  then have "G (\<lambda>b. if a = b then g b else 1) = G (\<lambda>b. if b = a then g b else 1)"
    by (simp cong del: strong_cong)
  then show ?thesis by simp
qed

end

notation times (infixl "*" 70)
notation Groups.one ("1")

subsection \<open>Concrete sum\<close>

context comm_monoid_add
begin

definition Sum_any :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a"
where
  "Sum_any = comm_monoid_fun.G plus 0"

permanent_interpretation Sum_any!: comm_monoid_fun plus 0
where
  "comm_monoid_fun.G plus 0 = Sum_any" and
  "comm_monoid_set.F plus 0 = setsum"
proof -
  show "comm_monoid_fun plus 0" ..
  then interpret Sum_any!: comm_monoid_fun plus 0 .
  from Sum_any_def show "comm_monoid_fun.G plus 0 = Sum_any" by rule
  from setsum_def show "comm_monoid_set.F plus 0 = setsum" by rule
qed

end

syntax
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3SUM _. _)" [0, 10] 10)
syntax (xsymbols)
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3\<Sum>_. _)" [0, 10] 10)
syntax (HTML output)
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3\<Sum>_. _)" [0, 10] 10)

translations
  "\<Sum>a. b" == "CONST Sum_any (\<lambda>a. b)"

lemma Sum_any_left_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "Sum_any g * r = (\<Sum>n. g n * r)"
proof -
  note assms
  moreover have "{a. g a * r \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: setsum_left_distrib Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_right_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "r * Sum_any g = (\<Sum>n. r * g n)"
proof -
  note assms
  moreover have "{a. r * g a \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: setsum_right_distrib Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_product:
  fixes f g :: "'b \<Rightarrow> 'a::semiring_0"
  assumes "finite {a. f a \<noteq> 0}" and "finite {b. g b \<noteq> 0}"
  shows "Sum_any f * Sum_any g = (\<Sum>a. \<Sum>b. f a * g b)"
proof -
  have subset_f: "{a. (\<Sum>b. f a * g b) \<noteq> 0} \<subseteq> {a. f a \<noteq> 0}"
    by rule (simp, rule, auto)
  moreover have subset_g: "\<And>a. {b. f a * g b \<noteq> 0} \<subseteq> {b. g b \<noteq> 0}"
    by rule (simp, rule, auto)
  ultimately show ?thesis using assms
    by (auto simp add: Sum_any.expand_set [of f] Sum_any.expand_set [of g]
      Sum_any.expand_superset [of "{a. f a \<noteq> 0}"] Sum_any.expand_superset [of "{b. g b \<noteq> 0}"]
      setsum_product)
qed

lemma Sum_any_eq_zero_iff [simp]:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "finite {a. f a \<noteq> 0}"
  shows "Sum_any f = 0 \<longleftrightarrow> f = (\<lambda>_. 0)"
  using assms by (simp add: Sum_any.expand_set fun_eq_iff)

subsection \<open>Concrete product\<close>

context comm_monoid_mult
begin

definition Prod_any :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a"
where
  "Prod_any = comm_monoid_fun.G times 1"

permanent_interpretation Prod_any!: comm_monoid_fun times 1
where
  "comm_monoid_fun.G times 1 = Prod_any" and
  "comm_monoid_set.F times 1 = setprod"
proof -
  show "comm_monoid_fun times 1" ..
  then interpret Prod_any!: comm_monoid_fun times 1 .
  from Prod_any_def show "comm_monoid_fun.G times 1 = Prod_any" by rule
  from setprod_def show "comm_monoid_set.F times 1 = setprod" by rule
qed

end

syntax
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"    ("(3PROD _. _)" [0, 10] 10)
syntax (xsymbols)
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"    ("(3\<Prod>_. _)" [0, 10] 10)
syntax (HTML output)
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"    ("(3\<Prod>_. _)" [0, 10] 10)

translations
  "\<Prod>a. b" == "CONST Prod_any (\<lambda>a. b)"

lemma Prod_any_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "f a = 0"
  shows "(\<Prod>a. f a) = 0"
proof -
  from `f a = 0` have "f a \<noteq> 1" by simp
  with `f a = 0` have "\<exists>a. f a \<noteq> 1 \<and> f a = 0" by blast
  with `finite {a. f a \<noteq> 1}` show ?thesis
    by (simp add: Prod_any.expand_set setprod_zero)
qed

lemma Prod_any_not_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "(\<Prod>a. f a) \<noteq> 0"
  shows "f a \<noteq> 0"
  using assms Prod_any_zero [of f] by blast

lemma power_Sum_any:
  assumes "finite {a. f a \<noteq> 0}"
  shows "c ^ (\<Sum>a. f a) = (\<Prod>a. c ^ f a)"
proof -
  have "{a. c ^ f a \<noteq> 1} \<subseteq> {a. f a \<noteq> 0}"
    by (auto intro: ccontr)
  with assms show ?thesis
    by (simp add: Sum_any.expand_set Prod_any.expand_superset power_setsum)
qed

end