theory CardArityTransformSafe
imports ArityTransform CardinalityAnalysisSpec AbstractTransform Sestoft SestoftGC ArityEtaExpansionSafe ArityAnalysisStack  ArityConsistent
begin

context CardinalityPrognosisSafe
begin
  sublocale AbstractTransformBoundSubst
    "\<lambda> a . inc\<cdot>a"
    "\<lambda> a . pred\<cdot>a"
    "\<lambda> \<Delta> e a . (a, Aheap \<Delta> e\<cdot>a)"
    "fst"
    "snd"
    "\<lambda> _. 0"
    "Aeta_expand"
    "snd"
  apply standard
  apply (simp add: Aheap_subst)
  apply (rule subst_Aeta_expand)
  done

  abbreviation ccTransform where "ccTransform \<equiv> transform"

  lemma supp_transform: "supp (transform a e) \<subseteq> supp e"
    by (induction rule: transform.induct)
       (auto simp add: exp_assn.supp Let_supp dest!: set_mp[OF supp_map_transform] set_mp[OF supp_map_transform_step] )
  interpretation supp_bounded_transform transform
    by standard (auto simp add: fresh_def supp_transform)

  type_synonym tstate = "(AEnv \<times> (var \<Rightarrow> two) \<times> Arity \<times> Arity list \<times> var list)"

  fun transform_alts :: "Arity list \<Rightarrow> stack \<Rightarrow> stack"
    where
      "transform_alts _ [] = []"
    | "transform_alts (a#as) (Alts e1 e2 # S) = (Alts (ccTransform a e1) (ccTransform a e2)) # transform_alts as S"
    | "transform_alts as (x # S) = x # transform_alts as S"

  lemma transform_alts_Nil[simp]: "transform_alts [] S = S"
    by (induction  S) auto

  lemma Astack_transform_alts[simp]:
    "Astack (transform_alts as S) = Astack S"
   by (induction rule: transform_alts.induct) auto

  lemma fresh_star_transform_alts[intro]: "a \<sharp>* S \<Longrightarrow> a \<sharp>* transform_alts as S"
   by (induction as S  rule: transform_alts.induct) (auto simp add: fresh_star_Cons)

  fun a_transform :: "astate \<Rightarrow> conf \<Rightarrow> conf"
  where "a_transform (ae, a, as) (\<Gamma>, e, S) =
    (map_transform Aeta_expand ae (map_transform ccTransform ae \<Gamma>),
     ccTransform a e,
     transform_alts as  S)"

  fun restr_conf :: "var set \<Rightarrow> conf \<Rightarrow> conf"
    where "restr_conf V (\<Gamma>, e, S) = (restrictA V \<Gamma>, e, restr_stack V S)"

  fun add_dummies_conf :: "var list \<Rightarrow> conf \<Rightarrow> conf"
    where "add_dummies_conf l (\<Gamma>, e, S) = (\<Gamma>, e, S @ map Dummy (rev l))"

  fun conf_transform :: "tstate \<Rightarrow> conf \<Rightarrow> conf"
  where "conf_transform (ae, ce, a, as, r) c = add_dummies_conf r ((a_transform (ae, a, as) (restr_conf (- set r) c)))"

  inductive consistent :: "tstate \<Rightarrow> conf \<Rightarrow> bool" where
    consistentI[intro!]:
    "a_consistent (ae, a, as) (restr_conf (- set r) (\<Gamma>, e, S))
    \<Longrightarrow> edom ae = edom ce
    \<Longrightarrow> prognosis ae as a (\<Gamma>, e, S) \<sqsubseteq> ce
    \<Longrightarrow> (\<And> x. x \<in> thunks \<Gamma> \<Longrightarrow> many \<sqsubseteq> ce x \<Longrightarrow> ae x = up\<cdot>0)
    \<Longrightarrow> set r \<subseteq> (domA \<Gamma> \<union> upds S) - edom ce
    \<Longrightarrow> consistent (ae, ce, a, as, r) (\<Gamma>, e, S)"
  inductive_cases consistentE[elim!]: "consistent (ae, ce, a, as) (\<Gamma>, e, S)"

  lemma closed_consistent:
    assumes "fv e = ({}::var set)"
    shows "consistent (\<bottom>, \<bottom>, 0, [], []) ([], e, [])"
  proof-
    from assms
    have "edom (prognosis \<bottom> [] 0 ([], e, [])) = {}"
     by (auto dest!: set_mp[OF edom_prognosis])
    thus ?thesis
      by (auto simp add: edom_empty_iff_bot closed_a_consistent[OF assms])
  qed

  lemma card_arity_transform_safe:
    fixes c c'
    assumes "c \<Rightarrow>\<^sup>* c'" and "\<not> boring_step c'" and "heap_upds_ok_conf c" and "consistent (ae,ce,a,as,r) c"
    shows "\<exists>ae' ce' a' as' r'. consistent (ae',ce',a',as',r') c' \<and> conf_transform (ae,ce,a,as,r) c \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae',ce',a',as',r') c'"
  using assms(1,2) heap_upds_ok_invariant assms(3-)
  proof(induction c c' arbitrary: ae ce a as r rule:step_invariant_induction)
  case (app\<^sub>1 \<Gamma> e x S)
    have "prognosis ae as (inc\<cdot>a) (\<Gamma>, e, Arg x # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, App e x, S)" by (rule prognosis_App)
    with app\<^sub>1 have "consistent (ae, ce, inc\<cdot>a, as, r) (\<Gamma>, e, Arg x # S)"
      by (auto intro: a_consistent_app\<^sub>1 elim: below_trans)
    moreover
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, App e x, S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, inc\<cdot>a, as, r) (\<Gamma>, e, Arg x # S)"
      by simp rule
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
  case (app\<^sub>2 \<Gamma> y e x S)
    have "prognosis ae as (pred\<cdot>a) (\<Gamma>, e[y::=x], S) \<sqsubseteq> prognosis ae as a (\<Gamma>, (Lam [y]. e), Arg x # S)"
       by (rule prognosis_subst_Lam)
    then
    have "consistent (ae, ce, pred\<cdot>a, as, r) (\<Gamma>, e[y::=x], S)" using app\<^sub>2
      by (auto 4 3 intro: a_consistent_app\<^sub>2 elim: below_trans)
    moreover
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Lam [y]. e, Arg x # S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, pred \<cdot> a, as, r) (\<Gamma>, e[y::=x], S)" by (simp add: subst_transform[symmetric]) rule
    ultimately
    show ?case by (blast  del: consistentI consistentE)
  next
  case (thunk \<Gamma> x e S)
    hence "x \<in> thunks \<Gamma>" by auto
    hence [simp]: "x \<in> domA \<Gamma>" by (rule set_mp[OF thunks_domA])

    from thunk have "prognosis ae as a (\<Gamma>, Var x, S) \<sqsubseteq> ce" by auto
    from below_trans[OF prognosis_called fun_belowD[OF this] ]
    have [simp]: "x \<in> edom ce" by (auto simp add: edom_def)
    hence [simp]: "x \<notin> set r" using thunk by auto

    from `heap_upds_ok_conf (\<Gamma>, Var x, S)`
    have "x \<notin> upds S" by (auto dest!:  heap_upds_okE)

    have "x \<in> edom ae" using thunk by auto
    then obtain u where "ae x = up\<cdot>u" by (cases "ae x") (auto simp add: edom_def)

    show ?case
    proof(cases "ce x" rule:two_cases)
      case none
      with `x \<in> edom ce` have False by (auto simp add: edom_def)
      thus ?thesis..
    next
      case once

      from `prognosis ae as a (\<Gamma>, Var x, S) \<sqsubseteq> ce`
      have "prognosis ae as a (\<Gamma>, Var x, S) x \<sqsubseteq> once"
        using once by (metis (mono_tags) fun_belowD)
      hence "x \<notin> ap S" using prognosis_ap[of ae as a \<Gamma> "(Var x)" S] by auto

      from `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` `\<not> isVal e`
      have *: "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x \<cdot> (prognosis ae as a (\<Gamma>, Var x, S))"
        by (rule prognosis_Var_thunk)

      from `prognosis ae as a (\<Gamma>, Var x, S) x \<sqsubseteq> once`
      have "(record_call x \<cdot> (prognosis ae as a (\<Gamma>, Var x, S))) x = none"
        by (simp add: two_pred_none)
      hence **: "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) x = none" using fun_belowD[OF *, where x = x] by auto

      have eq: "prognosis (env_delete x ae) as u (delete x \<Gamma>, e, Upd x # S) = prognosis ae as u (delete x \<Gamma>, e, Upd x # S)"
        by (rule prognosis_env_cong) simp

      have [simp]: "restr_stack (- set r - {x}) S = restr_stack (- set r) S"
        using `x \<notin> upds S` by (auto intro: restr_stack_cong)

      have "prognosis (env_delete x ae) as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> env_delete x ce"
        unfolding eq
        using ** below_trans[OF below_trans[OF * Cfun.monofun_cfun_arg[OF `prognosis ae as a (\<Gamma>, Var x, S) \<sqsubseteq> ce`]] record_call_below_arg]
        by (rule below_env_deleteI)
      moreover

      have *: "a_consistent (env_delete x ae, u, as) (delete x (restrictA (- set r) \<Gamma>), e, restr_stack (- set r) S)"
        using thunk `ae x = up\<cdot>u`
        by (auto intro!: a_consistent_thunk_once simp del: restr_delete)
      ultimately

      have "consistent (env_delete x ae, env_delete x ce, u, as, x # r) (delete x \<Gamma>, e, Upd x # S)" using thunk
        by (auto simp add: restr_delete_twist Compl_insert elim:below_trans )
      moreover

      from *
      have **: "Astack (transform_alts as (restr_stack (- set r) S) @ map Dummy (rev r) @ [Dummy x]) \<sqsubseteq> u" by (auto elim: a_consistent_stackD)

      {
      from  `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` once
      have "map_of (map_transform Aeta_expand ae (map_transform ccTransform ae (restrictA (- set r) \<Gamma>))) x = Some (Aeta_expand u (transform u e))"
        by (simp add: map_of_map_transform)
      hence "conf_transform (ae, ce, a, as, r) (\<Gamma>, Var x, S) \<Rightarrow>\<^sub>G
             add_dummies_conf r (delete x (map_transform Aeta_expand ae (map_transform ccTransform ae (restrictA (- set r) \<Gamma>))), Aeta_expand u (ccTransform u e), Upd x # transform_alts as (restr_stack (- set r) S))"
          by (auto simp add:  map_transform_delete delete_map_transform_env_delete insert_absorb restr_delete_twist simp del: restr_delete)
      also
      have "\<dots> \<Rightarrow>\<^sub>G\<^sup>* add_dummies_conf (x # r) (delete x (map_transform Aeta_expand ae (map_transform ccTransform ae (restrictA (- set r) \<Gamma>))), Aeta_expand u (ccTransform u e), transform_alts as (restr_stack (- set r) S))"
        apply (rule r_into_rtranclp)
        apply (simp add: append_assoc[symmetric] del: append_assoc)
        apply (rule dropUpd)
        done
      also
      have "\<dots> \<Rightarrow>\<^sub>G\<^sup>* add_dummies_conf (x # r) (delete x (map_transform Aeta_expand ae (map_transform ccTransform ae  (restrictA (- set r) \<Gamma>))), ccTransform u e, transform_alts as (restr_stack (- set r) S))"
        by simp (intro  normal_trans Aeta_expand_safe **)
      also(rtranclp_trans)
      have "\<dots> = conf_transform (env_delete x ae, env_delete x ce, u, as, x # r) (delete x \<Gamma>, e, Upd x # S)"
        by (auto intro!: map_transform_cong simp add:  map_transform_delete[symmetric]  restr_delete_twist Compl_insert)
      finally(back_subst)
      have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Var x, S) \<Rightarrow>\<^sub>G\<^sup>* conf_transform (env_delete x ae, env_delete x ce, u, as, x # r) (delete x \<Gamma>, e, Upd x # S)".
      }
      ultimately
      show ?thesis by (blast del: consistentI consistentE)

    next
      case many

      from `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` `\<not> isVal e`
      have "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x \<cdot> (prognosis ae as a (\<Gamma>, Var x, S))"
        by (rule prognosis_Var_thunk)
      also note record_call_below_arg
      finally
      have *: "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S)" by this simp_all

      have "ae x = up\<cdot>0" using thunk many `x \<in> thunks \<Gamma>` by (auto)
      hence "u = 0" using `ae x = up\<cdot>u` by simp

      have "prognosis ae as 0 (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> ce" using *[unfolded `u=0`] thunk by (auto elim: below_trans)
      moreover
      have "a_consistent (ae, 0, as) (delete x (restrictA (- set r) \<Gamma>), e, Upd x # restr_stack (- set r) S)" using thunk `ae x = up\<cdot>0`
        by (auto intro!: a_consistent_thunk_0 simp del: restr_delete)
      ultimately
      have "consistent (ae, ce, 0, as, r) (delete x \<Gamma>, e, Upd x # S)" using thunk `ae x = up\<cdot>u` `u = 0`
        by (auto simp add:  restr_delete_twist)
      moreover

      from  `map_of \<Gamma> x = Some e` `ae x = up\<cdot>0` many
      have "map_of (map_transform Aeta_expand ae (map_transform ccTransform ae (restrictA (- set r) \<Gamma>))) x = Some (transform 0 e)"
        by (simp add: map_of_map_transform)
      with `\<not> isVal e`
      have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Var x, S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, 0, as, r) (delete x \<Gamma>, e, Upd x # S)"
        by (auto intro: gc_step.intros simp add: map_transform_delete restr_delete_twist intro!: step.intros  simp del: restr_delete)
      ultimately
      show ?thesis by (blast del: consistentI consistentE)
    qed
  next
  case (lamvar \<Gamma> x e S)
    from lamvar(1) have [simp]: "x \<in> domA \<Gamma>" by (metis domI dom_map_of_conv_domA)

    from lamvar have "prognosis ae as a (\<Gamma>, Var x, S) \<sqsubseteq> ce" by auto
    from below_trans[OF prognosis_called fun_belowD[OF this] ]
    have [simp]: "x \<in> edom ce" by (auto simp add: edom_def)
    then obtain c where "ce x = up\<cdot>c" by (cases "ce x") (auto simp add: edom_def)

    from lamvar
    have [simp]: "x \<notin> set r" by auto

    then have "x \<in> edom ae" using lamvar by auto
    then obtain  u where "ae x = up\<cdot>u"  by (cases "ae x") (auto simp add: edom_def)

    have "prognosis ae as u ((x, e) # delete x \<Gamma>, e, S) = prognosis ae as u (\<Gamma>, e, S)"
      using `map_of \<Gamma> x = Some e` by (auto intro!: prognosis_reorder)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot> (prognosis ae as a (\<Gamma>, Var x, S))"
       using `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` `isVal e`  by (rule prognosis_Var_lam)
    also have "\<dots> \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S)" by (rule record_call_below_arg)
    finally have *: "prognosis ae as u ((x, e) # delete x \<Gamma>, e, S) \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S)" by this simp_all
    moreover
    have "a_consistent (ae, u, as) ((x,e) # delete x (restrictA (- set r) \<Gamma>), e, restr_stack (- set r) S)" using lamvar `ae x = up\<cdot>u`
      by (auto intro!: a_consistent_lamvar simp del: restr_delete)
    ultimately
    have "consistent (ae, ce, u, as, r) ((x, e) # delete x \<Gamma>, e, S)"
      using lamvar edom_mono[OF *] by (auto simp add:  thunks_Cons restr_delete_twist elim: below_trans)
    moreover

    from `a_consistent _ _`
    have **: "Astack (transform_alts as (restr_stack (- set r) S) @ map Dummy (rev r)) \<sqsubseteq> u" by (auto elim: a_consistent_stackD)

    {
    from `isVal e`
    have "isVal (transform u e)" by simp
    hence "isVal (Aeta_expand u (transform u e))" by (rule isVal_Aeta_expand)
    moreover
    from  `map_of \<Gamma> x = Some e`  `ae x = up \<cdot> u` `ce x = up\<cdot>c` `isVal (transform u e)`
    have "map_of (map_transform Aeta_expand ae (map_transform transform ae (restrictA (- set r) \<Gamma>))) x = Some (Aeta_expand u (transform u e))"
      by (simp add: map_of_map_transform)
    ultimately
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Var x, S) \<Rightarrow>\<^sub>G\<^sup>*
          add_dummies_conf r ((x, Aeta_expand u (transform u e)) # delete x (map_transform Aeta_expand ae (map_transform transform ae (restrictA (- set r) \<Gamma>))), Aeta_expand u (transform u e), transform_alts as (restr_stack (- set r) S))"
       by (auto intro!: normal_trans[OF lambda_var] simp add: map_transform_delete simp del: restr_delete)
    also have "\<dots> = add_dummies_conf r ((map_transform Aeta_expand ae (map_transform transform ae ((x,e) # delete x (restrictA (- set r) \<Gamma>)))), Aeta_expand u  (transform u e), transform_alts as (restr_stack (- set r) S))"
      using `ae x = up \<cdot> u` `ce x = up\<cdot>c` `isVal (transform u e)`
      by (simp add: map_transform_Cons map_transform_delete restr_delete_twist del: restr_delete)
    also(subst[rotated]) have "\<dots> \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae, ce, u, as, r) ((x, e) # delete x \<Gamma>, e, S)"
      by (simp add: restr_delete_twist) (rule normal_trans[OF Aeta_expand_safe[OF ** ]])
    finally(rtranclp_trans)
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Var x, S) \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae, ce, u, as, r) ((x, e) # delete x \<Gamma>, e, S)".
    }
    ultimately show ?case by (blast del: consistentI consistentE)
  next
  case (var\<^sub>2 \<Gamma> x e S)
    show ?case
    proof(cases "x \<in> set r")
      case [simp]: False

      from var\<^sub>2
      have "a_consistent (ae, a, as) (restrictA (- set r) \<Gamma>, e, Upd x # restr_stack (-set r) S)" by auto
      from a_consistent_UpdD[OF this]
      have "ae x = up\<cdot>0" and "a = 0".

      from `isVal e` `x \<notin> domA \<Gamma>`
      have *: "prognosis ae as 0 ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as 0 (\<Gamma>, e, Upd x # S)" by (rule prognosis_Var2)
      moreover
      have "a_consistent (ae, a, as) ((x, e) # restrictA (- set r) \<Gamma>, e, restr_stack (- set r) S)"
        using var\<^sub>2 by (auto intro!: a_consistent_var\<^sub>2)
      ultimately
      have "consistent (ae, ce, 0, as, r) ((x, e) # \<Gamma>, e, S)"
        using var\<^sub>2 `a = 0`
        by (auto simp add: thunks_Cons elim: below_trans)
      moreover
      have "conf_transform (ae, ce, a, as, r) (\<Gamma>, e, Upd x # S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, 0, as, r) ((x, e) # \<Gamma>, e, S)"
        using `ae x = up\<cdot>0` `a = 0` var\<^sub>2
        by (auto intro: gc_step.intros simp add: map_transform_Cons)
      ultimately show ?thesis by (blast del: consistentI consistentE)
    next
      case True
      hence "ce x = \<bottom>" using var\<^sub>2 by (auto simp add: edom_def)
      hence "x \<notin> edom ce" by (simp add: edomIff)
      hence "x \<notin> edom ae" using var\<^sub>2 by auto
      hence [simp]: "ae x = \<bottom>" by (auto simp add: edom_def)

      note  `x \<in> set r`[simp]

      have "prognosis ae as a ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as a ((x, e) # \<Gamma>, e, Upd x # S)" by (rule prognosis_upd)
      also have "\<dots> \<sqsubseteq> prognosis ae as a (delete x ((x,e) # \<Gamma>), e, Upd x # S)"
        using `ae x = \<bottom>` by (rule prognosis_not_called)
      also have "delete x ((x,e)#\<Gamma>) = \<Gamma>" using `x \<notin> domA \<Gamma>` by simp
      finally
      have *: "prognosis ae as a ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as a (\<Gamma>, e, Upd x # S)" by this simp
      then
      have "consistent (ae, ce, a, as, r) ((x, e) # \<Gamma>, e, S)" using var\<^sub>2
        by (auto simp add: thunks_Cons  elim:below_trans a_consistent_var\<^sub>2)
      moreover
      have "conf_transform (ae, ce, a, as, r) (\<Gamma>, e, Upd x # S) = conf_transform (ae, ce, a, as, r) ((x, e) # \<Gamma>, e, S)"
        by (auto simp add: map_transform_restrA[symmetric])
      ultimately show ?thesis
        by (fastforce del: consistentI consistentE simp del:conf_transform.simps)
    qed
  next
    case (let\<^sub>1 \<Delta> \<Gamma> e S)
    let ?ae = "Aheap \<Delta> e\<cdot>a"
    let ?ce = "cHeap \<Delta> e\<cdot>a"

    have "domA \<Delta> \<inter> upds S = {}" using fresh_distinct_fv[OF let\<^sub>1(2)] by (auto dest: set_mp[OF ups_fv_subset])
    hence *: "\<And> x. x \<in> upds S \<Longrightarrow> x \<notin> edom ?ae" by (auto simp add: edom_cHeap dest!: set_mp[OF edom_Aheap])
    have restr_stack_simp2: "restr_stack (edom (?ae \<squnion> ae)) S = restr_stack (edom ae) S"
      by (auto intro: restr_stack_cong dest!: *)

    have "edom ce = edom ae" using let\<^sub>1 by auto

    have "edom ae \<subseteq> domA \<Gamma> \<union> upds S" using let\<^sub>1 by (auto dest!: a_consistent_edom_subsetD)
    from set_mp[OF this] fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
    have "edom ae \<inter> domA \<Delta> = {}" by (auto dest: set_mp[OF ups_fv_subset])

    from `edom ae \<inter> domA \<Delta> = {}`
    have [simp]: "edom (Aheap \<Delta> e\<cdot>a) \<inter> edom ae = {}" by (auto dest!: set_mp[OF edom_Aheap])

    from fresh_distinct[OF let\<^sub>1(1)]
    have [simp]: "restrictA (edom ae \<union> edom (Aheap \<Delta> e\<cdot>a)) \<Gamma> = restrictA (edom ae) \<Gamma>"
      by (auto intro: restrictA_cong dest!: set_mp[OF edom_Aheap])

    have "set r \<subseteq> domA \<Gamma> \<union> upds S" using let\<^sub>1 by auto
    have [simp]: "restrictA (- set r) \<Delta> = \<Delta>"
      apply (rule restrictA_noop)
      apply auto
      by (metis IntI UnE `set r \<subseteq> domA \<Gamma> \<union> upds S` `domA \<Delta> \<inter> domA \<Gamma> = {}` `domA \<Delta> \<inter> upds S = {}` contra_subsetD empty_iff)

    {
    have "edom (?ae \<squnion> ae) = edom (?ce \<squnion> ce)"
      using let\<^sub>1(4) by (auto simp add: edom_cHeap)
    moreover
    { fix x e'
      assume "x \<in> thunks \<Gamma>"
      hence "x \<notin> edom ?ce" using fresh_distinct[OF let\<^sub>1(1)]
        by (auto simp add: edom_cHeap dest: set_mp[OF edom_Aheap]  set_mp[OF thunks_domA])
      hence [simp]: "?ce x = \<bottom>" unfolding edomIff by auto

      assume "many \<sqsubseteq> (?ce \<squnion> ce) x"
      with let\<^sub>1 `x \<in> thunks \<Gamma>`
      have "(?ae \<squnion> ae) x = up \<cdot>0" by auto
    }
    moreover
    { fix x e'
      assume "x \<in> thunks \<Delta>"
      hence "x \<notin> domA \<Gamma>" and "x \<notin> upds S"
        using fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
        by (auto dest!: set_mp[OF thunks_domA] set_mp[OF ups_fv_subset])
      hence "x \<notin> edom ce" using `edom ae \<subseteq> domA \<Gamma> \<union> upds S` `edom ce = edom ae` by auto
      hence [simp]: "ce x = \<bottom>"  by (auto simp add: edomIff)

      assume "many \<sqsubseteq> (?ce \<squnion> ce) x" with `x \<in> thunks \<Delta>`
      have "(?ae \<squnion> ae) x = up\<cdot>0" by (auto simp add: Aheap_heap3)
    }
    moreover
    {
    from let\<^sub>1(1,2) `edom ae \<subseteq> domA \<Gamma> \<union> upds S`
    have "prognosis (?ae \<squnion> ae) as a (\<Delta> @ \<Gamma>, e, S) \<sqsubseteq> ?ce \<squnion> prognosis ae as a (\<Gamma>, Let \<Delta> e, S)" by (rule prognosis_Let)
    also have "prognosis ae as a (\<Gamma>, Let \<Delta> e, S) \<sqsubseteq> ce" using let\<^sub>1 by auto
    finally have "prognosis (?ae \<squnion> ae) as a (\<Delta> @ \<Gamma>, e, S) \<sqsubseteq> ?ce \<squnion> ce" by this simp
    }
    moreover

    have "a_consistent (ae, a, as) (restrictA (- set r) \<Gamma>, Let \<Delta> e, restr_stack (- set r) S)"
      using let\<^sub>1 by auto
    hence "a_consistent (?ae \<squnion> ae, a, as) (\<Delta> @ restrictA (- set r) \<Gamma>, e, restr_stack (- set r) S)"
      using let\<^sub>1(1,2) `edom ae \<inter> domA \<Delta> = {}`
      by (auto intro!:  a_consistent_let simp del: join_comm)
    hence "a_consistent (?ae \<squnion> ae, a, as) (restrictA (- set r) (\<Delta> @ \<Gamma>), e, restr_stack (- set r) S)"
      by (simp add: restrictA_append)
    moreover
    have  "set r \<subseteq> (domA \<Gamma> \<union> upds S) - edom ce" using let\<^sub>1 by auto
    hence  "set r \<subseteq> (domA \<Gamma> \<union> upds S) - edom (?ce \<squnion> ce)"
      apply (rule order_trans)
      using `domA \<Delta> \<inter> domA \<Gamma> = {}` `domA \<Delta> \<inter> upds S = {}`
      apply (auto simp add: edom_cHeap dest!: set_mp[OF edom_Aheap])
      done
    ultimately
    have "consistent (?ae \<squnion> ae, ?ce \<squnion> ce, a, as, r) (\<Delta> @ \<Gamma>, e, S)" by auto
    }
    moreover
    {
      have "\<And> x. x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> edom ?ae" "\<And> x. x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> edom ?ce"
        using fresh_distinct[OF let\<^sub>1(1)]
        by (auto simp add: edom_cHeap dest!: set_mp[OF edom_Aheap])
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) (restrictA (-set r) \<Gamma>))
         = map_transform Aeta_expand ae (map_transform transform ae (restrictA (-set r) \<Gamma>))"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      moreover

      from `edom ae \<subseteq> domA \<Gamma> \<union> upds S` `edom ce = edom ae`
      have "\<And> x. x \<in> domA \<Delta> \<Longrightarrow> x \<notin> edom ce" and  "\<And> x. x \<in> domA \<Delta> \<Longrightarrow> x \<notin> edom ae"
         using fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_ups[OF let\<^sub>1(2)]  by auto
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) (restrictA (- set r) \<Delta>))
         = map_transform Aeta_expand ?ae (map_transform transform ?ae (restrictA (- set r) \<Delta>))"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      moreover

      from  `domA \<Delta> \<inter> domA \<Gamma> = {}`   `domA \<Delta> \<inter> upds S = {}`
      have "atom ` domA \<Delta> \<sharp>* set r"
        by (auto simp add: fresh_star_def fresh_at_base fresh_finite_set_at_base dest!: set_mp[OF `set r \<subseteq> domA \<Gamma> \<union> upds S`])
      hence "atom ` domA \<Delta> \<sharp>* map Dummy (rev r)"
        apply -
        apply (rule eqvt_fresh_star_cong1[where f = "map Dummy"], perm_simp, rule)
        apply (rule eqvt_fresh_star_cong1[where f = "rev"], perm_simp, rule)
        apply (auto simp add: fresh_star_def fresh_set)
        done
      ultimately

      have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Let \<Delta> e, S) \<Rightarrow>\<^sub>G conf_transform (?ae \<squnion> ae, ?ce \<squnion> ce, a, as, r) (\<Delta> @ \<Gamma>, e, S)"
        using restr_stack_simp2 let\<^sub>1(1,2)  `edom ce = edom ae`
        apply (auto simp add: map_transform_append restrictA_append edom_cHeap restr_stack_simp2[simplified] )
        apply (rule normal)
        apply (rule step.let\<^sub>1)
        apply (auto intro: normal step.let\<^sub>1 dest: set_mp[OF edom_Aheap] simp add: fresh_star_list)
        done
    }
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>1 \<Gamma> scrut e1 e2 S)
    have "prognosis ae as a (\<Gamma>, scrut ? e1 : e2, S) \<sqsubseteq> ce" using if\<^sub>1 by auto
    hence "prognosis ae (a#as) 0 (\<Gamma>, scrut, Alts e1 e2 # S) \<sqsubseteq> ce"
      by (rule below_trans[OF prognosis_IfThenElse])
    hence "consistent (ae, ce, 0, a#as, r) (\<Gamma>, scrut, Alts e1 e2 # S)"
      using if\<^sub>1  by (auto dest: a_consistent_if\<^sub>1)
    moreover
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, scrut ? e1 : e2, S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, 0, a#as, r) (\<Gamma>, scrut, Alts e1 e2 # S)"
      by (auto intro: normal step.intros)
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>2 \<Gamma> b e1 e2 S)
    hence "a_consistent (ae, a, as) (restrictA (- set r) \<Gamma>, Bool b, Alts e1 e2 # restr_stack (-set r) S)" by auto
    then  obtain a' as' where [simp]: "as = a' # as'" "a = 0"
      by (rule a_consistent_alts_on_stack)

    {
    have "prognosis ae (a'#as') 0 (\<Gamma>, Bool b, Alts e1 e2 # S) \<sqsubseteq> ce" using if\<^sub>2 by auto
    hence "prognosis ae as' a' (\<Gamma>, if b then e1 else e2, S) \<sqsubseteq> ce" by (rule below_trans[OF prognosis_Alts])
    then
    have "consistent (ae, ce, a', as', r) (\<Gamma>, if b then e1 else e2, S)"
      using if\<^sub>2 by (auto dest!: a_consistent_if\<^sub>2)
    }
    moreover
    have "conf_transform (ae, ce, a, as, r) (\<Gamma>, Bool b, Alts e1 e2 # S) \<Rightarrow>\<^sub>G conf_transform (ae, ce, a', as', r) (\<Gamma>, if b then e1 else e2, S)"
      by (auto intro: normal step.if\<^sub>2[where b = True, simplified] step.if\<^sub>2[where b = False, simplified])
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case refl thus ?case by force
  next
    case (trans c c' c'')
      from trans(3)[OF trans(5)]
      obtain ae' ce' a' as' r'
      where "consistent (ae', ce', a', as', r') c'" and *: "conf_transform (ae, ce, a, as, r) c \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae', ce', a', as', r') c'" by blast
      from trans(4)[OF this(1)]
      obtain ae'' ce'' a'' as'' r''
      where "consistent (ae'', ce'', a'', as'', r'') c''" and **: "conf_transform (ae', ce', a', as', r') c' \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae'', ce'', a'', as'', r'') c''" by blast
      from this(1) rtranclp_trans[OF * **]
      show ?case by blast
  qed
end

end


(*<*)
theory TAO_1_Embedding
imports Main
begin
(*>*)

section\<open>Representation Layer\<close>
text\<open>\label{TAO_Embedding}\<close>

subsection\<open>Primitives\<close>
text\<open>\label{TAO_Embedding_Primitives}\<close>

typedecl i \<comment> \<open>possible worlds\<close>
typedecl j \<comment> \<open>states\<close>

consts dw :: i \<comment> \<open>actual world\<close>
consts dj :: j \<comment> \<open>actual state\<close>

typedecl \<omega> \<comment> \<open>ordinary objects\<close>
typedecl \<sigma> \<comment> \<open>special urelements\<close>
datatype \<upsilon> = \<omega>\<upsilon> \<omega> | \<sigma>\<upsilon> \<sigma> \<comment> \<open>urelements\<close>

subsection\<open>Derived Types\<close>
text\<open>\label{TAO_Embedding_Derived_Types}\<close>

typedef \<o> = "UNIV::(j\<Rightarrow>i\<Rightarrow>bool) set"
  morphisms eval\<o> make\<o> .. \<comment> \<open>truth values\<close>

type_synonym \<Pi>\<^sub>0 = \<o> \<comment> \<open>zero place relations\<close>
typedef \<Pi>\<^sub>1 = "UNIV::(\<upsilon>\<Rightarrow>j\<Rightarrow>i\<Rightarrow>bool) set"
  morphisms eval\<Pi>\<^sub>1 make\<Pi>\<^sub>1 .. \<comment> \<open>one place relations\<close>
typedef \<Pi>\<^sub>2 = "UNIV::(\<upsilon>\<Rightarrow>\<upsilon>\<Rightarrow>j\<Rightarrow>i\<Rightarrow>bool) set"
  morphisms eval\<Pi>\<^sub>2 make\<Pi>\<^sub>2 .. \<comment> \<open>two place relations\<close>
typedef \<Pi>\<^sub>3 = "UNIV::(\<upsilon>\<Rightarrow>\<upsilon>\<Rightarrow>\<upsilon>\<Rightarrow>j\<Rightarrow>i\<Rightarrow>bool) set"
  morphisms eval\<Pi>\<^sub>3 make\<Pi>\<^sub>3 .. \<comment> \<open>three place relations\<close>

type_synonym \<alpha> = "\<Pi>\<^sub>1 set" \<comment> \<open>abstract objects\<close>

datatype \<nu> = \<omega>\<nu> \<omega> | \<alpha>\<nu> \<alpha> \<comment> \<open>individuals\<close>

typedef \<kappa> = "UNIV::(\<nu> option) set"
  morphisms eval\<kappa> make\<kappa> .. \<comment> \<open>individual terms\<close>

setup_lifting type_definition_\<o>
setup_lifting type_definition_\<kappa>
setup_lifting type_definition_\<Pi>\<^sub>1
setup_lifting type_definition_\<Pi>\<^sub>2
setup_lifting type_definition_\<Pi>\<^sub>3

subsection\<open>Individual Terms and Definite Descriptions\<close>
text\<open>\label{TAO_Embedding_IndividualTerms}\<close>

lift_definition \<nu>\<kappa> :: "\<nu>\<Rightarrow>\<kappa>" ("_\<^sup>P" [90] 90) is Some .
lift_definition proper :: "\<kappa>\<Rightarrow>bool" is "(\<noteq>) None" .
lift_definition rep :: "\<kappa>\<Rightarrow>\<nu>" is the .

lift_definition that::"(\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<kappa>" (binder "\<^bold>\<iota>" [8] 9) is
  "\<lambda> \<phi> . if (\<exists>! x . (\<phi> x) dj dw)
         then Some (THE x . (\<phi> x) dj dw)
         else None" .

subsection\<open>Mapping from Individuals to Urelements\<close>
text\<open>\label{TAO_Embedding_AbstractObjectsToSpecialUrelements}\<close>

consts \<alpha>\<sigma> :: "\<alpha>\<Rightarrow>\<sigma>"
axiomatization where \<alpha>\<sigma>_surj: "surj \<alpha>\<sigma>"
definition \<nu>\<upsilon> :: "\<nu>\<Rightarrow>\<upsilon>" where "\<nu>\<upsilon> \<equiv> case_\<nu> \<omega>\<upsilon> (\<sigma>\<upsilon> \<circ> \<alpha>\<sigma>)"

subsection\<open>Exemplification of n-place-Relations.\<close>
text\<open>\label{TAO_Embedding_Exemplification}\<close>

lift_definition exe0::"\<Pi>\<^sub>0\<Rightarrow>\<o>" ("\<lparr>_\<rparr>") is id .
lift_definition exe1::"\<Pi>\<^sub>1\<Rightarrow>\<kappa>\<Rightarrow>\<o>" ("\<lparr>_,_\<rparr>") is
  "\<lambda> F x s w . (proper x) \<and> F (\<nu>\<upsilon> (rep x)) s w" .
lift_definition exe2::"\<Pi>\<^sub>2\<Rightarrow>\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<o>" ("\<lparr>_,_,_\<rparr>") is
  "\<lambda> F x y s w . (proper x) \<and> (proper y) \<and>
     F (\<nu>\<upsilon> (rep x)) (\<nu>\<upsilon> (rep y)) s w" .
lift_definition exe3::"\<Pi>\<^sub>3\<Rightarrow>\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<o>" ("\<lparr>_,_,_,_\<rparr>") is
"\<lambda> F x y z s w . (proper x) \<and> (proper y) \<and> (proper z) \<and>
   F (\<nu>\<upsilon> (rep x)) (\<nu>\<upsilon> (rep y)) (\<nu>\<upsilon> (rep z)) s w" .

subsection\<open>Encoding\<close>
text\<open>\label{TAO_Embedding_Encoding}\<close>

lift_definition enc :: "\<kappa>\<Rightarrow>\<Pi>\<^sub>1\<Rightarrow>\<o>" ("\<lbrace>_,_\<rbrace>") is
  "\<lambda> x F s w . (proper x) \<and> case_\<nu> (\<lambda> \<omega> . False) (\<lambda> \<alpha> . F \<in> \<alpha>) (rep x)" .

subsection\<open>Connectives and Quantifiers\<close>
text\<open>\label{TAO_Embedding_Connectives}\<close>

consts I_NOT :: "j\<Rightarrow>(i\<Rightarrow>bool)\<Rightarrow>i\<Rightarrow>bool"
consts I_IMPL :: "j\<Rightarrow>(i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>bool)"

lift_definition not :: "\<o>\<Rightarrow>\<o>" ("\<^bold>\<not>_" [54] 70) is
  "\<lambda> p s w . s = dj \<and> \<not>p dj w \<or> s \<noteq> dj \<and> (I_NOT s (p s) w)" .
lift_definition impl :: "\<o>\<Rightarrow>\<o>\<Rightarrow>\<o>" (infixl "\<^bold>\<rightarrow>" 51) is
  "\<lambda> p q s w . s = dj \<and> (p dj w \<longrightarrow> q dj w) \<or> s \<noteq> dj \<and> (I_IMPL s (p s) (q s) w)" .
lift_definition forall\<^sub>\<nu> :: "(\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>\<nu>" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<nu> . (\<phi> x) s w" .
lift_definition forall\<^sub>0 :: "(\<Pi>\<^sub>0\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>0" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<Pi>\<^sub>0 . (\<phi> x) s w" .
lift_definition forall\<^sub>1 :: "(\<Pi>\<^sub>1\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>1" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<Pi>\<^sub>1  . (\<phi> x) s w" .
lift_definition forall\<^sub>2 :: "(\<Pi>\<^sub>2\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>2" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<Pi>\<^sub>2  . (\<phi> x) s w" .
lift_definition forall\<^sub>3 :: "(\<Pi>\<^sub>3\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>3" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<Pi>\<^sub>3  . (\<phi> x) s w" .
lift_definition forall\<^sub>\<o> :: "(\<o>\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>\<^sub>\<o>" [8] 9) is
  "\<lambda> \<phi> s w . \<forall> x :: \<o>  . (\<phi> x) s w" .
lift_definition box :: "\<o>\<Rightarrow>\<o>" ("\<^bold>\<box>_" [62] 63) is
  "\<lambda> p s w . \<forall> v . p s v" .
lift_definition actual :: "\<o>\<Rightarrow>\<o>" ("\<^bold>\<A>_" [64] 65) is
  "\<lambda> p s w . p s dw" .

text\<open>
\begin{remark}
  The connectives behave classically if evaluated for the actual state @{term "dj"},
  whereas their behavior is governed by uninterpreted constants for any
  other state.
\end{remark}
\<close>

subsection\<open>Lambda Expressions\<close>
text\<open>\label{TAO_Embedding_Lambda}\<close>

text\<open>
\begin{remark}
  Lambda expressions have to convert maps from individuals to propositions to
  relations that are represented by maps from urelements to truth values.
\end{remark}
\<close>

lift_definition lambdabinder0 :: "\<o>\<Rightarrow>\<Pi>\<^sub>0" ("\<^bold>\<lambda>\<^sup>0") is id .
lift_definition lambdabinder1 :: "(\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<Pi>\<^sub>1" (binder "\<^bold>\<lambda>" [8] 9) is
  "\<lambda> \<phi> u s w . \<exists> x . \<nu>\<upsilon> x = u \<and> \<phi> x s w" .
lift_definition lambdabinder2 :: "(\<nu>\<Rightarrow>\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<Pi>\<^sub>2" ("\<^bold>\<lambda>\<^sup>2") is
  "\<lambda> \<phi> u v s w . \<exists> x y . \<nu>\<upsilon> x = u \<and> \<nu>\<upsilon> y = v \<and> \<phi> x y s w" .
lift_definition lambdabinder3 :: "(\<nu>\<Rightarrow>\<nu>\<Rightarrow>\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<Pi>\<^sub>3" ("\<^bold>\<lambda>\<^sup>3") is
  "\<lambda> \<phi> u v r s w . \<exists> x y z . \<nu>\<upsilon> x = u \<and> \<nu>\<upsilon> y = v \<and> \<nu>\<upsilon> z = r \<and> \<phi> x y z s w" .

subsection\<open>Proper Maps\<close>
text\<open>\label{TAO_Embedding_Proper}\<close>

text\<open>
\begin{remark}
  The embedding introduces the notion of \emph{proper} maps from
  individual terms to propositions.

  Such a map is proper if and only if for all proper individual terms its truth evaluation in the
  actual state only depends on the urelements corresponding to the individuals the terms denote.

  Proper maps are exactly those maps that - when used as matrix of a lambda-expression - unconditionally
  allow beta-reduction.
\end{remark}
\<close>

lift_definition IsProperInX :: "(\<kappa>\<Rightarrow>\<o>)\<Rightarrow>bool" is
  "\<lambda> \<phi> . \<forall> x v . (\<exists> a . \<nu>\<upsilon> a = \<nu>\<upsilon> x \<and> (\<phi> (a\<^sup>P) dj v)) = (\<phi> (x\<^sup>P) dj v)" .
lift_definition IsProperInXY :: "(\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<o>)\<Rightarrow>bool" is
  "\<lambda> \<phi> . \<forall> x y v . (\<exists> a b . \<nu>\<upsilon> a = \<nu>\<upsilon> x \<and> \<nu>\<upsilon> b = \<nu>\<upsilon> y
                    \<and> (\<phi> (a\<^sup>P) (b\<^sup>P) dj v)) = (\<phi> (x\<^sup>P) (y\<^sup>P) dj v)" .
lift_definition IsProperInXYZ :: "(\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<kappa>\<Rightarrow>\<o>)\<Rightarrow>bool" is
  "\<lambda> \<phi> . \<forall> x y z v . (\<exists> a b c . \<nu>\<upsilon> a = \<nu>\<upsilon> x \<and> \<nu>\<upsilon> b = \<nu>\<upsilon> y \<and> \<nu>\<upsilon> c = \<nu>\<upsilon> z
                      \<and> (\<phi> (a\<^sup>P) (b\<^sup>P) (c\<^sup>P) dj v)) = (\<phi> (x\<^sup>P) (y\<^sup>P) (z\<^sup>P) dj v)" .

subsection\<open>Validity\<close>
text\<open>\label{TAO_Embedding_Validity}\<close>

lift_definition valid_in :: "i\<Rightarrow>\<o>\<Rightarrow>bool" (infixl "\<Turnstile>" 5) is
  "\<lambda> v \<phi> . \<phi> dj v" .

text\<open>
\begin{remark}
  A formula is considered semantically valid for a possible world,
  if it evaluates to @{term "True"} for the actual state @{term "dj"}
  and the given possible world.
\end{remark}
\<close>

subsection\<open>Concreteness\<close>
text\<open>\label{TAO_Embedding_Concreteness}\<close>

consts ConcreteInWorld :: "\<omega>\<Rightarrow>i\<Rightarrow>bool"

abbreviation (input) OrdinaryObjectsPossiblyConcrete where
  "OrdinaryObjectsPossiblyConcrete \<equiv> \<forall> x . \<exists> v . ConcreteInWorld x v"
abbreviation (input) PossiblyContingentObjectExists where
  "PossiblyContingentObjectExists \<equiv> \<exists> x v . ConcreteInWorld x v
                                        \<and> (\<exists> w . \<not> ConcreteInWorld x w)"
abbreviation (input) PossiblyNoContingentObjectExists where
  "PossiblyNoContingentObjectExists \<equiv> \<exists> w . \<forall> x . ConcreteInWorld x w
                                        \<longrightarrow> (\<forall> v . ConcreteInWorld x v)"
axiomatization where
  OrdinaryObjectsPossiblyConcreteAxiom:
    "OrdinaryObjectsPossiblyConcrete"
  and PossiblyContingentObjectExistsAxiom:
    "PossiblyContingentObjectExists"
  and PossiblyNoContingentObjectExistsAxiom:
    "PossiblyNoContingentObjectExists"

text\<open>
\begin{remark}
  Care has to be taken that the defined notion of concreteness
  coincides with the meta-logical distinction between
  abstract objects and ordinary objects. Furthermore the axioms about
  concreteness have to be satisfied. This is achieved by introducing an
  uninterpreted constant @{term "ConcreteInWorld"} that determines whether
  an ordinary object is concrete in a given possible world. This constant is
  axiomatized, such that all ordinary objects are possibly concrete, contingent
  objects possibly exist and possibly no contingent objects exist.
\end{remark}
\<close>

lift_definition Concrete::"\<Pi>\<^sub>1" ("E!") is
  "\<lambda> u s w . case u of \<omega>\<upsilon> x \<Rightarrow> ConcreteInWorld x w | _ \<Rightarrow> False" .

text\<open>
\begin{remark}
  Concreteness of ordinary objects is now defined using this
  axiomatized uninterpreted constant. Abstract objects on the other
  hand are never concrete.
\end{remark}
\<close>

subsection\<open>Collection of Meta-Definitions\<close>
text\<open>\label{TAO_Embedding_meta_defs}\<close>

named_theorems meta_defs

declare not_def[meta_defs] impl_def[meta_defs] forall\<^sub>\<nu>_def[meta_defs]
        forall\<^sub>0_def[meta_defs] forall\<^sub>1_def[meta_defs]
        forall\<^sub>2_def[meta_defs] forall\<^sub>3_def[meta_defs] forall\<^sub>\<o>_def[meta_defs]
        box_def[meta_defs] actual_def[meta_defs] that_def[meta_defs]
        lambdabinder0_def[meta_defs] lambdabinder1_def[meta_defs]
        lambdabinder2_def[meta_defs] lambdabinder3_def[meta_defs]
        exe0_def[meta_defs] exe1_def[meta_defs] exe2_def[meta_defs]
        exe3_def[meta_defs] enc_def[meta_defs] inv_def[meta_defs]
        that_def[meta_defs] valid_in_def[meta_defs] Concrete_def[meta_defs]

declare [[smt_solver = cvc4]]
declare [[simp_depth_limit = 10]] (* prevent the simplifier from running forever *)
declare [[unify_search_bound = 40]] (* prevent unification bound errors *)

subsection\<open>Auxiliary Lemmata\<close>
text\<open>\label{TAO_Embedding_Aux}\<close>

named_theorems meta_aux

declare make\<kappa>_inverse[meta_aux] eval\<kappa>_inverse[meta_aux]
        make\<o>_inverse[meta_aux] eval\<o>_inverse[meta_aux]
        make\<Pi>\<^sub>1_inverse[meta_aux] eval\<Pi>\<^sub>1_inverse[meta_aux]
        make\<Pi>\<^sub>2_inverse[meta_aux] eval\<Pi>\<^sub>2_inverse[meta_aux]
        make\<Pi>\<^sub>3_inverse[meta_aux] eval\<Pi>\<^sub>3_inverse[meta_aux]
lemma \<nu>\<upsilon>_\<omega>\<nu>_is_\<omega>\<upsilon>[meta_aux]: "\<nu>\<upsilon> (\<omega>\<nu> x) = \<omega>\<upsilon> x" by (simp add: \<nu>\<upsilon>_def)
lemma rep_proper_id[meta_aux]: "rep (x\<^sup>P) = x"
  by (simp add: meta_aux \<nu>\<kappa>_def rep_def)
lemma \<nu>\<kappa>_proper[meta_aux]: "proper (x\<^sup>P)"
  by (simp add: meta_aux \<nu>\<kappa>_def proper_def)
lemma no_\<alpha>\<omega>[meta_aux]: "\<not>(\<nu>\<upsilon> (\<alpha>\<nu> x) = \<omega>\<upsilon> y)" by (simp add: \<nu>\<upsilon>_def)
lemma no_\<sigma>\<omega>[meta_aux]: "\<not>(\<sigma>\<upsilon> x = \<omega>\<upsilon> y)" by blast
lemma \<nu>\<upsilon>_surj[meta_aux]: "surj \<nu>\<upsilon>"
  using \<alpha>\<sigma>_surj unfolding \<nu>\<upsilon>_def surj_def
  by (metis \<nu>.simps(5) \<nu>.simps(6) \<upsilon>.exhaust comp_apply)
lemma lambda\<Pi>\<^sub>1_aux[meta_aux]:
  "make\<Pi>\<^sub>1 (\<lambda>u s w. \<exists>x. \<nu>\<upsilon> x = u \<and> eval\<Pi>\<^sub>1 F (\<nu>\<upsilon> x) s w) = F"
  proof -
    have "\<And> u s w \<phi> . (\<exists> x . \<nu>\<upsilon> x = u \<and> \<phi> (\<nu>\<upsilon> x) (s::j) (w::i)) \<longleftrightarrow> \<phi> u s w"
      using \<nu>\<upsilon>_surj unfolding surj_def by metis
    thus ?thesis apply transfer by simp
  qed
lemma lambda\<Pi>\<^sub>2_aux[meta_aux]:
  "make\<Pi>\<^sub>2 (\<lambda>u v s w. \<exists>x . \<nu>\<upsilon> x = u \<and> (\<exists> y . \<nu>\<upsilon> y = v \<and> eval\<Pi>\<^sub>2 F (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) s w)) = F"
  proof -
    have "\<And> u v (s ::j) (w::i) \<phi> .
      (\<exists> x . \<nu>\<upsilon> x = u \<and> (\<exists> y . \<nu>\<upsilon> y = v \<and> \<phi> (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) s w))
      \<longleftrightarrow> \<phi> u v s w"
      using \<nu>\<upsilon>_surj unfolding surj_def by metis
    thus ?thesis apply transfer by simp
  qed
lemma lambda\<Pi>\<^sub>3_aux[meta_aux]:
  "make\<Pi>\<^sub>3 (\<lambda>u v r s w. \<exists>x. \<nu>\<upsilon> x = u \<and> (\<exists>y. \<nu>\<upsilon> y = v \<and>
   (\<exists>z. \<nu>\<upsilon> z = r \<and> eval\<Pi>\<^sub>3 F (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) (\<nu>\<upsilon> z) s w))) = F"
  proof -
    have "\<And> u v r (s::j) (w::i) \<phi> . \<exists>x. \<nu>\<upsilon> x = u \<and> (\<exists>y. \<nu>\<upsilon> y = v
          \<and> (\<exists>z. \<nu>\<upsilon> z = r \<and> \<phi> (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) (\<nu>\<upsilon> z) s w)) = \<phi> u v r s w"
      using \<nu>\<upsilon>_surj unfolding surj_def by metis
    thus ?thesis apply transfer apply (rule ext)+ by metis
  qed
(*<*)
end
(*>*)


section  \<open>Syntax tree helpers\<close>

theory CPSUtils
imports CPSScheme
begin

text \<open>
This theory defines the sets \<open>lambdas p\<close>, \<open>calls p\<close>, \<open>calls p\<close>, \<open>vars p\<close>, \<open>labels p\<close> and \<open>prims p\<close> as the subexpressions of the program \<open>p\<close>. Finiteness is shown for each of these sets, and some rules about how these sets relate. All these rules are proven more or less the same ways, which is very inelegant due to the nesting of the type and the shape of the derived induction rule.

It would be much nicer to start with these rules and define the set inductively. Unfortunately, that approach would make it very hard to show the finiteness of the sets in question.
\<close>

fun lambdas :: "lambda \<Rightarrow> lambda set"
and lambdasC :: "call \<Rightarrow> lambda set"
and lambdasV :: "val \<Rightarrow> lambda set"
where "lambdas  (Lambda l vs c) = ({Lambda l vs c} \<union> lambdasC c)"
    | "lambdasC (App l d ds) = lambdasV d \<union> \<Union> (lambdasV ` set ds)"
    | "lambdasC (Let l binds c') = (\<Union>(_, y)\<in>set binds. lambdas y) \<union> lambdasC c'"
    | "lambdasV (L l) = lambdas l"
    | "lambdasV _     = {}"

fun calls :: "lambda \<Rightarrow> call set"
and callsC :: "call \<Rightarrow> call set"
and callsV :: "val \<Rightarrow> call set"
where "calls  (Lambda l vs c) = callsC c"
    | "callsC (App l d ds) = {App l d ds} \<union> callsV d \<union> (\<Union>(callsV ` (set ds)))"
    | "callsC (Let l binds c') = {call.Let l binds c'} \<union> ((\<Union>(_, y)\<in>set binds. calls y) \<union> callsC c')"
    | "callsV (L l) = calls l"
    | "callsV _     = {}"

lemma finite_lambdas[simp]: "finite (lambdas l)" and "finite (lambdasC c)" "finite (lambdasV v)"
by (induct rule: lambdas_lambdasC_lambdasV.induct, auto)

lemma finite_calls[simp]: "finite (calls l)" and "finite (callsC c)" "finite (callsV v)"
by (induct rule: calls_callsC_callsV.induct, auto)

fun vars :: "lambda \<Rightarrow> var set"
and varsC :: "call \<Rightarrow> var set"
and varsV :: "val \<Rightarrow> var set"
where "vars (Lambda _ vs c) = set vs \<union> varsC c"
    | "varsC (App _ a as) = varsV a \<union> \<Union>(varsV ` (set as))"
    | "varsC (Let _ binds c') = (\<Union>(v, l)\<in>set binds. {v} \<union> vars l) \<union> varsC c'"
    | "varsV (L l) = vars l"
    | "varsV (R _ v) = {v}"
    | "varsV _  = {}"

fun label :: "lambda + call \<Rightarrow> label"
where "label (Inl (Lambda l _ _)) = l"
    | "label (Inr (App l _ _)) = l"
    | "label (Inr (Let l _ _)) = l"

fun labels :: "lambda \<Rightarrow> label set"
and labelsC :: "call \<Rightarrow> label set"
and labelsV :: "val \<Rightarrow> label set"
where "labels (Lambda l vs c) = {l} \<union> labelsC c"
    | "labelsC (App l a as) = {l} \<union> labelsV a \<union> \<Union>(labelsV ` (set as))"
    | "labelsC (Let l binds c') = {l} \<union> (\<Union>(v, y)\<in>set binds. labels y) \<union> labelsC c'"
    | "labelsV (L l) = labels l"
    | "labelsV (R l _) = {l}"
    | "labelsV _  = {}"

lemma finite_labels[simp]: "finite (labels l)" and "finite (labelsC c)" "finite (labelsV v)"
by (induct rule: labels_labelsC_labelsV.induct, auto)

fun prims :: "lambda \<Rightarrow> prim set"
and primsC :: "call \<Rightarrow> prim set"
and primsV :: "val \<Rightarrow> prim set"
where "prims (Lambda _ vs c) = primsC c"
    | "primsC (App _ a as) = primsV a \<union> \<Union>(primsV ` (set as))"
    | "primsC (Let _ binds c') = (\<Union>(_, y)\<in>set binds. prims y) \<union> primsC c'"
    | "primsV (L l) = prims l"
    | "primsV (R l v) = {}"
    | "primsV (P prim) = {prim}"
    | "primsV (C l v) = {}"

lemma finite_prims[simp]: "finite (prims l)" and "finite (primsC c)" "finite (primsV v)"
by (induct rule: labels_labelsC_labelsV.induct, auto)

fun vals :: "lambda \<Rightarrow> val set"
and valsC :: "call \<Rightarrow> val set"
and valsV :: "val \<Rightarrow> val set"
where "vals (Lambda _ vs c) = valsC c"
    | "valsC (App _ a as) = valsV a \<union> \<Union>(valsV ` (set as))"
    | "valsC (Let _ binds c') = (\<Union>(_, y)\<in>set binds. vals y) \<union> valsC c'"
    | "valsV (L l) = {L l} \<union> vals l"
    | "valsV (R l v) = {R l v}"
    | "valsV (P prim) = {P prim}"
    | "valsV (C l v) = {C l v}"

lemma
  fixes list2 :: "(var \<times> lambda) list" and t :: "var\<times>lambda"
  shows lambdas1: "Lambda l vs c \<in> lambdas x \<Longrightarrow> c \<in> calls x"
  and "Lambda l vs c \<in> lambdasC y \<Longrightarrow> c \<in> callsC y"
  and "Lambda l vs c \<in> lambdasV z \<Longrightarrow> c \<in> callsV z"
  and "\<forall>z\<in> set list. Lambda l vs c \<in> lambdasV z \<longrightarrow> c \<in> callsV z"
  and "\<forall>x\<in> set list2. Lambda l vs c \<in> lambdas (snd x) \<longrightarrow> c \<in> calls (snd x)"
  and "Lambda l vs c \<in> lambdas (snd t) \<Longrightarrow> c \<in> calls (snd t)"
apply (induct rule:mutual_lambda_call_var_inducts)
apply auto
apply (case_tac c, auto)[1]
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows lambdas2: "Lambda l vs c \<in> lambdas x \<Longrightarrow> l \<in> labels x"
  and "Lambda l vs c \<in> lambdasC y \<Longrightarrow> l \<in> labelsC y"
  and "Lambda l vs c \<in> lambdasV z \<Longrightarrow> l \<in> labelsV z"
  and "\<forall>z\<in> set list. Lambda l vs c \<in> lambdasV z \<longrightarrow> l \<in> labelsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Lambda l vs c \<in> lambdas (snd x) \<longrightarrow> l \<in> labels (snd x)"
  and "Lambda l vs c \<in> lambdas (snd (t:: var\<times>lambda)) \<Longrightarrow> l \<in> labels (snd t)"
apply (induct rule:mutual_lambda_call_var_inducts)
apply auto
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows lambdas3: "Lambda l vs c \<in> lambdas x \<Longrightarrow> set vs \<subseteq> vars x"
  and "Lambda l vs c \<in> lambdasC y \<Longrightarrow> set vs \<subseteq> varsC y"
  and "Lambda l vs c \<in> lambdasV z \<Longrightarrow> set vs \<subseteq> varsV z"
  and "\<forall>z\<in> set list. Lambda l vs c \<in> lambdasV z \<longrightarrow> set vs \<subseteq> varsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Lambda l vs c \<in> lambdas (snd x) \<longrightarrow> set vs \<subseteq> vars (snd x)"
  and "Lambda l vs c \<in> lambdas (snd (t:: var\<times>lambda)) \<Longrightarrow> set vs \<subseteq> vars (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((aa, ba), bb)" in ballE)
apply (rule_tac x="((aa, ba), bb)" in bexI, auto)
done

lemma
  shows app1: "App l d ds \<in> calls x \<Longrightarrow> d \<in> vals x"
  and "App l d ds \<in> callsC y \<Longrightarrow> d \<in> valsC y"
  and "App l d ds \<in> callsV z \<Longrightarrow> d \<in> valsV z"
  and "\<forall>z\<in> set list. App l d ds \<in> callsV z \<longrightarrow> d \<in> valsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . App l d ds \<in> calls (snd x) \<longrightarrow> d \<in> vals (snd x)"
  and "App l d ds \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> d \<in> vals (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (case_tac d, auto)
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows app2: "App l d ds \<in> calls x \<Longrightarrow> set ds \<subseteq> vals x"
  and "App l d ds \<in> callsC y \<Longrightarrow> set ds \<subseteq> valsC y"
  and "App l d ds \<in> callsV z \<Longrightarrow> set ds \<subseteq> valsV z"
  and "\<forall>z\<in> set list. App l d ds \<in> callsV z \<longrightarrow> set ds \<subseteq> valsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . App l d ds \<in> calls (snd x) \<longrightarrow> set ds \<subseteq> vals (snd x)"
  and "App l d ds \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> set ds \<subseteq> vals (snd t)"
apply (induct  x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (case_tac x, auto)
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows let1: "Let l binds c' \<in> calls x \<Longrightarrow> l \<in> labels x"
  and "Let l binds c' \<in> callsC y \<Longrightarrow> l \<in> labelsC y"
  and "Let l binds c' \<in> callsV z \<Longrightarrow> l \<in> labelsV z"
  and "\<forall>z\<in> set list. Let l binds c' \<in> callsV z \<longrightarrow> l \<in> labelsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Let l binds c' \<in> calls (snd x) \<longrightarrow> l \<in> labels (snd x)"
  and "Let l binds c' \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> l \<in> labels (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows let2: "Let l binds c' \<in> calls x \<Longrightarrow> c' \<in> calls x"
  and "Let l binds c' \<in> callsC y \<Longrightarrow> c' \<in> callsC y"
  and "Let l binds c' \<in> callsV z \<Longrightarrow> c' \<in> callsV z"
  and "\<forall>z\<in> set list. Let l binds c' \<in> callsV z \<longrightarrow> c' \<in> callsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Let l binds c' \<in> calls (snd x) \<longrightarrow> c' \<in> calls (snd x)"
  and "Let l binds c' \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> c' \<in> calls (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (case_tac c', auto)
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
  shows let3: "Let l binds c' \<in> calls x \<Longrightarrow> fst ` set binds \<subseteq> vars x"
  and "Let l binds c' \<in> callsC y \<Longrightarrow> fst ` set binds \<subseteq> varsC y"
  and "Let l binds c' \<in> callsV z \<Longrightarrow> fst ` set binds \<subseteq> varsV z"
  and "\<forall>z\<in> set list. Let l binds c' \<in> callsV z \<longrightarrow> fst ` set binds \<subseteq> varsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Let l binds c' \<in> calls (snd x) \<longrightarrow> fst ` set binds \<subseteq> vars (snd x)"
  and "Let l binds c' \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> fst ` set binds \<subseteq> vars (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((ab, bc), bd)" in ballE)
apply (rule_tac x="((ab, bc), bd)" in bexI, auto)
done

lemma
  shows let4: "Let l binds c' \<in> calls x \<Longrightarrow> snd ` set binds \<subseteq> lambdas x"
  and "Let l binds c' \<in> callsC y \<Longrightarrow> snd ` set binds \<subseteq> lambdasC y"
  and "Let l binds c' \<in> callsV z \<Longrightarrow> snd ` set binds \<subseteq> lambdasV z"
  and "\<forall>z\<in> set list. Let l binds c' \<in> callsV z \<longrightarrow> snd ` set binds \<subseteq> lambdasV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . Let l binds c' \<in> calls (snd x) \<longrightarrow> snd ` set binds \<subseteq> lambdas (snd x)"
  and "Let l binds c' \<in> calls (snd (t:: var\<times>lambda)) \<Longrightarrow> snd ` set binds \<subseteq> lambdas (snd t)"
apply (induct x and y and z and list and list2 and t rule:mutual_lambda_call_var_inducts)
apply auto
apply (rule_tac x="((a, b), ba)" in bexI, auto)
apply (case_tac ba, auto)
apply (erule_tac x="((aa, bb), bc)" in ballE)
apply (rule_tac x="((aa, bb), bc)" in bexI, auto)
done

lemma
shows vals1: "P prim \<in> vals p \<Longrightarrow> prim \<in> prims p"
  and "P prim \<in> valsC y \<Longrightarrow> prim \<in> primsC y"
  and "P prim \<in> valsV z \<Longrightarrow> prim \<in> primsV z"
  and "\<forall>z\<in> set list. P prim \<in> valsV z \<longrightarrow> prim \<in> primsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . P prim \<in> vals (snd x) \<longrightarrow> prim \<in> prims (snd x)"
  and "P prim \<in> vals (snd (t:: var\<times>lambda)) \<Longrightarrow> prim \<in> prims (snd t)"
apply (induct rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
shows vals2: "R l var \<in> vals p \<Longrightarrow> var \<in> vars p"
  and "R l var \<in> valsC y \<Longrightarrow> var \<in> varsC y"
  and "R l var \<in> valsV z \<Longrightarrow> var \<in> varsV z"
  and "\<forall>z\<in> set list. R l var \<in> valsV z \<longrightarrow> var \<in> varsV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . R l var \<in> vals (snd x) \<longrightarrow> var \<in> vars (snd x)"
  and "R l var \<in> vals (snd (t:: var\<times>lambda)) \<Longrightarrow> var \<in> vars (snd t)"
apply (induct rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
done

lemma
shows vals3: "L l \<in> vals p \<Longrightarrow> l \<in> lambdas p"
  and "L l \<in> valsC y \<Longrightarrow> l \<in> lambdasC y"
  and "L l \<in> valsV z \<Longrightarrow> l \<in> lambdasV z"
  and "\<forall>z\<in> set list. L l \<in> valsV z \<longrightarrow> l \<in> lambdasV z"
  and "\<forall>x\<in> set (list2 :: (var \<times> lambda) list) . L l \<in> vals (snd x) \<longrightarrow> l \<in> lambdas (snd x)"
  and "L l \<in> vals (snd (t:: var\<times>lambda)) \<Longrightarrow> l \<in> lambdas (snd t)"
apply (induct rule:mutual_lambda_call_var_inducts)
apply auto
apply (erule_tac x="((a, b), ba)" in ballE)
apply (rule_tac x="((a, b), ba)" in bexI, auto)
apply (case_tac l, auto)
done

definition nList :: "'a set => nat => 'a list set"
where "nList A n \<equiv> {l. set l \<le> A \<and> length l = n}"

definition NList :: "'a set => nat set => 'a list set"
where "NList A N \<equiv> \<Union> n \<in> N. nList A n"

lemma finite_Nlist[intro]:
  "\<lbrakk> finite A; finite N \<rbrakk> \<Longrightarrow> finite (NList A N)"
unfolding NList_def by auto

definition call_list_lengths
  where "call_list_lengths p = {0,1,2,3} \<union> (\<lambda>c. case c of (App _ _ ds) \<Rightarrow> length ds | _ \<Rightarrow> 0) ` calls p"

lemma finite_call_list_lengths[simp]: "finite (call_list_lengths p)"
  unfolding call_list_lengths_def by auto

end


(*<*)
theory GewirthArgument
  imports ExtendedDDL
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]
(*>*)

text\<open>\noindent{Before starting our formalisation in the next section. We show that the axioms defined so far are consistent.
Rather surprisingly, the \emph{nunchaku} model finder states that no model has been found, while \emph{nitpick}
is indeed able to find one:}\<close>
lemma True nunchaku[satisfy] nitpick[satisfy] oops

section \<open>Gewith's Argument for the Principle of Generic Consistency (PGC)\<close>

text\<open>\noindent{Alan Gewirth's meta-ethical position is known as moral (or ethical) rationalism. According to it, moral principles are knowable \emph{a priori},
by reason alone.
Immanuel Kant is perhaps the most famous figure who has defended such a position. He has argued for the existence of upper moral principles
(e.g. his "categorical imperative")
from which we can reason (in a top-down fashion) in order to deduce and evaluate other more concrete maxims and actions.
In contrast to Kant, Gewirth attempts to derive such upper moral principles by starting from non-moral considerations alone, namely from
an agent's self-reflection.
Gewirth's Principle of Generic Consistency (PGC) asserts that any agent (by virtue of its self-understanding as an agent) is rationally committed
to asserting that (i) it has rights to freedom and well-being, and (ii) that all other agents have those same rights. Gewirth claims that, in his informal proof,
the latter generalisation step (from "I" to all individuals) is done on purely logical grounds and does not presuppose any kind of universal moral principle.
Gewirth's result is thus meant to hold with some kind of apodicticity (i.e.~necessity).
Deryck Beyleveld, author of an authoritative book on Gewirth's argument, puts it this way:
"The argument purports to establish the PGC as a rationally necessary proposition with an apodictic status
\emph{for any PPA} equivalent to that enjoyed by the logical principle of noncontradiction itself." (@{cite "Beyleveld"} p. 1)
If this is correct, then he succeeded in the task that Kant set himself, i.e.~to found certain basic principles of morality in reason alone.}\<close>
text\<open>\noindent{The argument for the PGC  employs what Gewirth calls "the dialectically necessary method" within the "internal viewpoint" (perspective) of an agent.
Although the drawn inferences are relative to the reasoning agent, Gewirth further argues that
"the dialectically necessary method propounds the contents of this relativity
as necessary ones, since the statements it presents reflect judgements all agents necessarily make on the basis of what is necessarily
involved in their actions ... The statements the method attributes to the agent are set forth as necessary ones in that they reflect what is conceptually
necessary to being an agent who voluntarily or freely acts for purposes he wants to attain." (@{cite "GewirthRM"}).
In other words, the "dialectical necessity" of the assertions and inferences made in the argument comes from the definitional features (conceptual analysis)
of the involved notions of agency, purposeful action, obligation, rights, etc. Hence the alternative notions of logical (i.e.~indexical) validity
and 'a priori necessity', developed in Kaplan's logical framework LD, have been considered by us as appropriate to model this kind of "dialectical necessity".}\<close>

subsection \<open>Conceptual Explications\<close>

type_synonym p = "e\<Rightarrow>m" \<comment> \<open> Type for properties (function from individuals to sentence meanings) \<close>

subsubsection \<open>Agency\<close>

text\<open>\noindent{The type chosen to represent what Gewirth calls "purposes" is not essential for the argument's validity.
We choose to give "purposes" the same type as sentence meanings (type 'm'), so "acting on a purpose" would be
represented in an analogous way to having a certain propositional attitude (e.g. "desiring that some proposition obtains"). }\<close>
consts ActsOnPurpose:: "e\<Rightarrow>m\<Rightarrow>m" \<comment> \<open>  ActsOnPurpose(A,E) gives the meaning of the sentence "A is acting on purpose E" \<close>
consts NeedsForPurpose:: "e\<Rightarrow>p\<Rightarrow>m\<Rightarrow>m" \<comment> \<open>  NeedsForPurpose(A,P,E) gives the meaning of "A needs to have property P in order to reach purpose E" \<close>

text\<open>\noindent{In Gewirth's argument, an individual with agency (i.e.~capable of purposive action) is said to be a PPA (prospective purposive agent).}\<close>
definition PPA:: "p" where "PPA a \<equiv> \<^bold>\<exists>E. ActsOnPurpose a E" \<comment> \<open>  Definition of PPA \<close>

text\<open>\noindent{We have added the following axiom in order to guarantee the argument's logical correctness. It basically says that being
a PPA is identity-constitutive for an individual (i.e.~it's an essential property).}\<close>
axiomatization where essentialPPA: "\<lfloor>\<^bold>\<forall>a. PPA a \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>D(PPA a)\<rfloor>\<^sup>D" \<comment> \<open> being a PPA is an essential property \<close>

text\<open>\noindent{Quite interestingly, the axiom above entails, as a corollary, a kind of ability for a PPA to recognise other PPAs.
For instance, if some individual holds itself as a PPA (i.e.~seen from its own perspective/context 'd') then this individual
(Agent(d)) is considered as a PPA from any other agent's perspective/context 'c'.}\<close>
lemma recognizeOtherPPA: "\<forall>c d. \<lfloor>PPA (Agent d)\<rfloor>\<^sub>d \<longrightarrow> \<lfloor>PPA (Agent d)\<rfloor>\<^sub>c" using essentialPPA by blast

subsubsection \<open>Goodness\<close>

text\<open>\noindent{Gewirth's concept of (subjective) goodness, as employed in his argument, applies to purposes and is relative to some agent.
It is therefore modelled as a binary relation relating an individual (type 'e') with a purpose (type 'm').
Other readings given by Gewirth's for the expression "P is good for A" include among others: "A attaches a positive value to P",
"A values P proactively" and "A is motivated to achieve P".}\<close>
consts Good::"e\<Rightarrow>m\<Rightarrow>m"

text\<open>\noindent{The following axioms interrelate the concept of goodness with the concept of agency, thus providing
the above concepts with some meaning (by framing their inferential roles). Notice that such meaning-constitutive
axioms (which we call "explications") are given as indexically valid (i.e.~a priori) sentences.}\<close>
axiomatization where explicationGoodness1: "\<lfloor>\<^bold>\<forall>a P. ActsOnPurpose a P \<^bold>\<rightarrow> Good a P\<rfloor>\<^sup>D"
axiomatization where explicationGoodness2: "\<lfloor>\<^bold>\<forall>P M a. Good a P \<^bold>\<and> NeedsForPurpose a M P \<^bold>\<rightarrow> Good a (M a)\<rfloor>\<^sup>D"
axiomatization where explicationGoodness3: "\<lfloor>\<^bold>\<forall>\<phi> a. \<^bold>\<diamond>\<^sub>p\<phi> \<^bold>\<rightarrow> \<^bold>O\<langle>\<phi> | \<^bold>\<box>\<^sup>DGood a \<phi>\<rangle>\<rfloor>\<^sup>D"

text\<open>\noindent{Below we show that all axioms defined so far are consistent:}\<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 1] oops \<comment> \<open> one-world model found (card w=1) \<close>

text\<open>\noindent{The first two assertions above have been explicitly provided by Gewirth as premises of his argument.
The third axiom, however, has been added by us as an implicit premise in order to render Gewirth's proof as correct.
This axiom aims at representing the intuitive notion of "seeking the good". In particular, it asserts
that, from the point of view of an agent, necessarily good purposes are not only action motivating,
but also entail an instrumental obligation to their realisation. The notion of necessity here involved
is not the usual alethic one (which is represented in DDL with the modal box operators \<open>\<^bold>\<box>\<^sub>a\<close> and \<open>\<^bold>\<box>\<^sub>p\<close>), but the linguistic one
introduced above (\<open>\<^bold>\<box>\<^sup>D\<close>) derived from indexical validity, signaling that an agent holds some
purpose as being true almost 'by definition' (i.e.~a priori).
This sets quite high standards for the kind of purposes an agent would ever take to be (instrumentally) obligatory and is
indeed the weakest implicit premise we could come up with so far (taking away the \<open>\<^bold>\<box>\<^sup>D\<close> 'a priori necessity' operator
would indeed make this premise much stronger and our proof less credible).}\<close>

subsubsection \<open>Freedom and Well-Being\<close>

text\<open>\noindent{According to Gewirth, enjoying freedom and well-being (which we take together as a predicate: FWB) is the property
which represents the "necessary conditions" or "generic features" of agency (i.e.~being capable of purposeful action).
Gewirth argues, the property of enjoying freedom and well-being (FWB) is special amongst other action-enabling properties,
in that it is always required in order to act on any purpose (no matter which one).}\<close>

consts FWB::"p" \<comment> \<open> Enjoying freedom and well-being (FWB) is a property (i.e.~has type @{text "e\<Rightarrow>m"}) \<close>

axiomatization where
explicationFWB1: "\<lfloor>\<^bold>\<forall>P a. NeedsForPurpose a FWB P\<rfloor>\<^sup>D"

text\<open>\noindent{We use model finder \emph{nitpick} to verify that all axioms defined so far are consistent.
\emph{Nitpick} can indeed find a 'small' model with cardinality one for the sets of worlds and contexts.}\<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 1] oops \<comment> \<open> one-world model found  \<close>

text\<open>\noindent{At some point in Gewirth's argument we have to show that there exists an (instrumental) obligation to enjoying freedom and well-being (FWB).
Since, according to the so-called "Kant's law" (which is a corollary of DDL), impossible or necessary things cannot be obligatory,
we can reasonably demand that
FWB be (metaphysically) possible for every agent. As before, we take this demand to be an a priori
characteristic of the concept of FWB and therefore axiomatise it as an indexically valid sentence.}\<close>
axiomatization where explicationFWB2: "\<lfloor>\<^bold>\<forall>a. \<^bold>\<diamond>\<^sub>p FWB a\<rfloor>\<^sup>D"
axiomatization where explicationFWB3: "\<lfloor>\<^bold>\<forall>a. \<^bold>\<diamond>\<^sub>p \<^bold>\<not>FWB a\<rfloor>\<^sup>D"

text\<open>\noindent{As a result of enforcing the contingency of FWB, the models found by \emph{nitpick} now have a cardinality
of two for the set of worlds:}\<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 1, expect=none] oops \<comment> \<open> no model found for one-world models \<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 2] oops \<comment> \<open> models need now at least two worlds \<close>

subsubsection \<open>Obligation and Interference\<close>

text\<open>\noindent{ Kant's Law ("ought implies can") is derivable directly from DDL: If \<open>\<phi>\<close> oughts to obtain then \<open>\<phi>\<close> is possible.
Note that we will use for the formalisation of Gewirth's argument the DDL ideal obligation operator (\<open>\<^bold>O\<^sub>i\<close>) but
we could have also used (mutatis mutandis) the DDL actual obligation operator (\<open>\<^bold>O\<^sub>a\<close>).}\<close>
lemma "\<lfloor>\<^bold>O\<^sub>i\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sub>p\<phi>\<rfloor>" using sem_5ab by simp

text\<open>\noindent{Furthermore, we have seen the need to postulate the following (implicit) premise in order to validate the argument.
This axiom can be seen as a variation of the so-called Kant's law ("ought implies can"), i.e.~an impossible act cannot be obligatory.
In the same vein, our variation can be read as "ought implies ought to can" and is closer to Gewirth's own description:
that having an obligation to do X implies that "I ought (in the same sense and the same criterion) to be free to do X,
that I ought not to be prevented from doing X, that my capacity to do X ought not to be interfered with." (@{cite "GewirthRM"} p. 91-95)}\<close>
axiomatization where OIOAC: "\<lfloor>\<^bold>O\<^sub>i\<phi> \<^bold>\<rightarrow> \<^bold>O\<^sub>i(\<^bold>\<diamond>\<^sub>a\<phi>)\<rfloor>\<^sup>D"

text\<open>\noindent{Concerning the concept of interference, we state that the existence of an individual (successfully) interfering
with some state of affairs S implies that S cannot possibly obtain in any of the actually possible situations (and the other way round).
Note that for this definition we have employed a possibility operator (\<open>\<^bold>\<diamond>\<^sub>a\<close>) which is weaker than metaphysical
possibility (\<open>\<^bold>\<diamond>\<^sub>p\<close>) (see Carmo and Jones DDL framework @{cite "CJDDL"} for details).
Also note that we have also employed the (stronger) classical notion of modal
validity instead of indexical validity. (So far we haven't been able to get theorem provers and model finders to prove/disprove
Gewirth's proof if formalizing this axiom as simply indexically valid.)}\<close>

consts InterferesWith::"e\<Rightarrow>m\<Rightarrow>m" \<comment> \<open> an individual can interfere with some state of affairs (from obtaining) \<close>
axiomatization where explicationInterference: "\<lfloor>(\<^bold>\<exists>b. InterferesWith b \<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<diamond>\<^sub>a\<phi>\<rfloor>"

text\<open>\noindent{From the previous axiom we can prove following corollaries: If someone (successfully) interferes with agent 'a' having FWB,
then 'a' can no longer possibly enjoy its FWB (and the other way round).}\<close>
lemma "\<lfloor>\<^bold>\<forall>a. (\<^bold>\<exists>b. InterferesWith b (FWB a)) \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<diamond>\<^sub>a(FWB a)\<rfloor>" using explicationInterference by blast
lemma InterferenceWithFWB: "\<lfloor>\<^bold>\<forall>a.  \<^bold>\<diamond>\<^sub>a(FWB a) \<^bold>\<leftrightarrow> (\<^bold>\<forall>b. \<^bold>\<not>InterferesWith b (FWB a))\<rfloor>" using explicationInterference by blast

subsubsection \<open>Rights and Other-Directed Obligations\<close>

text\<open>\noindent{Gewirth points out the existence of a correlation between an agent's own claim rights and other-referring obligations (see e.g. @{cite "GewirthRM"}, p. 66).
A claim right is a right which entails duties or obligations on other agents regarding the right-holder
(so-called Hohfeldian claim rights in legal theory).
We model this concept of claim rights in such a way that an individual 'a' has a (claim) right to some property 'P' if and only if
it is obligatory that every
(other) individual 'b' does not interfere with the state of affairs 'P(a)' from obtaining.
Since there is no particular individual to whom this directive is addressed, this obligation has been referred to by Gewirth as being "other-directed"
(aka. "other-referring") in contrast to "other-directing" obligations which entail a moral obligation for some particular subject (@{cite "Beyleveld"} p. 41,51).
This latter distinction is essential to Gewirth's argument.}\<close>
definition RightTo::"e\<Rightarrow>(e\<Rightarrow>m)\<Rightarrow>m" where "RightTo a \<phi> \<equiv> \<^bold>O\<^sub>i(\<^bold>\<forall>b. \<^bold>\<not>InterferesWith b (\<phi> a))"

text\<open>\noindent{Now that all needed axioms and definitions are in place, we use model finder \emph{nitpick} to show that
they are consistent:}\<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 2] oops \<comment> \<open> models with at least two worlds found \<close>

subsection \<open>Formal Proof of Gewirth's Argument for the PGC\<close>

text\<open>\noindent{Following Beyleveld's summary (@{cite "Beyleveld"}, ch. 2), the main steps of the argument are (with original numbering): }\<close>
text\<open>\noindent{(1) I act voluntarily for some (freely chosen) purpose E (equivalent --by definition-- to: I am a PPA).}\<close>
text\<open>\noindent{(2) E is (subjectively) good (i.e.~I value E proactively).}\<close>
text\<open>\noindent{(3) My freedom and well-being (FWB) are generically necessary conditions of my agency (i.e.~I need them to achieve any purpose whatsoever).}\<close>
text\<open>\noindent{(4) My FWB are necessary goods (at least for me).}\<close>
text\<open>\noindent{(5) I (even if no one else) have a claim right to my FWB.}\<close>
text\<open>\noindent{(13) Every PPA has a claim right to their FWB.}\<close>

subsubsection \<open>Weak Variant\<close>
text\<open>\noindent{In the following we present a formalised proof for a weak variant of the Principle of Generic Consistency (PGC),
which asserts that the following sentence is valid from every PPA's standpoint:
"I (as a PPA) have a claim right to my freedom and well-being".}\<close>
theorem PGC_weak: shows "\<forall>C. \<lfloor>PPA (Agent C) \<^bold>\<rightarrow> (RightTo (Agent C) FWB)\<rfloor>\<^sub>C"
proof - {
  fix C::c \<comment> \<open> 'C' is some arbitrarily chosen context (agent's perspective) \<close>
  let ?I = "(Agent C)" \<comment> \<open> 'I' is/am the agent with perspective 'C' \<close>
  {
    fix E::m \<comment> \<open> 'E' is some arbitrarily chosen purpose \<close>
    {
      assume P1: "\<lfloor>ActsOnPurpose ?I E\<rfloor>\<^sub>C" \<comment> \<open> (1) I act voluntarily on purpose E \<close>
      from P1 have P1a: "\<lfloor>PPA ?I\<rfloor>\<^sub>C" using PPA_def by auto \<comment> \<open> (1a) I am a PPA \<close>
      from P1 have C2: "\<lfloor>Good ?I E\<rfloor>\<^sub>C" using explicationGoodness1 essentialPPA by meson \<comment> \<open> (2) purpose E is good for me \<close>
      from explicationFWB1 have C3: "\<lfloor>\<^bold>\<forall>P. NeedsForPurpose ?I FWB P\<rfloor>\<^sup>D" by simp \<comment> \<open> (3) I need FWB for any purpose whatsoever \<close>
      hence "\<exists>P.\<lfloor>Good ?I P \<^bold>\<and> NeedsForPurpose ?I FWB P\<rfloor>\<^sup>D" using explicationFWB2 explicationGoodness3 sem_5ab by blast
      hence "\<lfloor>Good ?I (FWB ?I)\<rfloor>\<^sup>D" using explicationGoodness2 by blast \<comment> \<open> FWB is (a priori) good for me (in a kind of definitional sense) \<close>
      hence C4: "\<lfloor>\<^bold>\<box>\<^sup>D(Good ?I (FWB ?I))\<rfloor>\<^sub>C" by simp \<comment> \<open> (4) FWB is an (a priori) necessary good for me \<close>
      have "\<lfloor>\<^bold>O\<langle>FWB ?I | \<^bold>\<box>\<^sup>D(Good ?I) (FWB ?I)\<rangle>\<rfloor>\<^sub>C" using explicationGoodness3 explicationFWB2 by blast \<comment> \<open> I ought to pursue my FWB on the condition that I consider it to be a necessary good \<close>
      hence "\<lfloor>\<^bold>O\<^sub>i(FWB ?I)\<rfloor>\<^sub>C" using explicationFWB2 explicationFWB3 C4 CJ_14p by fastforce \<comment> \<open> There is an (other-directed) obligation to my FWB \<close>
      hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<diamond>\<^sub>a(FWB ?I))\<rfloor>\<^sub>C" using OIOAC by simp \<comment> \<open> It must therefore be the case that my FWB is possible \<close>
      hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<forall>a. \<^bold>\<not>InterferesWith a (FWB ?I))\<rfloor>\<^sub>C" using InterferenceWithFWB by simp \<comment> \<open> There is an obligation for others not to interfere with my FWB  \<close>
      hence C5: "\<lfloor>RightTo ?I FWB\<rfloor>\<^sub>C" using RightTo_def by simp \<comment> \<open> (5) I have a claim right to my freedom and well-being \<close>
    }
    hence "\<lfloor>ActsOnPurpose ?I E \<^bold>\<rightarrow> RightTo ?I FWB\<rfloor>\<^sub>C" by (rule impI) \<comment> \<open> I have a claim right to my freedom and well-being (since I act on some purpose E) \<close>
  }
  hence "\<lfloor>\<^bold>\<forall>P. ActsOnPurpose ?I P \<^bold>\<rightarrow> RightTo ?I FWB\<rfloor>\<^sub>C" by (rule allI) \<comment> \<open>  "allI" is a logical generalisation rule: "all-quantifier introduction" \<close>
  hence "\<lfloor>PPA ?I \<^bold>\<rightarrow> RightTo ?I FWB\<rfloor>\<^sub>C" using PPA_def by simp \<comment> \<open> (seen from my perspective C) I have a claim right to my freedom and well-being since I am a PPA \<close>
  hence "\<lfloor>PPA (Agent C) \<^bold>\<rightarrow> RightTo (Agent C) FWB\<rfloor>\<^sub>C" by simp \<comment> \<open> (seen from the perspective C) C's agent has a claim right to its freedom and well-being since it is a PPA \<close>
}
  thus C13: "\<forall>C. \<lfloor>PPA (Agent C) \<^bold>\<rightarrow> (RightTo (Agent C) FWB)\<rfloor>\<^sub>C" by (rule allI) \<comment> \<open> (13) For every perspective C: C's agent has a claim right to its freedom and well-being \<close>
qed

text\<open>\noindent{Regarding the last inference step, given that the context (agent's perspective) 'C' has been arbitrarily fixed at the beginning, we can use again the "all-quantifier introduction" rule
to generalise the previous assertion to all possible contexts 'C' (and agents 'Agent(C)').
Note that the generalisation from "I" to all individuals has been done on purely logical grounds and does not involve any kind of universal moral principle.
This is a main requirement Gewirth has set for his argument.}\<close>

subsubsection \<open>Strong Variant\<close>
text\<open>\noindent{This is a proof for a stronger variant of the PGC, which asserts that the following
sentence is valid from every PPA's standpoint: "Every PPA has a claim right to its freedom and well-being (FWB)".}\<close>

theorem PGC_strong: shows "\<lfloor>\<^bold>\<forall>x. PPA x \<^bold>\<rightarrow> (RightTo x FWB)\<rfloor>\<^sup>D"
proof - {
fix C::c  \<comment> \<open> 'C' is some arbitrarily chosen context (agent's perspective) \<close>
{
  fix I::"e"  \<comment> \<open> 'I' is some arbitrarily chosen individual (agent's perspective) \<close>
  {
    fix E::m  \<comment> \<open> 'E' is some arbitrarily chosen purpose \<close>
    {
     assume P1: "\<lfloor>ActsOnPurpose I E\<rfloor>\<^sub>C" \<comment> \<open> (1) I act voluntarily on purpose E \<close>
     from P1 have P1a: "\<lfloor>PPA I\<rfloor>\<^sub>C" using PPA_def by auto  \<comment> \<open> (1a) I am a PPA \<close>
     from P1 have C2: "\<lfloor>Good I E\<rfloor>\<^sub>C" using explicationGoodness1 essentialPPA by meson  \<comment> \<open> (2) purpose E is good for me \<close>
     from explicationFWB1 have C3: "\<lfloor>\<^bold>\<forall>P. NeedsForPurpose I FWB P\<rfloor>\<^sup>D" by simp  \<comment> \<open> (3) I need FWB for any purpose whatsoever \<close>
     hence "\<exists>P.\<lfloor>Good I P \<^bold>\<and> NeedsForPurpose I FWB P\<rfloor>\<^sup>D" using explicationFWB2 explicationGoodness3 sem_5ab by blast
     hence "\<lfloor>Good I (FWB I)\<rfloor>\<^sup>D" using explicationGoodness2 by blast  \<comment> \<open> FWB is (a priori) good for me (in a kind of definitional sense) \<close>
     hence C4: "\<lfloor>\<^bold>\<box>\<^sup>D(Good I (FWB I))\<rfloor>\<^sub>C" by simp  \<comment> \<open> (4) FWB is an (a priori) necessary good for me\<close>
     have "\<lfloor>\<^bold>O\<langle>FWB I | \<^bold>\<box>\<^sup>D(Good I) (FWB I)\<rangle>\<rfloor>\<^sub>C" using explicationGoodness3 explicationFWB2 by blast  \<comment> \<open> I ought to pursue my FWB on the condition that I consider it to be a necessary good\<close>
     hence "\<lfloor>\<^bold>O\<^sub>i(FWB I)\<rfloor>\<^sub>C" using explicationFWB2 explicationFWB3 C4 CJ_14p by fastforce  \<comment> \<open> There is an (other-directed) obligation to my FWB\<close>
     hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<diamond>\<^sub>a(FWB I))\<rfloor>\<^sub>C" using OIOAC by simp  \<comment> \<open> It must therefore be the case that my FWB is possible\<close>
     hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<forall>a. \<^bold>\<not>InterferesWith a (FWB I))\<rfloor>\<^sub>C" using InterferenceWithFWB by simp  \<comment> \<open> There is an obligation for others not to interfere with my FWB\<close>
     hence C5: "\<lfloor>RightTo I FWB\<rfloor>\<^sub>C" using RightTo_def by simp  \<comment> \<open> (5) I have a claim right to my FWB\<close>
   }
    hence "\<lfloor>ActsOnPurpose I E \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" by (rule impI)  \<comment> \<open> I have a claim right to my FWB (since I act on some purpose E)\<close>
  }
  hence "\<lfloor>\<^bold>\<forall>P. ActsOnPurpose I P \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" by (rule allI)
  hence "\<lfloor>PPA I \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" using PPA_def by simp  \<comment> \<open> I have a claim right to my FWB since I am a PPA \<close>
}
  hence "\<forall>x. \<lfloor>PPA x \<^bold>\<rightarrow> RightTo x FWB\<rfloor>\<^sub>C" by simp  \<comment> \<open> Every agent has a claim right to its FWB since it is a PPA\<close>
}
thus C13: "\<forall>C. \<lfloor>\<^bold>\<forall>x. PPA x \<^bold>\<rightarrow> (RightTo x FWB)\<rfloor>\<^sub>C" by (rule allI)  \<comment> \<open> (13) For every perspective C: every agent has a claim right to its FWB\<close>
qed

text\<open>\noindent{We show that the weaker variant of the PGC presented above can be derived
from the stronger one.}\<close>
lemma PGC_weak2: "\<forall>C. \<lfloor>PPA (Agent C) \<^bold>\<rightarrow> (RightTo (Agent C) FWB)\<rfloor>\<^sub>C" using PGC_strong by simp

subsubsection \<open>Some Exemplary Inferences\<close>

text\<open>\noindent{In the following, we illustrate how to draw some inferences building upon Gewirth's PGC.}\<close>

consts X::c  \<comment> \<open> Context of use X (to which a certain speaker agent corresponds)\<close>
consts Y::c  \<comment> \<open> Context of use Y (to which another speaker agent corresponds)\<close>

text\<open>\noindent{The agent (of context) X holds itself as a PPA.}\<close>
axiomatization where AgentX_X_PPA: "\<lfloor>PPA (Agent X)\<rfloor>\<^sub>X"

text\<open>\noindent{The agent (of another context) Y holds the agent (of context) X  as a PPA.}\<close>
lemma AgentY_X_PPA: "\<lfloor>PPA (Agent X)\<rfloor>\<^sub>Y" using AgentX_X_PPA recognizeOtherPPA by simp

text\<open>\noindent{Now the agent (of context) Y holds itself as a PPA.}\<close>
axiomatization where AgentY_Y_PPA: "\<lfloor>PPA (Agent Y)\<rfloor>\<^sub>Y"

text\<open>\noindent{The agent Y claims a right to FWB.}\<close>
lemma AgentY_Y_FWB: "\<lfloor>RightTo (Agent Y) FWB\<rfloor>\<^sub>Y" using AgentY_Y_PPA PGC_weak by simp

text\<open>\noindent{The agent Y accepts X claiming a right to FWB.}\<close>
lemma AgentY_X_FWB: "\<lfloor>RightTo (Agent X) FWB\<rfloor>\<^sub>Y" using AgentY_X_PPA PGC_strong by simp

text\<open>\noindent{The agent Y accepts an (other-directed) obligation of non-interference with X's FWB.}\<close>
lemma AgentY_NonInterference_X_FWB: "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<forall>z. \<^bold>\<not>InterferesWith z (FWB (Agent X)))\<rfloor>\<^sub>Y" using AgentY_X_FWB RightTo_def by simp

text\<open>\noindent{Axiom consistency checked: Nitpick finds a two-world model (card w=2).}\<close>
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 2] oops

(*<*)
end
(*>*)