theory Big_Step_Value
imports
  Big_Step_Sterm
  "../Terms/Value"
begin

subsection \<open>Big-step semantics evaluating to @{typ value}\<close>

primrec vrule :: "vrule \<Rightarrow> bool" where
"vrule (_, rhs) \<longleftrightarrow> vwellformed rhs \<and> vclosed rhs \<and> \<not> is_Vconstr rhs"

locale vrules = constants C_info "fst |`| fset_of_list rs" for C_info and rs :: "vrule list" +
  assumes all_rules: "list_all vrule rs"
  assumes distinct: "distinct (map fst rs)"
  assumes not_shadows: "list_all (\<lambda>(_, rhs). not_shadows_vconsts rhs) rs"
  assumes vconstructor_value_rs: "vconstructor_value_rs rs"
  assumes vwelldefined_rs: "list_all (\<lambda>(_, rhs). vwelldefined rhs) rs"
begin

lemma map: "is_map (set rs)"
using distinct by (rule distinct_is_map)

end

abbreviation value_to_sterm_rules :: "vrule list \<Rightarrow> srule list" where
"value_to_sterm_rules \<equiv> map (map_prod id value_to_sterm)"

inductive (in special_constants)
  veval :: "(name \<times> value) list \<Rightarrow> (name, value) fmap \<Rightarrow> sterm \<Rightarrow> value \<Rightarrow> bool"  ("_, _/ \<turnstile>\<^sub>v/ _ \<down>/ _" [50,0,50] 50) for rs where
const: "(name, rhs) \<in> set rs \<Longrightarrow> rs, \<Gamma> \<turnstile>\<^sub>v Sconst name \<down> rhs" |
var: "fmlookup \<Gamma> name = Some val \<Longrightarrow> rs, \<Gamma> \<turnstile>\<^sub>v Svar name \<down> val" |
abs: "rs, \<Gamma> \<turnstile>\<^sub>v Sabs cs \<down> Vabs cs \<Gamma>" |
comb: "
  rs, \<Gamma> \<turnstile>\<^sub>v t \<down> Vabs cs \<Gamma>' \<Longrightarrow> rs, \<Gamma> \<turnstile>\<^sub>v u \<down> u' \<Longrightarrow>
  vfind_match cs u' = Some (env, _, rhs) \<Longrightarrow>
  rs, \<Gamma>' ++\<^sub>f env \<turnstile>\<^sub>v rhs \<down> val \<Longrightarrow>
  rs, \<Gamma> \<turnstile>\<^sub>v t $\<^sub>s u \<down> val" |
rec_comb: "
  rs, \<Gamma> \<turnstile>\<^sub>v t \<down> Vrecabs css name \<Gamma>' \<Longrightarrow>
  fmlookup css name = Some cs \<Longrightarrow>
  rs, \<Gamma> \<turnstile>\<^sub>v u \<down> u' \<Longrightarrow>
  vfind_match cs u' = Some (env, _, rhs) \<Longrightarrow>
  rs, \<Gamma>' ++\<^sub>f env \<turnstile>\<^sub>v rhs \<down> val \<Longrightarrow>
  rs, \<Gamma> \<turnstile>\<^sub>v t $\<^sub>s u \<down> val" |
constr: "
  name |\<in>| C \<Longrightarrow>
  list_all2 (veval rs \<Gamma>) ts us \<Longrightarrow>
  rs, \<Gamma> \<turnstile>\<^sub>v name $$ ts \<down> Vconstr name us"

lemma (in vrules) veval_wellformed:
  assumes "rs, \<Gamma> \<turnstile>\<^sub>v t \<down> v" "wellformed t" "wellformed_venv \<Gamma>"
  shows "vwellformed v"
using assms proof induction
  case const
  thus ?case
    using all_rules
    by (auto simp: list_all_iff)
next
  case comb
  show ?case
    apply (rule comb)
    using comb by (auto simp: list_all_iff dest: vfind_match_elem intro: vwellformed.vmatch_env)
next
  case (rec_comb \<Gamma> t css name \<Gamma>' cs u u' env pat rhs val)
  hence "(pat, rhs) \<in> set cs" "vmatch (mk_pat pat) u' = Some env"
    by (metis vfind_match_elem)+

  show ?case
    proof (rule rec_comb)
      have "wellformed t"
        using rec_comb by simp
      have "vwellformed (Vrecabs css name \<Gamma>')"
        by (rule rec_comb) fact+
      thus "wellformed rhs"
        using rec_comb \<open>(pat, rhs) \<in> set cs\<close>
        by (auto simp: list_all_iff)

      have "wellformed_venv \<Gamma>'"
        using \<open>vwellformed (Vrecabs css name \<Gamma>')\<close> by simp
      moreover have "wellformed_venv env"
        using rec_comb \<open>vmatch (mk_pat pat) u' = Some env\<close>
        by (auto intro: vwellformed.vmatch_env)
      ultimately show "wellformed_venv (\<Gamma>' ++\<^sub>f env)"
        by blast
    qed
next
  case (constr name \<Gamma> ts us)
  have "list_all vwellformed us"
    using \<open>list_all2 _ _ _\<close> \<open>wellformed (list_comb _ _)\<close>
    proof (induction ts us rule: list.rel_induct)
      case (Cons v vs u us)
      with constr show ?case
        unfolding wellformed.list_comb by auto
    qed simp
  thus ?case
    by (simp add: list_all_iff)
qed auto

  show ?case
    proof (rule comb)
      have "vclosed u'"
        using comb by (auto simp: Sterm.closed_except_simps)
      have "closed_venv env"
        by (rule vclosed.vmatch_env) fact+
      thus "closed_venv (\<Gamma>' ++\<^sub>f env)"
        using comb by (auto simp: Sterm.closed_except_simps)
    next
      have "wellformed t"
        using comb by simp
      have "vwellformed (Vabs cs \<Gamma>')"
        by (rule veval_wellformed) fact+
      thus "wellformed rhs"
        using pat by (auto simp: list_all_iff)

      have "wellformed_venv \<Gamma>'"
        using \<open>vwellformed (Vabs cs \<Gamma>')\<close> by simp
      moreover have "wellformed_venv env"
        using comb pat
        by (auto intro: vwellformed.vmatch_env veval_wellformed)
      ultimately show "wellformed_venv (\<Gamma>' ++\<^sub>f env)"
        by blast

      have "vclosed (Vabs cs \<Gamma>')"
        using comb by (auto simp: Sterm.closed_except_simps)
      hence "closed_except rhs (fmdom \<Gamma>' |\<union>| frees pat)"
        using pat by (auto simp: list_all_iff)

      moreover have "fmdom env = frees pat"
        using \<open>vwellformed (Vabs cs \<Gamma>')\<close> pat
        by (auto simp: vmatch_dom mk_pat_frees list_all_iff)

      ultimately show "closed_except rhs (fmdom (\<Gamma>' ++\<^sub>f env))"
        using \<open>vclosed (Vabs cs \<Gamma>')\<close>
        by simp
    qed
next
  case (rec_comb \<Gamma> t css name \<Gamma>' cs u u' env pat rhs val)
  hence pat: "(pat, rhs) \<in> set cs" "vmatch (mk_pat pat) u' = Some env"
    by (metis vfind_match_elem)+

  show ?case
    proof (rule rec_comb)
      have "vclosed u'"
        using rec_comb by (auto simp: Sterm.closed_except_simps)
      have "closed_venv env"
        by (rule vclosed.vmatch_env) fact+
      thus "closed_venv (\<Gamma>' ++\<^sub>f env)"
        using rec_comb by (auto simp: Sterm.closed_except_simps)
    next
      have "wellformed t"
        using rec_comb by simp
      have "vwellformed (Vrecabs css name \<Gamma>')"
        by (rule veval_wellformed) fact+
      thus "wellformed rhs"
        using pat rec_comb by (auto simp: list_all_iff)

      have "wellformed_venv \<Gamma>'"
        using \<open>vwellformed (Vrecabs css name \<Gamma>')\<close> by simp
      moreover have "wellformed_venv env"
        using rec_comb pat
        by (auto intro: vwellformed.vmatch_env veval_wellformed)
      ultimately show "wellformed_venv (\<Gamma>' ++\<^sub>f env)"
        by blast

      have "wellformed_clauses cs"
        using \<open>vwellformed (Vrecabs css name \<Gamma>')\<close> \<open>fmlookup css name = Some cs\<close>
        by auto

      have "vclosed (Vrecabs css name \<Gamma>')"
        using rec_comb by (auto simp: Sterm.closed_except_simps)
      hence "closed_except rhs (fmdom \<Gamma>' |\<union>| frees pat)"
        using rec_comb pat by (auto simp: list_all_iff)
      moreover have "fmdom env = frees pat"
        using \<open>wellformed_clauses cs\<close> pat
        by (auto simp: list_all_iff vmatch_dom mk_pat_frees)
      ultimately show "closed_except rhs (fmdom (\<Gamma>' ++\<^sub>f env))"
        using \<open>vclosed (Vrecabs css name \<Gamma>')\<close>
        by simp
    qed
next
  case (constr name \<Gamma> ts us)
  have "list_all vclosed us"
    using \<open>list_all2 _ _ _\<close> \<open>closed_except (_ $$ _) _\<close> \<open>wellformed (name $$ ts)\<close>
    proof (induction ts us rule: list.rel_induct)
      case (Cons v vs u us)
      with constr show ?case
        unfolding closed.list_comb wellformed.list_comb
        by (auto simp: list_all_iff Sterm.closed_except_simps)
    qed simp
  thus ?case
    by (simp add: list_all_iff)
qed (auto simp: Sterm.closed_except_simps)

lemma (in vrules) veval_constructor_value:
  assumes "rs, \<Gamma> \<turnstile>\<^sub>v t \<down> v" "vconstructor_value_env \<Gamma>"
  shows "vconstructor_value v"
using assms proof induction
  case (comb \<Gamma> t cs \<Gamma>' u u' env pat rhs val)
  hence "(pat, rhs) \<in> set cs" "vmatch (mk_pat pat) u' = Some env"
    by (metis vfind_match_elem)+
  hence "vconstructor_value_env (\<Gamma>' ++\<^sub>f env)"
    using comb by (auto intro: vconstructor_value.vmatch_env)
  thus ?case
    using comb by auto
next
  case (constr name \<Gamma> ts us)
  hence "list_all vconstructor_value us"
    by (auto elim: list_all2_rightE)
  with constr show ?case
    by simp
next
  case const
  thus ?case
    using vconstructor_value_rs
    by (auto simp: list_all_iff vconstructor_value_rs_def)
next
  case (rec_comb \<Gamma> t css name \<Gamma>' cs u u' env pat rhs val)
  hence "(pat, rhs) \<in> set cs" "vmatch (mk_pat pat) u' = Some env"
    by (metis vfind_match_elem)+
  hence "vconstructor_value_env (\<Gamma>' ++\<^sub>f env)"
    using rec_comb by (auto intro: vconstructor_value.vmatch_env)
  thus ?case
    using rec_comb by auto
qed (auto simp: list_all_iff vconstructor_value_rs_def)

lemma (in vrules) veval_welldefined:
  assumes "rs, \<Gamma> \<turnstile>\<^sub>v t \<down> v" "fmpred (\<lambda>_. vwelldefined) \<Gamma>" "welldefined t"
  shows "vwelldefined v"
using assms proof induction
  case const
  thus ?case
    using vwelldefined_rs assms
    unfolding list_all_iff
    by (auto simp: list_all_iff)
next
  case (comb \<Gamma> t cs \<Gamma>' u u' env pat rhs val)
  hence "vwelldefined (Vabs cs \<Gamma>')"
    by auto

  show ?case
    proof (rule comb)
      have "fmpred (\<lambda>_. vwelldefined) \<Gamma>'"
        using \<open>vwelldefined (Vabs cs \<Gamma>')\<close>
        by simp
      moreover have "fmpred (\<lambda>_. vwelldefined) env"
        apply (rule vwelldefined.vmatch_env)
         apply (rule vfind_match_elem)
        using comb by auto
      ultimately show "fmpred (\<lambda>_. vwelldefined) (\<Gamma>' ++\<^sub>f env)"
        by auto
    next
      have "(pat, rhs) \<in> set cs"
        using comb by (metis vfind_match_elem)
      thus "welldefined rhs"
        using \<open>vwelldefined (Vabs cs \<Gamma>')\<close>
        by (auto simp: list_all_iff)
    qed
next
  case (rec_comb \<Gamma> t css name \<Gamma>' cs u u' env pat rhs val)
  have "(pat, rhs) \<in> set cs"
    by (rule vfind_match_elem) fact
  show ?case
    proof (rule rec_comb)
      show "fmpred (\<lambda>_. vwelldefined) (\<Gamma>' ++\<^sub>f env)"
        proof
          show "fmpred (\<lambda>_. vwelldefined) env"
            using rec_comb by (auto dest: vfind_match_elem intro: vwelldefined.vmatch_env)
        next
          show "fmpred (\<lambda>_. vwelldefined) \<Gamma>'"
            using rec_comb by auto
        qed
    next
      have "vwelldefined (Vrecabs css name \<Gamma>')"
        using rec_comb by auto

      thus "welldefined rhs"
        apply simp
        apply (elim conjE)
        apply (drule fmpredD[where m = css])
        using \<open>(pat, rhs) \<in> set cs\<close> rec_comb by (auto simp: list_all_iff)
    qed
next
  case (constr name \<Gamma> ts us)
  have "list_all vwelldefined us"
    using \<open>list_all2 _ _ _\<close> \<open>welldefined (_ $$ _)\<close>
    proof (induction ts us rule: list.rel_induct)
      case (Cons v vs u us)
      with constr show ?case
        unfolding welldefined.list_comb
        by auto
    qed simp
  with constr show ?case
    by (simp add: list_all_iff all_consts_def)
next
  case abs
  thus ?case
    unfolding welldefined_sabs by auto
qed auto

subsubsection \<open>Correctness wrt @{const constructors.seval}\<close>

context vrules begin

definition rs' :: "srule list" where
"rs' = value_to_sterm_rules rs"

lemma value_to_sterm_srules: "srules C_info rs'"
proof
  show "distinct (map fst rs')"
    unfolding rs'_def
    using distinct by auto
next
  show "list_all srule rs'"
    unfolding rs'_def list.pred_map
    apply (rule list.pred_mono_strong[OF all_rules])
    apply (auto intro: vclosed.value_to_sterm vwellformed.value_to_sterm)
    subgoal by (auto intro: vwellformed.value_to_sterm)
    subgoal by (auto intro: vclosed.value_to_sterm)
    subgoal for a b by (cases b) (auto simp: is_abs_def term_cases_def)
    done
next
  show "fdisjnt (fst |`| fset_of_list rs') C"
    using vconstructor_value_rs unfolding rs'_def vconstructor_value_rs_def
    by auto
  interpret c: constants _ "fst |`| fset_of_list rs'"
    by standard (fact | fact distinct_ctr)+
  have all_consts: "c.all_consts = all_consts"
    unfolding c.all_consts_def all_consts_def
    by (simp add: rs'_def)
  have shadows_consts: "c.shadows_consts rhs = shadows_consts rhs" for rhs :: sterm
    by (induction rhs; fastforce simp: all_consts list_ex_iff)

  have "list_all (\<lambda>(_, rhs). \<not> shadows_consts rhs) rs'"
    unfolding rs'_def
    unfolding list.pred_map map_prod_def id_def case_prod_twice list_all_iff
    apply auto
    unfolding comp_def all_consts_def
    using not_shadows
    by (fastforce simp: list_all_iff dest: not_shadows_vconsts.value_to_sterm)
  thus "list_all (\<lambda>(_, rhs). \<not> c.shadows_consts rhs) rs'"
    unfolding shadows_consts .

  have "list_all (\<lambda>(_, rhs). welldefined rhs) rs'"
    unfolding rs'_def list.pred_map
    apply (rule list.pred_mono_strong[OF vwelldefined_rs])
    subgoal for z
      apply (cases z; hypsubst_thin)
      apply simp
      apply (erule vwelldefined.value_to_sterm)
      done
    done
  moreover have "map fst rs = map fst rs'"
    unfolding rs'_def by simp
  ultimately have "list_all (\<lambda>(_, rhs). welldefined rhs) rs'"
    by simp
  thus "list_all (\<lambda>(_, rhs). c.welldefined rhs) rs'"
    unfolding all_consts .
next
  show "distinct all_constructors"
    by (fact distinct_ctr)
qed

end

text (in special_constants) \<open>
  When we evaluate @{typ sterm}s using @{const veval}, the result is a @{typ value} which possibly
  contains a closure (constructor @{const Vabs}). Such a closure is essentially a case-lambda (like
  @{const Sabs}), but with an additionally captured environment of type
  @{typ [source] "string \<rightharpoonup> value"} (which is usually called \<open>\<Gamma>'\<close>). The contained case-lambda might
  not be closed.

  The proof idea is that we can always substitute with \<open>\<Gamma>'\<close> and obtain a regular @{typ sterm} value.
  The only interesting part of the proof is the case when a case-lambda gets applied to a value,
  because in that process, a hidden environment is \<^emph>\<open>unveiled\<close>. That environment may not bear any
  relation to the active environment \<open>\<Gamma>\<close> at all. But pattern matching and substitution proceeds only
  with that hidden environment.
\<close>

context vrules begin

context begin

private lemma veval_correct0:
  assumes "rs, \<Gamma> \<turnstile>\<^sub>v t \<down> v" "wellformed t" "wellformed_venv \<Gamma>"
  assumes "closed_except t (fmdom \<Gamma>)" "closed_venv \<Gamma>"
  assumes "vconstructor_value_env \<Gamma>"
  shows "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t \<down> value_to_sterm v"
using assms proof induction
  case (constr name \<Gamma> ts us)

  have "list_all2 (seval rs' (fmmap value_to_sterm \<Gamma>)) ts (map value_to_sterm us)"
    unfolding list_all2_map2
    proof (rule list.rel_mono_strong[OF \<open>list_all2 _ _ _\<close>], elim conjE impE)
      fix t u
      assume "t \<in> set ts" "u \<in> set us"
      assume "rs, \<Gamma> \<turnstile>\<^sub>v t \<down> u"

      show "wellformed t"  "closed_except t (fmdom \<Gamma>)"
        using \<open>t \<in> set ts\<close> constr
        unfolding wellformed.list_comb closed.list_comb list_all_iff
        by auto
    qed (rule constr | assumption)+

  thus ?case
    using \<open>name |\<in>| C\<close>
    by (auto intro: seval.constr)
next
  case (comb \<Gamma> t cs \<Gamma>' u u' venv pat rhs val)

  \<comment> \<open>We first need to establish a ton of boring side-conditions.\<close>

  hence "vmatch (mk_pat pat) u' = Some venv"
    by (auto dest: vfind_match_elem)

  have "wellformed t"
    using comb by simp
  have "vwellformed (Vabs cs \<Gamma>')"
    by (rule veval_wellformed) fact+

  hence
    "list_all (linear \<circ> fst) cs"
    "wellformed_venv \<Gamma>'"
    by (auto simp: list_all_iff split_beta)

  have "rel_option match_related (vfind_match cs u') (find_match cs (value_to_sterm u'))"
    apply (rule find_match_eq)
     apply fact
    apply (rule veval_constructor_value)
     apply fact+
    done

  then obtain senv
    where "find_match cs (value_to_sterm u') = Some (senv, pat, rhs)"
      and "env_eq venv senv"
    using \<open>vfind_match _ _ = _\<close>
    by cases auto
  hence "(pat, rhs) \<in> set cs" "match pat (value_to_sterm u') = Some senv"
    by (auto dest: find_match_elem)
  hence "fmdom senv = frees pat"
    by (simp add: match_dom)

  moreover have "senv = fmmap value_to_sterm venv"
    using \<open>env_eq venv senv\<close>
    by (rule env_eq_eq)

  ultimately have "fmdom venv = frees pat"
    by simp

  have "closed_except t (fmdom \<Gamma>)" "wellformed t"
    using comb by (simp add: closed_except_def)+
  have "vclosed (Vabs cs \<Gamma>')"
    by (rule veval_closed) fact+

  have "vconstructor_value (Vabs cs \<Gamma>')" "vconstructor_value u'"
    by (rule veval_constructor_value; fact)+
  hence "vconstructor_value_env \<Gamma>'"
    by simp
  have "vconstructor_value_env venv"
    by (rule vconstructor_value.vmatch_env) fact+

  have "wellformed u"
    using comb by simp
  have "vwellformed u'"
    by (rule veval_wellformed) fact+
  have "wellformed_venv venv"
    by (rule vwellformed.vmatch_env) fact+

  have "closed_except u (fmdom \<Gamma>)"
    using comb by (simp add: closed_except_def)
  have "vclosed u'"
    by (rule veval_closed) fact+
  have "closed_venv venv"
    by (rule vclosed.vmatch_env) fact+

  have "closed_venv \<Gamma>'"
    using \<open>vclosed (Vabs cs \<Gamma>')\<close> by simp

  let ?subst = "\<lambda>pat t. subst t (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>'))"
  txt \<open>
    \<^enum> We know the following (induction hypothesis):
      @{term "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s rhs \<down> value_to_sterm val"}

    \<^enum> ... first, we can deduce using @{thm [source] ssubst_eval} that this is equivalent to
      substituting \<open>rhs\<close> first:
      @{term "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"}

    \<^enum> ... second, we can replace the hidden environment \<open>\<Gamma>'\<close> by the active environment \<open>\<Gamma>\<close>
      using @{thm [source] seval_agree_eq} because it does not contain useful information at this
      point:
      @{term "rs', fmmap value_to_sterm (\<Gamma> ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"}

    \<^enum> ... finally we can apply a step in the original semantics and arrive at the conclusion:
      @{term "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t $\<^sub>s u \<down> value_to_sterm val"}
  \<close>

  have "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
    proof (rule ssubst_eval)
      show "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s rhs \<down> value_to_sterm val"
        proof (rule comb)
          have "linear pat" "closed_except rhs (fmdom \<Gamma>' |\<union>| frees pat)"
            using \<open>(pat, rhs) \<in> set cs\<close> \<open>vwellformed (Vabs cs \<Gamma>')\<close> \<open>vclosed (Vabs cs \<Gamma>')\<close>
            by (auto simp: list_all_iff)
          hence "closed_except rhs (fmdom \<Gamma>' |\<union>| fmdom venv)"
            using \<open>vmatch (mk_pat pat) u' = Some venv\<close>
            by (auto simp: mk_pat_frees vmatch_dom)
          thus "closed_except rhs (fmdom (\<Gamma>' ++\<^sub>f venv))"
            by simp
        next
          show "wellformed_venv (\<Gamma>' ++\<^sub>f venv)"
            using \<open>wellformed_venv \<Gamma>'\<close> \<open>wellformed_venv venv\<close>
            by blast
        next
          show "closed_venv (\<Gamma>' ++\<^sub>f venv)"
            using \<open>closed_venv \<Gamma>'\<close> \<open>closed_venv venv\<close>
            by blast
        next
          show "vconstructor_value_env (\<Gamma>' ++\<^sub>f venv)"
            using \<open>vconstructor_value_env \<Gamma>'\<close> \<open>vconstructor_value_env venv\<close>
            by blast
        next
          show "wellformed rhs"
            using \<open>(pat, rhs) \<in> set cs\<close> \<open>vwellformed (Vabs cs \<Gamma>')\<close>
            by (fastforce simp: list_all_iff)
        qed
    next
      have "fmdrop_fset (fmdom venv) \<Gamma>' \<subseteq>\<^sub>f \<Gamma>' ++\<^sub>f venv"
        including fmap.lifting fset.lifting
        by transfer'
           (auto simp: map_drop_set_def map_filter_def map_le_def map_add_def split: if_splits)
      thus "fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>') \<subseteq>\<^sub>f fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv)"
        unfolding \<open>fmdom venv = frees pat\<close>
        by (metis fmdrop_fset_fmmap fmmap_subset)
    next
      show "closed_env (fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv))"
        apply auto
        apply rule
         apply (rule vclosed.value_to_sterm_env, fact)+
        done
    next
      show "value_env (fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv))"
        apply auto
        apply rule
         apply (rule vconstructor_value.value_to_sterm_env, fact)+
        done
    qed

  show ?case
    proof (rule seval.comb)
      have "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t \<down> value_to_sterm (Vabs cs \<Gamma>')"
        using comb by (auto simp: closed_except_def)
      thus "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t \<down> Sabs (map (\<lambda>(pat, t). (pat, ?subst pat t)) cs)"
        by simp
    next
      show "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s u \<down> value_to_sterm u'"
        using comb by (simp add: closed_except_def)
    next
      show "rs', fmmap value_to_sterm \<Gamma> ++\<^sub>f senv \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
        proof (rule seval_agree_eq)
          show "rs', fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
            using \<open>rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val\<close> by simp
        next
          show "fmrestrict_fset (frees pat) (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv) =
                fmrestrict_fset (frees pat) (fmmap value_to_sterm \<Gamma> ++\<^sub>f senv)"
            unfolding \<open>senv = _\<close>
            apply (subst \<open>fmdom venv = frees pat\<close>[symmetric])+
            apply (subst fmdom_map[symmetric])
            apply (subst fmadd_restrict_right_dom)
            apply (subst fmdom_map[symmetric])
            apply (subst fmadd_restrict_right_dom)
            apply simp
            done
        next
          have "closed (value_to_sterm (Vabs cs \<Gamma>'))"
            using \<open>vclosed (Vabs cs \<Gamma>')\<close>
            by (rule vclosed.value_to_sterm)
          thus "closed_except (subst rhs (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>'))) (frees pat)"
            using \<open>(pat, rhs) \<in> set cs\<close>
            by (auto simp: Sterm.closed_except_simps list_all_iff)
        next
          show "closed_env (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv)"
            using \<open>closed_venv \<Gamma>'\<close> \<open>closed_venv venv\<close>
            by (auto intro: vclosed.value_to_sterm_env)
        next
          show "frees pat |\<subseteq>| fmdom (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv)"
            using \<open>fmdom venv = frees pat\<close>
            by fastforce
        next
          show "closed_srules rs'"
            using all_rules
            unfolding rs'_def list_all_iff
            by (fastforce intro: vclosed.value_to_sterm)
        qed
    next
      show "find_match (map (\<lambda>(pat, t). (pat, ?subst pat t)) cs) (value_to_sterm u') = Some (senv, pat, ?subst pat rhs)"
        using \<open>find_match _ _ = _\<close>
        by (auto simp: find_match_map)
    qed
next
  \<comment> \<open>Basically a verbatim copy from the \<open>comb\<close> case\<close>

  case (rec_comb \<Gamma> t css name \<Gamma>' cs u u' venv pat rhs val)

  hence "vmatch (mk_pat pat) u' = Some venv"
    by (auto dest: vfind_match_elem)

  have "cs = the (fmlookup css name)"
    using rec_comb by simp

  have "wellformed t"
    using rec_comb by simp
  have "vwellformed (Vrecabs css name \<Gamma>')"
    by (rule veval_wellformed) fact+
  hence "vwellformed (Vabs cs \<Gamma>')" \<comment> \<open>convenient hack: @{term cs} is not really part of a @{term Vabs}\<close>
    using rec_comb by auto

  hence
    "list_all (linear \<circ> fst) cs"
    "wellformed_venv \<Gamma>'"
    by (auto simp: list_all_iff split_beta)

  have "rel_option match_related (vfind_match cs u') (find_match cs (value_to_sterm u'))"
    apply (rule find_match_eq)
     apply fact
    apply (rule veval_constructor_value)
     apply fact+
    done

  then obtain senv
    where "find_match cs (value_to_sterm u') = Some (senv, pat, rhs)"
      and "env_eq venv senv"
    using \<open>vfind_match _ _ = _\<close>
    by cases auto
  hence "(pat, rhs) \<in> set cs" "match pat (value_to_sterm u') = Some senv"
    by (auto dest: find_match_elem)
  hence "fmdom senv = frees pat"
    by (simp add: match_dom)

  moreover have "senv = fmmap value_to_sterm venv"
    using \<open>env_eq venv senv\<close>
    by (rule env_eq_eq)

  ultimately have "fmdom venv = frees pat"
    by simp

  have "closed_except t (fmdom \<Gamma>)" "wellformed t"
    using rec_comb by (simp add: closed_except_def)+
  have "vclosed (Vrecabs css name \<Gamma>')"
    by (rule veval_closed) fact+
  hence "vclosed (Vabs cs \<Gamma>')"
    using rec_comb by auto

  have "vconstructor_value u'"
    by (rule veval_constructor_value) fact+
  have "vconstructor_value (Vrecabs css name \<Gamma>')"
    by (rule veval_constructor_value) fact+
  hence "vconstructor_value_env \<Gamma>'"
    by simp
  have "vconstructor_value_env venv"
    by (rule vconstructor_value.vmatch_env) fact+

  have "wellformed u"
    using rec_comb by simp
  have "vwellformed u'"
    by (rule veval_wellformed) fact+
  have "wellformed_venv venv"
    by (rule vwellformed.vmatch_env) fact+

  have "closed_except u (fmdom \<Gamma>)"
    using rec_comb by (simp add: closed_except_def)
  have "vclosed u'"
    by (rule veval_closed) fact+
  have "closed_venv venv"
    by (rule vclosed.vmatch_env) fact+

  have "closed_venv \<Gamma>'"
    using \<open>vclosed (Vabs cs \<Gamma>')\<close> by simp

  let ?subst = "\<lambda>pat t. subst t (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>'))"
  have "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
    proof (rule ssubst_eval)
      show "rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s rhs \<down> value_to_sterm val"
        proof (rule rec_comb)
          have "linear pat" "closed_except rhs (fmdom \<Gamma>' |\<union>| frees pat)"
            using \<open>(pat, rhs) \<in> set cs\<close> \<open>vwellformed (Vabs cs \<Gamma>')\<close> \<open>vclosed (Vabs cs \<Gamma>')\<close>
            by (auto simp: list_all_iff)
          hence "closed_except rhs (fmdom \<Gamma>' |\<union>| fmdom venv)"
            using \<open>vmatch (mk_pat pat) u' = Some venv\<close>
            by (auto simp: mk_pat_frees vmatch_dom)
          thus "closed_except rhs (fmdom (\<Gamma>' ++\<^sub>f venv))"
            by simp
        next
          show "wellformed_venv (\<Gamma>' ++\<^sub>f venv)"
            using \<open>wellformed_venv \<Gamma>'\<close> \<open>wellformed_venv venv\<close>
            by blast
        next
          show "closed_venv (\<Gamma>' ++\<^sub>f venv)"
            using \<open>closed_venv \<Gamma>'\<close> \<open>closed_venv venv\<close>
            by blast
        next
          show "vconstructor_value_env (\<Gamma>' ++\<^sub>f venv)"
            using \<open>vconstructor_value_env \<Gamma>'\<close> \<open>vconstructor_value_env venv\<close>
            by blast
        next
          show "wellformed rhs"
            using \<open>(pat, rhs) \<in> set cs\<close> \<open>vwellformed (Vabs cs \<Gamma>')\<close>
            by (fastforce simp: list_all_iff)
        qed
    next
      have "fmdrop_fset (fmdom venv) \<Gamma>' \<subseteq>\<^sub>f \<Gamma>' ++\<^sub>f venv"
        including fmap.lifting fset.lifting
        by transfer'
           (auto simp: map_drop_set_def map_filter_def map_le_def map_add_def split: if_splits)
      thus "fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>') \<subseteq>\<^sub>f fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv)"
        unfolding \<open>fmdom venv = frees pat\<close>
        by (metis fmdrop_fset_fmmap fmmap_subset)
    next
      show "closed_env (fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv))"
        apply auto
        apply rule
         apply (rule vclosed.value_to_sterm_env, fact)+
        done
    next
      show "value_env (fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv))"
        apply auto
        apply rule
         apply (rule vconstructor_value.value_to_sterm_env, fact)+
        done
    qed

  show ?case
    proof (rule seval.comb)
      have "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t \<down> value_to_sterm (Vrecabs css name \<Gamma>')"
        using rec_comb by (auto simp: closed_except_def)
      thus "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s t \<down> Sabs (map (\<lambda>(pat, t). (pat, ?subst pat t)) cs)"
        unfolding \<open>cs = _\<close> by simp
    next
      show "rs', fmmap value_to_sterm \<Gamma> \<turnstile>\<^sub>s u \<down> value_to_sterm u'"
        using rec_comb by (simp add: closed_except_def)
    next
      show "rs', fmmap value_to_sterm \<Gamma> ++\<^sub>f senv \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
        proof (rule seval_agree_eq)
          show "rs', fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val"
            using \<open>rs', fmmap value_to_sterm (\<Gamma>' ++\<^sub>f venv) \<turnstile>\<^sub>s ?subst pat rhs \<down> value_to_sterm val\<close> by simp
        next
          show "fmrestrict_fset (frees pat) (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv) =
                fmrestrict_fset (frees pat) (fmmap value_to_sterm \<Gamma> ++\<^sub>f senv)"
            unfolding \<open>senv = _\<close>
            apply (subst \<open>fmdom venv = frees pat\<close>[symmetric])+
            apply (subst fmdom_map[symmetric])
            apply (subst fmadd_restrict_right_dom)
            apply (subst fmdom_map[symmetric])
            apply (subst fmadd_restrict_right_dom)
            apply simp
            done
        next
          have "closed (value_to_sterm (Vabs cs \<Gamma>'))"
            using \<open>vclosed (Vabs cs \<Gamma>')\<close>
            by (rule vclosed.value_to_sterm)
          thus "closed_except (subst rhs (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>'))) (frees pat)"
            using \<open>(pat, rhs) \<in> set cs\<close>
            by (auto simp: Sterm.closed_except_simps list_all_iff)
        next
          show "closed_env (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv)"
            using \<open>closed_venv \<Gamma>'\<close> \<open>closed_venv venv\<close>
            by (auto intro: vclosed.value_to_sterm_env)
        next
          show "frees pat |\<subseteq>| fmdom (fmmap value_to_sterm \<Gamma>' ++\<^sub>f fmmap value_to_sterm venv)"
            using \<open>fmdom venv = frees pat\<close>
            by fastforce
        next
          show "closed_srules rs'"
            using all_rules
            unfolding rs'_def list_all_iff
            by (fastforce intro: vclosed.value_to_sterm)
        qed
    next
      show "find_match (map (\<lambda>(pat, t). (pat, ?subst pat t)) cs) (value_to_sterm u') = Some (senv, pat, ?subst pat rhs)"
        using \<open>find_match _ _ = _\<close>
        by (auto simp: find_match_map)
    qed
next
  case (const name rhs \<Gamma>)
  show ?case
    apply (rule seval.const)
    unfolding rs'_def
    using \<open>(name, rhs) \<in> _\<close> by force
next
  case abs
  show ?case
    by (auto simp del: fmdrop_fset_fmmap intro: seval.abs)
qed (auto intro: seval.var seval.abs)

lemma veval_correct:
  assumes "rs, fmempty \<turnstile>\<^sub>v t \<down> v" "wellformed t" "closed t"
  shows "rs', fmempty \<turnstile>\<^sub>s t \<down> value_to_sterm v"
proof -
  have "rs', fmmap value_to_sterm fmempty \<turnstile>\<^sub>s t \<down> value_to_sterm v"
    using assms
    by (auto intro: veval_correct0 simp del: fmmap_empty)
  thus ?thesis
    by simp
qed

end end

end


(*
    File:        FinBndEx.thy
    Time-stamp:  <2015-12-20T11:46:36Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory FinBndEx imports FinBnd begin

definition h_nat :: "i=>i" where
"h_nat(X) == {0} Un {succ(x). x: X}"

definition h_tn :: "i=>i" where
"h_tn(X) == if(nat: X | X = nat, succ(nat), h_nat(X))"

lemma subset_consE:
  assumes major: "x <= cons(a, B)"
  and prem1: "a: x ==> R"
  and prem2: "x <= B ==> R"
  shows "R"
apply (rule excluded_middle [THEN disjE])
apply (erule_tac [2] prem1)
apply (rule prem2)
apply (rule subsetI)
apply (frule major [THEN subsetD])
apply (erule consE)
apply hypsubst
apply (erule notE)
apply assumption+
done

lemma subset_succE:
  "[| x <= succ(n); n: x ==> R; x <= n ==> R |] ==> R"
apply (unfold succ_def)
apply (erule subset_consE)
apply blast+
done

lemma succ_self_neq:
  "succ(n) = n ==> P"
apply (unfold succ_def)
apply (rule mem_irrefl)
apply (erule equalityD1 [THEN subsetD])
apply (rule consI1)
done

lemma h_nat_bnd_mono:
  "bnd_mono(Inf, h_nat)"
apply (unfold bnd_mono_def h_nat_def)
apply (rule nat_bnd_mono [unfolded bnd_mono_def])
done

lemma h_nat_lfp:
    "nat = lfp(Inf, h_nat)"
apply (unfold lfp_def h_nat_def nat_def)
apply (rule refl)
done

lemma h_tn_bnd_mono:
    "bnd_mono(succ(nat), h_tn)"
apply (rule bnd_monoI)
apply (unfold h_tn_def)
apply (rule if_P [THEN ssubst])
apply (rule succI1 [THEN disjI1])
apply (rule subset_refl)
apply (rule_tac P1="%x. (if nat: W | W = nat then succ(nat) else h_nat(W)) <= x"
    in split_if [THEN iffD2])
apply (rule conjI)
apply (rule impI)
apply (rule_tac P1="%x. x <= succ(nat)"
    in split_if [THEN iffD2])
apply (rule conjI)
apply (rule subset_refl [THEN impI])
apply (rule impI)
apply (erule subset_succE)
apply (erule notE)
apply (erule disjI1)
apply (rule subset_succI [THEN [2] subset_trans])
apply (rule h_nat_lfp [THEN ssubst])
apply (rule h_nat_bnd_mono [THEN lfp_lemma2, THEN [2] subset_trans])
apply (rule h_nat_bnd_mono [THEN bnd_monoD2])
apply (erule h_nat_lfp [THEN subst])
apply (rule lfp_subset)
apply (rule impI)
apply (rule_tac P1="%x. x<= h_nat(X)" in split_if [THEN iffD2])
apply (rule conjI)
apply (rule impI)
apply (erule notE)
apply (erule disjE)
apply (rule disjI1)
apply (erule subsetD)
apply assumption
apply hypsubst
apply (erule_tac x="X" in subset_succE)
apply (erule disjI1)
apply (rule disjI2)
apply (erule equalityI, assumption)
apply (rule impI)
apply (erule h_nat_bnd_mono [THEN bnd_monoD2])
apply (erule_tac x="X" in subset_succE)
apply (erule notE)
apply (erule disjI1)
apply (erule subset_trans)
apply (rule h_nat_lfp [THEN ssubst])
apply (rule lfp_subset)
done

lemma h_tn_lfp:
    "lfp(succ(nat), h_tn) = succ(nat)"
apply (rule h_tn_bnd_mono [THEN lfpI])
apply (unfold h_tn_def)
apply (drule_tac P1="%x. x<= X" in split_if [THEN iffD1])
apply (erule conjE)
apply (case_tac "nat:X | X = nat")
apply (drule mp, assumption, assumption)
apply (drule mp)
apply (erule subset_succE)
apply (erule notE)
apply (erule disjI1)
apply (rule notE, assumption)
apply (drule mp, assumption)
apply (rule disjI2)
apply (rule equalityI)
apply assumption
apply (rule h_nat_lfp [THEN ssubst])
apply (erule lfp_lowerbound)
apply (erule subset_trans)
apply (rule h_nat_lfp [THEN ssubst])
apply (rule lfp_subset)
apply assumption
apply (rule if_P [THEN ssubst])
apply (rule succI1 [THEN disjI1])
apply (rule subset_refl)
done

lemma FinBndEx_lemma1:
  "n: A ==> ~(A: n | n = A)"
apply (rule notI)
apply (erule disjE)
apply (erule mem_asym, assumption)
apply hypsubst
apply (erule mem_irrefl)
done

lemma FinBndEx_lemma2:
    "n: nat ==> nat_rec(n, 0, %n r. h_nat(r)) = n"
apply (unfold h_nat_def)
apply (erule nat_induct)
apply (simp_all add: nat_rec_0 nat_rec_succ)
apply (rule equalityI)
apply (rule subsetI)
apply (erule UnE)
apply (erule singletonE)
apply hypsubst
apply (rule ltD)
apply (erule nat_into_Ord [THEN Ord_0_le])
apply (erule RepFunE)
apply hypsubst
apply (rule ltD)
apply (erule ltI [THEN succ_leI])
apply (erule nat_into_Ord)
apply (rule subsetI)
apply (rename_tac v)
apply (frule_tac i="v" in ltI)
apply (erule nat_into_Ord [THEN Ord_succ])
apply (frule lt_nat_in_nat)
apply (erule nat_succI)
apply (erule_tac n="v" in natE)
apply hypsubst
apply blast
apply (rule UnI2)
apply hypsubst
apply (rule RepFunI)
apply (rule ltD)
apply (rule succ_leE)
apply (erule ltI)
apply (erule nat_into_Ord [THEN Ord_succ])
done

lemma FinBndEx_lemma3:
  "n: nat ==> nat_rec(n, 0, %x r. h_tn(r)) = nat_rec(n, 0, %x r. h_nat(r))"
apply (unfold h_tn_def)
apply (erule nat_induct)
apply (simp_all add: nat_rec_0 nat_rec_succ)
apply (simp only: FinBndEx_lemma2)
apply (rule impI)
apply (drule FinBndEx_lemma1)
apply (erule notE, assumption)
done

lemma Singleton_of_the_nat_is_an_finite_subset_of_succ_nat:
  "{nat}: Fin(lfp(succ(nat), h_tn))"
apply (rule_tac P="%x. {nat}: Fin(x)" in h_tn_lfp [THEN ssubst])
apply (rule Fin.intros)
apply (rule succI1)
apply (rule Fin.intros)
done

lemma Singleton_of_the_nat_is_not_in_the_finitely_bound_set:
  "{nat} ~: fin_bnd_set(succ(nat), h_tn)"
apply (rule notI)
apply (erule fin_bnd_setE)
apply (unfold fin_bnd_def)
apply (erule bexE)
apply (erule_tac P="{nat} <= nat_rec(n, 0, %n r. h_tn(r))"
        in rev_mp)
apply (simp add: FinBndEx_lemma2 FinBndEx_lemma3)
apply (rule notI)
apply (erule mem_asym, assumption)
done

lemma h_nat_bnd_cont:
    "bnd_cont(Inf, h_nat)"
apply (rule bnd_contI)
apply (rule_tac [2] h_nat_bnd_mono [THEN bnd_monoD1])
apply (unfold h_nat_def)
apply (rule equalityI)
prefer 2 apply blast
apply (rule subsetI)
apply (erule UnE)
apply (erule singletonE)
apply hypsubst
apply (erule not_emptyE)
apply (erule UN_I)
apply (rule singletonI [THEN UnI1])
apply (erule RepFunE)
apply (erule UnionE)
apply (erule UN_I)
apply (rule UnI2)
apply hypsubst
apply (rule RepFunI, assumption)
done

lemma nat_not_in_the_fin_bnd_set:
    "nat ~: fin_bnd_set(Inf, h_nat)"
apply (unfold fin_bnd_set_def fin_bnd_def)
apply (rule notI)
apply (erule CollectE)
apply (erule bexE)
apply (simp only: FinBndEx_lemma2)
apply (rule mem_imp_not_eq [THEN notE])
apply (rule_tac [2] equalityI)
prefer 3 apply assumption
apply assumption
apply (erule ltI [THEN leI, THEN le_imp_subset])
apply (rule Ord_nat)
done

lemma Pow_lfp_of_h_nat_is_not_equal_to_the_fin_bnd_set:
    "Pow(lfp(Inf, h_nat)) ~= fin_bnd_set(Inf, h_nat)"
apply (rule notI)
apply (rule nat_not_in_the_fin_bnd_set [THEN notE])
apply (erule subst)
apply (rule PowI)
apply (rule h_nat_lfp [THEN subst])
apply (rule subset_refl)
done

end


(*  Title:      HOL/Nunchaku_Examples/Special_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples featuring Nunchaku's specialization optimization.
*)

section {* Examples Featuring Nunchaku's Specialization Optimization *}

theory Special_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, timeout = 240]

fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "f1 a b c d e = a + b + c + d + e"

lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

lemma "f1 u v w x y = f1 y x w v u"
nunchaku [timeout = 5, expect = unknown]
nunchaku [dont_specialize, timeout = 5, expect = unknown]
sorry

fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "f2 a b c d (Suc e) = a + b + c + d + e"

lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
nunchaku [timeout = 5, expect = unknown]
nunchaku [dont_specialize, timeout = 5, expect = unknown]
sorry

lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
nunchaku [expect = genuine]
nunchaku [dont_specialize, expect = genuine]
oops

lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "f3 (Suc a) b 0 d (Suc e) = a + b + d + e"
| "f3 0 b 0 d 0 = b + d"

lemma "f3 a b c d e = f3 e d c b a"
nunchaku [expect = genuine]
nunchaku [dont_specialize, expect = genuine]
oops

lemma "f3 a b c d a = f3 a d c d a"
nunchaku [expect = genuine]
nunchaku [dont_specialize, expect = genuine]
oops

lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
nunchaku [timeout = 5, expect = unknown]
nunchaku [dont_specialize, timeout = 5, expect = unknown]
sorry

lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u) \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "f4 x x = 1"
| "f4 y z = (if y = z then 1 else 0)"
by auto
termination by lexicographic_order

lemma "f4 a b = f4 b a"
nunchaku [timeout = 5, expect = unknown]
nunchaku [dont_specialize, timeout = 5, expect = unknown]
sorry

lemma "f4 a (Suc a) = f4 a a"
nunchaku [expect = genuine]
nunchaku [dont_specialize, expect = genuine]
oops

fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "f5 f (Suc a) = f a"

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}. f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nunchaku [expect = genuine]
oops

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}. f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nunchaku [expect = genuine]
oops

lemma
  "\<forall>a. g a = a \<Longrightarrow>
   \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x = f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nunchaku [expect = none]
nunchaku [dont_specialize, expect = none]
sorry

lemma
  "\<forall>a. g a = a \<Longrightarrow>
   \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x = f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nunchaku [expect = potential]
nunchaku [dont_specialize, expect = potential]
sorry

lemma
  "\<forall>a. g a = a \<Longrightarrow>
   \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
   b\<^sub>1 < b\<^sub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2) x"
nunchaku [expect = potential]
nunchaku [dont_specialize, expect = none]
sorry

lemma
  "\<forall>a. g a = a \<Longrightarrow>
   \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
   b\<^sub>1 < b\<^sub>11 \<and> f5 g x =
   f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8 + h b\<^sub>9 + h b\<^sub>10) x"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma
  "\<forall>a. g a = a \<Longrightarrow>
   \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
   b\<^sub>1 < b\<^sub>11 \<and> f5 g x =
   f5 (\<lambda>a. if b\<^sub>1 \<ge> b\<^sub>11 then a else h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8 + h b\<^sub>9 + h b\<^sub>10) x"
nunchaku [timeout = 5, expect = potential]
oops

end


theory "Example_System"
imports "./Proof_Checker"
begin
context ids begin

  section \<open>Example 2: Concrete Hybrid System\<close>

(* v \<ge> 0 \<and> A() \<ge> 0 \<longrightarrow> [v' = A, x' = v]v' \<ge> 0*)
definition SystemConcl::"('sf,'sc,'sz) sequent"
where "SystemConcl =
  ([],[
  Implies (And (Geq (Var vid1) (Const 0)) (Geq (f0 fid1) (Const 0)))
  ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (TT)]]Geq (Var vid1) (Const 0))
  ])"

definition SystemDICut :: "('sf,'sc,'sz) formula"
where "SystemDICut =
  Implies
  (Implies TT ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]]
     (Geq (Differential (Var vid1)) (Differential (Const 0)))))
  (Implies
     (Implies TT (Geq (Var vid1) (Const 0)))
     ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]](Geq (Var vid1) (Const 0))))"
(*
    (Implies (Geq (Var vid1) (Const 0))
      (Implies (And TT ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]]
                  (Geq (Differential (Var vid1)) (Differential (Const 0)))
   )) ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]](Geq (Var vid1) (Const 0)))))"
*)
definition SystemDCCut::"('sf,'sc,'sz) formula"
where "SystemDCCut =
(([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]](Geq (f0 fid1) (Const 0))) \<rightarrow>
   (([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]]((Geq (Differential (Var vid1)) (Differential (Const 0)))))
   \<leftrightarrow>
   ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]](Geq (Differential (Var vid1)) (Differential (Const 0))))))"

definition SystemVCut::"('sf,'sc,'sz) formula"
where "SystemVCut =
  Implies (Geq (f0 fid1) (Const 0)) ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]](Geq (f0 fid1) (Const 0)))"

definition SystemVCut2::"('sf,'sc,'sz) formula"
where "SystemVCut2 =
  Implies (Geq (f0 fid1) (Const 0)) ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]](Geq (f0 fid1) (Const 0)))"

definition SystemDECut::"('sf,'sc,'sz) formula"
where "SystemDECut = (([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]] ((Geq (Differential (Var vid1)) (Differential (Const 0))))) \<leftrightarrow>
 ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]]
    [[DiffAssign vid1 (f0 fid1)]](Geq (Differential (Var vid1)) (Differential (Const 0)))))"

definition SystemKCut::"('sf,'sc,'sz) formula"
where "SystemKCut =
  (Implies ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]]
                (Implies ((And TT (Geq (f0 fid1) (Const 0)))) ([[DiffAssign vid1 (f0 fid1)]](Geq (Differential (Var vid1)) (Differential (Const 0))))))
      (Implies ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]] ((And TT (Geq (f0 fid1) (Const 0)))))
               ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]] ([[DiffAssign vid1 (f0 fid1)]](Geq (Differential (Var vid1)) (Differential (Const 0)))))))"

definition SystemEquivCut::"('sf,'sc,'sz) formula"
where "SystemEquivCut =
  (Equiv (Implies ((And TT (Geq (f0 fid1) (Const 0)))) ([[DiffAssign vid1 (f0 fid1)]](Geq (Differential (Var vid1)) (Differential (Const 0)))))
         (Implies ((And TT (Geq (f0 fid1) (Const 0)))) ([[DiffAssign vid1 (f0 fid1)]](Geq (DiffVar vid1) (Const 0)))))"

definition SystemDiffAssignCut::"('sf,'sc,'sz) formula"
where "SystemDiffAssignCut =
  (([[DiffAssign vid1  ($f fid1 empty)]] (Geq (DiffVar vid1) (Const 0)))
\<leftrightarrow> (Geq ($f fid1 empty) (Const 0)))"

definition SystemCEFml1::"('sf,'sc,'sz) formula"
where "SystemCEFml1 = Geq (Differential (Var vid1)) (Differential (Const 0))"

definition SystemCEFml2::"('sf,'sc,'sz) formula"
where "SystemCEFml2 = Geq (DiffVar vid1) (Const 0)"

(*
definition diff_const_axiom :: "formula"
  where [axiom_defs]:"diff_const_axiom \<equiv> Equals (Differential ($f fid1 empty)) (Const 0)"

definition diff_var_axiom :: "formula"
  where [axiom_defs]:"diff_var_axiom \<equiv> Equals (Differential (Var vid1)) (DiffVar vid1)"*)

definition CQ1Concl::"('sf,'sc,'sz) formula"
where "CQ1Concl = (Geq (Differential (Var vid1)) (Differential (Const 0)) \<leftrightarrow> Geq (DiffVar vid1) (Differential (Const 0)))"

definition CQ2Concl::"('sf,'sc,'sz) formula"
where "CQ2Concl = (Geq (DiffVar vid1) (Differential (Const 0)) \<leftrightarrow> Geq ($' vid1) (Const 0))"

definition CEReq::"('sf,'sc,'sz) formula"
where "CEReq = (Geq (Differential (trm.Var vid1)) (Differential (Const 0)) \<leftrightarrow> Geq ($' vid1) (Const 0))"

definition CQRightSubst::"('sf,'sc,'sz) subst"
where "CQRightSubst =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>p. (if p = vid1 then (Some (Geq (DiffVar vid1) (Function  (Inr vid1)  empty))) else None)),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition CQLeftSubst::"('sf,'sc,'sz) subst"
where "CQLeftSubst =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>p. (if p = vid1 then (Some (Geq  (Function  (Inr vid1)  empty) (Differential (Const 0)))) else None)),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition CEProof::"('sf,'sc,'sz) pf"
where "CEProof = (([],[CEReq]), [
  (0, Cut CQ1Concl)
 ,(0, Cut CQ2Concl)
 ,(1, Rrule CohideRR 0)
 ,(Suc (Suc 0), CQ (Differential (Const 0)) (Const 0) CQRightSubst)
 ,(1, Rrule CohideRR 0)
 ,(1, CQ (Differential (Var vid1)) (DiffVar vid1) CQLeftSubst)
 ,(0, Rrule EquivR 0)
 ,(0, Lrule EquivForwardL 1)
 ,(Suc (Suc 0), Lrule EquivForwardL 1)
 ,(Suc (Suc (Suc 0)), CloseId 0 0)
 ,(Suc (Suc 0), CloseId 0 0)
 ,(Suc 0, CloseId 0 0)
 ,(0, Lrule EquivBackwardL (Suc (Suc 0)))
 ,(0, CloseId 0 0)
 ,(0, Lrule EquivBackwardL (Suc 0))
 ,(0, CloseId 0 0)
 ,(0, CloseId 0 0)
 ])"

lemma CE_result_correct:"proof_result CEProof = ([],([],[CEReq]))"
  unfolding CEProof_def CEReq_def CQ1Concl_def  CQ2Concl_def Implies_def Or_def f0_def TT_def Equiv_def Box_def CQRightSubst_def
  by (auto simp add: id_simps)

definition DiffConstSubst::"('sf,'sc,'sz) subst"
where "DiffConstSubst = \<lparr>
    SFunctions = (\<lambda>f. (if f = fid1 then (Some (Const 0)) else None)),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition DiffConstProof::"('sf,'sc,'sz) pf"
where "DiffConstProof = (([],[(Equals (Differential (Const 0)) (Const 0))]), [
  (0, AxSubst AdConst DiffConstSubst)])"

lemma diffconst_result_correct:"proof_result DiffConstProof = ([], ([],[Equals (Differential (Const 0)) (Const 0)]))"
  by(auto simp add: prover DiffConstProof_def)

lemma diffconst_sound_lemma:"sound (proof_result DiffConstProof)"
  apply(rule proof_sound)
  unfolding DiffConstProof_def
  by (auto simp add: prover DiffConstProof_def DiffConstSubst_def Equals_def empty_def TUadmit_def)

lemma valid_of_sound:"sound ([], ([],[\<phi>])) \<Longrightarrow> valid \<phi>"
  unfolding valid_def sound_def TT_def FF_def
  apply (auto simp add: TT_def FF_def Or_def)
  subgoal for I a b
    apply(erule allE[where x=I])
    by(auto)
  done

lemma almost_diff_const_sound:"sound ([], ([], [Equals (Differential (Const 0)) (Const 0)]))"
  using diffconst_result_correct diffconst_sound_lemma by simp

lemma almost_diff_const:"valid (Equals (Differential (Const 0)) (Const 0))"
  using almost_diff_const_sound valid_of_sound by auto

(* Note: this is just unpacking the definition: the axiom is defined as literally this formula *)
lemma almost_diff_var:"valid (Equals (Differential (trm.Var vid1)) ($' vid1))"
  using diff_var_axiom_valid unfolding diff_var_axiom_def by auto

lemma CESound_lemma:"sound (proof_result CEProof)"
  apply(rule proof_sound)
  unfolding CEProof_def CEReq_def CQ1Concl_def CQ2Concl_def Equiv_def CQRightSubst_def diff_const_axiom_valid diff_var_axiom_valid empty_def Or_def expand_singleton
  diff_var_axiom_def
  by (auto simp add: prover CEProof_def CEReq_def CQ1Concl_def CQ2Concl_def Equiv_def
    CQRightSubst_def diff_const_axiom_valid diff_var_axiom_valid empty_def Or_def expand_singleton
    TUadmit_def NTUadmit_def almost_diff_const CQLeftSubst_def almost_diff_var)

lemma sound_to_valid:"sound ([], ([], [\<phi>])) \<Longrightarrow> valid \<phi>"
  unfolding  valid_def apply auto
  apply(drule soundD_mem)
  by (auto simp add: member_rec(2))

lemma CE1pre:"sound ([], ([], [CEReq]))"
  using CE_result_correct CESound_lemma
  by simp

lemma CE1pre_valid:"valid CEReq"
  by (rule sound_to_valid[OF CE1pre])

lemma CE1pre_valid2:"valid (! (! (Geq (Differential (trm.Var vid1)) (Differential (Const 0)) && Geq ($' vid1) (Const 0)) &&
              ! (! (Geq (Differential (trm.Var vid1)) (Differential (Const 0))) && ! (Geq ($' vid1) (Const 0))))) "
  using CE1pre_valid unfolding CEReq_def Equiv_def Or_def by auto

definition SystemDISubst::"('sf,'sc,'sz) subst"
where "SystemDISubst =
  \<lparr> SFunctions = (\<lambda>f.
    (     if f = fid1 then Some(Function (Inr vid1) empty)
     else if f = fid2 then Some(Const 0)
     else None)),
    SPredicates = (\<lambda>p. if p = vid1 then Some TT else None),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>c. if c = vid1 then Some (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (trm.Var vid1))) else None)
  \<rparr>"

  (*
  Implies
  (Implies (Prop vid1 empty) ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Geq (Differential (f1 fid1 vid1)) (Differential (f1 fid2 vid1)))))
  (Implies
     (Implies(Prop vid1 empty) (Geq (f1 fid1 vid1) (f1 fid2 vid1)))
     ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Geq (f1 fid1 vid1) (f1 fid2 vid1))))"
*)
(*
Implies
  (Implies TT ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]]
     (Geq (Differential (Var vid1)) (Differential (Const 0)))))
  (Implies
     (Implies TT (Geq (Var vid1) (Const 0)))
     ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) TT]](Geq (Var vid1) (Const 0))))
*)

definition SystemDCSubst::"('sf,'sc,'sz) subst"
where "SystemDCSubst =
  \<lparr> SFunctions = (\<lambda>
  f.  None),
    SPredicates = (\<lambda>p.  None),
    SContexts = (\<lambda>C.
    if C = pid1 then
      Some TT
    else if C = pid2 then
      Some (Geq (Differential (Var vid1)) (Differential (Const 0)))
    else if C = pid3 then
      Some (Geq (Function fid1 empty) (Const 0))
    else
     None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>c. if c = vid1 then Some (OProd (OSing vid1 (Function fid1 empty)) (OSing vid2 (trm.Var vid1))) else None)
  \<rparr>"

definition SystemVSubst::"('sf,'sc,'sz) subst"
where "SystemVSubst =
  \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>p. if p = vid1 then Some (Geq (Function (Inl fid1) empty) (Const 0)) else None),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>a. if a = vid1 then
      Some (EvolveODE (OProd
                         (OSing vid1 (Function fid1 empty))
                         (OSing vid2 (Var vid1)))
                      (And TT (Geq (Function fid1 empty) (Const 0))))
                      else None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition SystemVSubst2::"('sf,'sc,'sz) subst"
where "SystemVSubst2 =
  \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>p. if p = vid1 then Some (Geq (Function (Inl fid1) empty) (Const 0)) else None),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>a. if a = vid1 then
      Some (EvolveODE (OProd
                         (OSing vid1 (Function fid1 empty))
                         (OSing vid2 (Var vid1)))
                      TT)
                      else None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition SystemDESubst::"('sf,'sc,'sz) subst"
where "SystemDESubst =
  \<lparr> SFunctions = (\<lambda>f. if f = fid1 then Some(Function (Inl fid1) empty) else None),
    SPredicates = (\<lambda>p. if p = vid2 then Some(And TT (Geq (Function (Inl fid1) empty) (Const 0))) else None),
    SContexts = (\<lambda>C. if C = pid1 then Some(Geq (Differential (Var vid1)) (Differential (Const 0))) else None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

lemma systemdesubst_correct:"\<exists> ODE.(([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]] ((Geq (Differential (Var vid1)) (Differential (Const 0))))) \<leftrightarrow>
 ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (And TT (Geq (f0 fid1) (Const 0)))]]
    [[DiffAssign vid1 (f0 fid1)]](Geq (Differential (Var vid1)) (Differential (Const 0)))))
    = Fsubst ((([[EvolveODE (OProd (OSing vid1 (f1 fid1 vid1)) ODE) (p1 vid2 vid1)]] (P pid1)) \<leftrightarrow>
          ([[EvolveODE ((OProd  (OSing vid1 (f1 fid1 vid1))) ODE) (p1 vid2 vid1)]]
               [[DiffAssign vid1 (f1 fid1 vid1)]]P pid1))) SystemDESubst"
  apply(rule exI[where x="OSing vid2 (trm.Var vid1)"])
  by(auto simp add: f0_def f1_def Box_def Or_def Equiv_def empty_def TT_def P_def p1_def SystemDESubst_def empty_def)

(*[{dx=, dy=x&r>=r&>=r}]r>=r&>=r->[D{x}:=]D{x}>=D{r}->
  [{dx=, dy=x&r>=r&>=r}]r>=r&>=r->
  [{dx=, dy=x&r>=r&>=r}][D{x}:=]D{x}>=D{r}
  ([[$\<alpha> vid1]]((Predicational pid1) \<rightarrow> (Predicational pid2)))
    \<rightarrow> ([[$\<alpha> vid1]]Predicational pid1) \<rightarrow> ([[$\<alpha> vid1]]Predicational pid2)
  *)
definition SystemKSubst::"('sf,'sc,'sz) subst"
where "SystemKSubst = \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. if C = pid1 then
        (Some (And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0))))
      else if C = pid2 then
        (Some ([[DiffAssign vid1 (Function fid1 empty)]](Geq (Differential (Var vid1)) (Differential (Const 0))))) else None),
    SPrograms = (\<lambda>c. if c = vid1 then Some (EvolveODE (OProd (OSing vid1 (Function fid1 empty)) (OSing vid2 (Var vid1))) (And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0)))) else None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

lemma subst_equiv_simp:"Fsubst (Equiv p q) \<sigma> = (Equiv (Fsubst p \<sigma>) (Fsubst q \<sigma>))"
  unfolding Implies_def Or_def Equiv_def by auto

lemma subst_box_simp:"Fsubst (Box p q) \<sigma> = (Box (Psubst p \<sigma>) (Fsubst q \<sigma>))"
  unfolding Box_def Or_def by auto

lemma pfsubst_box_simp:"PFsubst (Box p q) \<sigma> = (Box (PPsubst p \<sigma>) (PFsubst q \<sigma>))"
  unfolding Box_def Or_def by auto

lemma pfsubst_imp_simp:"PFsubst (Implies p q) \<sigma> = (Implies (PFsubst p \<sigma>) (PFsubst q \<sigma>))"
  unfolding Box_def Implies_def Or_def by auto

definition SystemDWSubst::"('sf,'sc,'sz) subst"
where "SystemDWSubst = \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. if C = pid1 then Some (And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0))) else None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>c. if c = vid1 then Some (OProd (OSing vid1 (Function fid1 empty)) (OSing vid2 (Var vid1))) else None)
  \<rparr>"

definition SystemCESubst::"('sf,'sc,'sz) subst"
where "SystemCESubst = \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. if C = pid1 then Some(Implies(And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0))) ([[DiffAssign vid1 (Function fid1 empty)]](Predicational (Inr ())))) else None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

lemma SystemCESubstOK:
  "step_ok
  ([([],[Equiv (Implies(And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0))) ([[DiffAssign vid1 (Function fid1 empty)]]( SystemCEFml1)))
         (Implies(And (Geq (Const 0) (Const 0)) (Geq (Function fid1 empty) (Const 0))) ([[DiffAssign vid1 (Function fid1 empty)]]( (SystemCEFml2))))
         ])],
         ([],[]))

         0
         (CE SystemCEFml1 SystemCEFml2 SystemCESubst)"
  apply(rule Step_CE)
       subgoal by(auto simp add: subst_equiv_simp subst_imp_simp subst_box_simp SystemCESubst_def SystemCEFml1_def SystemCEFml2_def pfsubst_imp_simp pfsubst_box_simp)
      subgoal using CE1pre_valid
        by (auto simp add: CEReq_def SystemCEFml1_def SystemCEFml2_def CE1pre_valid)
     subgoal unfolding SystemCEFml1_def by auto
    subgoal unfolding SystemCEFml2_def by auto
   subgoal unfolding SystemCESubst_def ssafe_def Implies_def Box_def Or_def empty_def by auto
  unfolding SystemCESubst_def Equiv_def Or_def SystemCEFml1_def SystemCEFml2_def TUadmit_def apply (auto simp add: TUadmit_def FUadmit_def Box_def Implies_def Or_def)
     unfolding PFUadmit_def by auto

(* [D{x}:=f]Dv{x}>=r<->f>=r
 [[DiffAssign vid1  ($f fid1 empty)]] (Prop vid1 (singleton (DiffVar vid1))))
      \<leftrightarrow> Prop vid1 (singleton ($f fid1 empty))*)
definition SystemDiffAssignSubst::"('sf,'sc,'sz) subst"
where "SystemDiffAssignSubst = \<lparr> SFunctions = (\<lambda>f.  None),
    SPredicates = (\<lambda>p. if p = vid1 then Some (Geq (Function (Inr vid1) empty) (Const 0)) else None),
    SContexts = (\<lambda>_. None),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

lemma SystemDICutCorrect:"SystemDICut = Fsubst DIGeqaxiom SystemDISubst"
  unfolding SystemDICut_def DIGeqaxiom_def SystemDISubst_def
  by (auto simp add: f1_def p1_def f0_def Implies_def Or_def id_simps TT_def Box_def empty_def)

(* v\<ge>0 \<and> A()\<ge>0 \<rightarrow> [{x'=v, v'=A()}]v\<ge>0 *)
definition SystemProof :: "('sf, 'sc, 'sz) pf"
where "SystemProof =
  (SystemConcl, [
  (0, Rrule ImplyR 0)
  ,(0, Lrule AndL 0)
  ,(0, Cut SystemDICut)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Lrule ImplyL 0)
  ,(Suc (Suc 0), CloseId 0 0)
  ,(Suc 0, AxSubst ADIGeq SystemDISubst) (* 8 *)
  ,(Suc 0, Rrule ImplyR 0)
(*  ,(0, CloseId 0 0)        *)
  ,(Suc 0, CloseId 1 0)
(*  ,(0, Rrule AndR 0)*)
  ,(0, Rrule ImplyR 0)
  ,(0, Cut SystemDCCut)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Lrule EquivBackwardL 0)
  ,(0, Rrule CohideR 0)
  ,(0, AxSubst ADC SystemDCSubst) (* 17 *)
  ,(0, CloseId 0 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Cut SystemVCut)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Cut SystemDECut)
  ,(0, Lrule EquivBackwardL 0)
  ,(0, Rrule CohideRR 0)
  ,(1, CloseId (Suc 1) 0) (* Last step *)
  ,(Suc 1, CloseId 0 0)
  ,(1, AxSubst AV SystemVSubst) (* 28 *)
  ,(0, Cut SystemVCut2)

  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(Suc 1, CloseId 0 0)
  ,(Suc 1, CloseId (Suc 2) 0)

  ,(Suc 1, AxSubst AV SystemVSubst2) (* 34 *)
  ,(0, Rrule CohideRR 0)
  ,(0, DEAxiomSchema (OSing vid2 (trm.Var vid1)) SystemDESubst) (* 36 *)
  ,(0, Cut SystemKCut)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, AxSubst AK SystemKSubst) (* 42 *)
  ,(0, CloseId 0 0)
  ,(0, Rrule CohideR 0)
  ,(1, AxSubst ADW SystemDWSubst) (* 45 *)
  ,(0, G)
  ,(0, Cut SystemEquivCut)
  ,(0, Lrule EquivBackwardL 0)
  ,(0, Rrule CohideR 0)
  ,(0, CloseId 0 0)
  ,(0, Rrule CohideR 0)
  ,(0, CE SystemCEFml1 SystemCEFml2 SystemCESubst) (* 52 *)
  ,(0, Rrule ImplyR 0)
  ,(0, Lrule AndL 0)
  ,(0, Cut SystemDiffAssignCut)
  ,(0, Lrule EquivBackwardL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, CloseId 0 0)
  ,(0, CloseId 1 0)
  ,(0, AxSubst Adassign SystemDiffAssignSubst) (* 60 *)
  ])"

lemma system_result_correct:"proof_result SystemProof =
  ([],
  ([],[Implies (And (Geq (Var vid1) (Const 0)) (Geq (f0 fid1) (Const 0)))
        ([[EvolveODE (OProd (OSing vid1 (f0 fid1)) (OSing vid2 (Var vid1))) (TT)]]Geq (Var vid1) (Const 0))]))"
  unfolding SystemProof_def SystemConcl_def Implies_def Or_def f0_def TT_def Equiv_def SystemDICut_def SystemDCCut_def
  proof_result.simps deriv_result.simps start_proof.simps  Box_def SystemDCSubst_def SystemVCut_def SystemDECut_def SystemKCut_def SystemEquivCut_def
  SystemDiffAssignCut_def SystemVCut2_def
    (* slow *)
  apply( simp add:  prover)
  done

lemma SystemSound_lemma:"sound (proof_result SystemProof)"
  apply(rule proof_sound)
  unfolding SystemProof_def SystemConcl_def CQ1Concl_def CQ2Concl_def Equiv_def CQRightSubst_def diff_const_axiom_valid diff_var_axiom_valid empty_def Or_def expand_singleton
  diff_var_axiom_def SystemDICut_def
  (* slow *)
  apply (auto simp add: prover CEProof_def CEReq_def CQ1Concl_def CQ2Concl_def Equiv_def
    CQRightSubst_def diff_const_axiom_valid diff_var_axiom_valid empty_def Or_def expand_singleton
    TUadmit_def NTUadmit_def almost_diff_const CQLeftSubst_def almost_diff_var f0_def TT_def SystemDISubst_def f1_def p1_def SystemDCCut_def SystemDCSubst_def
    SystemVCut_def SystemDECut_def SystemVSubst_def
    SystemVCut2_def SystemVSubst2_def  SystemDESubst_def P_def SystemKCut_def  SystemKSubst_def SystemDWSubst_def SystemEquivCut_def
    SystemCESubst_def SystemCEFml1_def SystemCEFml2_def CE1pre_valid2 SystemDiffAssignCut_def SystemDiffAssignSubst_def)
  done

lemma system_sound:"sound ([], SystemConcl)"
  using SystemSound_lemma system_result_correct unfolding SystemConcl_def by auto

end end


theory segmentList
imports segment
begin

(*additional lemmas*)
lemma distinctElem : "L \<noteq> [] \<and> distinct L \<Longrightarrow> i < (size L - 1) \<Longrightarrow> (L!i) \<noteq> (L! Suc i)"
  by (auto simp add: distinct_conv_nth)
lemma intersectNext: "length L \<ge> 1 \<Longrightarrow> \<not> intersect b (hd L) A B \<Longrightarrow>
  intersect ((b # L) ! k) ((b # L) ! Suc k) A B \<Longrightarrow> intersect (L ! (k - 1)) (L ! (Suc k - 1)) A B"
  by (cases "k = 0", simp, metis Suc_n_not_le_n hd_conv_nth length_0_conv, auto)
lemma inInsort : "a \<in> set (insort_insert x xs) \<longleftrightarrow> a \<in> set (xs) \<or> a = x"
  by (auto simp add: linorder_class.set_insort_insert)
theorem sortedKey : "sorted (map f (x # xs)) = (sorted (map f xs) \<and> (\<forall> y \<in> set xs. f x \<le> f y))"
  by (auto simp add: linorder_class.sorted_Cons)
lemma distinctCount: "distinct L \<Longrightarrow> List.count L a \<le> 1"
  by (induct L, auto)
lemma countNotIn[dest]: "a \<in> set L \<Longrightarrow> List.count L a = 0 \<Longrightarrow> False"
  apply (induct L, auto)
by (meson add_is_0)
lemma countOne_distinct1: "List.count L a > 1 \<Longrightarrow> \<not>distinct L"
  apply (induct L, auto)
by (metis (full_types) Suc_eq_plus1 count_notin less_not_refl2)
lemma countOne_distinct: "\<forall> a. List.count L a \<le> 1 \<Longrightarrow> distinct L"
  apply (induct L, simp)
  apply (subgoal_tac "List.count L a = 0")
  apply (auto)
  apply (metis (full_types) le_0_eq le_Suc_eq)
by (metis (full_types) Suc_eq_plus1 Suc_le_mono le_0_eq)
theorem countDinstinctEq: "(\<forall> a. List.count L a \<le> 1) = distinct L"
  by (meson countOne_distinct distinctCount)

(*connected edges, with more than 2 corners.
every corner is found only one time. So therefore has only 2 neighbors*)
definition pointList :: "point2d list \<Rightarrow> bool" where
"pointList L \<equiv> (size L \<ge> 3 \<and> distinct L)"
lemma pointListNotEmpty[dest]: "pointList [] \<Longrightarrow> False" by (simp add: pointList_def)
lemma pointListRev[simp] : "pointList L \<Longrightarrow> pointList (rev L)" by (simp add: pointList_def)
(*List with pointList's*)
definition pointLists :: "(point2d list) list \<Rightarrow> bool" where
  "pointLists PL \<equiv> length PL > 0 \<and> (\<forall>  i < length PL. pointList (PL!i))"
lemma pointListsEmpty[dest]: "pointLists ([] # PL) \<Longrightarrow> False"
  by (auto simp add: pointLists_def pointList_def)
lemma pointListsSimp : "(pointList A \<and> pointList B) \<longleftrightarrow> pointLists [A,B]"
  by (auto simp add: pointLists_def, case_tac i, auto)
lemma pointListsSimp1 : "pointLists [A] = pointList A" by(simp add: pointLists_def)
(*jedes Element ist eine pointList*)
lemma pointListsSimp2 [simp]: "i < length PL \<Longrightarrow> pointLists PL \<Longrightarrow> pointList (PL!i)"
  by (auto simp add: pointLists_def)

(*none of the corners can be repeated*)
lemma distVertex : "pointList L \<Longrightarrow> i < size L \<Longrightarrow> k < size L \<Longrightarrow> k \<noteq> i
  \<Longrightarrow> pointsEqual (L ! i) (L ! k) \<Longrightarrow> False"
  by (metis nth_eq_iff_index_eq pointList_def pointsEqual1)
(*none of the edges can be repeated*)
lemma distEdge : "pointList L \<Longrightarrow> a < size L \<Longrightarrow> b < size L \<Longrightarrow> c < size L \<Longrightarrow> d < size L \<Longrightarrow>
   a \<noteq> c \<and> a \<noteq> b \<and> c \<noteq> d \<Longrightarrow> segment_Same (L!a) (L!b) (L!c) (L!d) \<Longrightarrow> False"
  apply (subgoal_tac "segment (L!a) (L!b) \<and> segment (L!c) (L!d)", auto)
by (auto simp add: segment_Same_def distVertex segment_def nth_eq_iff_index_eq pointList_def)
lemma poinListSame: "pointList P \<Longrightarrow> i < length P \<Longrightarrow> k < length P \<Longrightarrow> P!i = P!k \<longleftrightarrow> i = k"
  apply (auto)
by (simp add: nth_eq_iff_index_eq pointList_def)

(*there is no point in the point list, with the same xCoordinate*)
definition uniqueXCoord :: "point2d list \<Rightarrow> bool" where
  "uniqueXCoord L \<equiv> \<forall> a < length L. \<forall> b < length L. a \<noteq> b \<longrightarrow> xCoord (L!a) \<noteq> xCoord (L!b)"
lemma uniqueXCoordEmtyp[simp]: "uniqueXCoord []" by(simp add: uniqueXCoord_def)
lemma uniqueXCoordOne[simp]: "uniqueXCoord [x]" by(simp add: uniqueXCoord_def)
lemma pointsUniqueXCoord: "leftFrom A B \<Longrightarrow> uniqueXCoord[A,B]"
  by (simp add: less_2_cases nth_Cons' uniqueXCoord_def leftFrom_def)

(*kein elemet kommt doppelt vor*)
lemma uniqueX_notIn[dest]: "uniqueXCoord (a # L) \<Longrightarrow> a \<in> set L \<Longrightarrow> False"
  by (metis Suc_mono in_set_conv_nth length_Cons nat.distinct(1) nth_Cons_0 nth_Cons_Suc
    uniqueXCoord_def zero_less_Suc)
(*uniqueXCoord List is a distinct List*)
lemma uniqueXCoordToDistinct: "uniqueXCoord L \<Longrightarrow> distinct L"
  apply (induct L, auto)
by (metis Suc_mono diff_Suc_1 length_Cons list.sel(3) nth_tl uniqueXCoord_def)
lemma uniqueXNotDouble: "uniqueXCoord L \<Longrightarrow> List.count L a \<le> 1"
by (meson countDinstinctEq uniqueXCoordToDistinct)

(*uniqueXCoord List after remove of elements is still a uniqueXCoord List*)
lemma uniqueXCoordAppend[intro]: "uniqueXCoord (a # L) \<longrightarrow> uniqueXCoord L"
  by (metis Suc_mono diff_Suc_1 length_Cons list.sel(3) nth_tl uniqueXCoord_def)
lemma uniqueXCoordEq: "\<forall> a < length L. xCoord (L!a) \<noteq> xCoord b \<Longrightarrow>
  uniqueXCoord (b # L) = uniqueXCoord L"
  apply (safe, simp add: uniqueXCoordAppend)
  apply (auto simp add: uniqueXCoord_def)
by (metis (no_types, lifting) diff_Suc_1 less_Suc_eq_0_disj nth_Cons')
lemma uniqueXRemove:"uniqueXCoord L \<Longrightarrow> uniqueXCoord (remove1 a L)"
  apply (induct L, auto)
  apply (simp add: uniqueXCoordAppend)
  apply (subgoal_tac "\<forall> b < length (remove1 a L). xCoord ((remove1 a L)!b) \<noteq> xCoord aa")
  using uniqueXCoordAppend uniqueXCoordEq apply blast
  apply (subgoal_tac "\<forall>b<length L. xCoord (L!b) \<noteq> xCoord aa")
  apply (metis in_set_conv_nth notin_set_remove1)
by (metis Suc_less_eq length_Cons nth_Cons_0 nth_Cons_Suc uniqueXCoord_def zero_less_Suc)
lemma uniqueXCoordAppend1[intro]: "uniqueXCoord (D @ X) \<longrightarrow> uniqueXCoord X"
  apply (safe, induct D)
  apply (simp add: uniqueXCoord_def)
by (metis append_Cons uniqueXCoordAppend)

(*partlist of a uniqueXCoord-List, is a uniqueXCoord-List*)
lemma uniqueXSub: "uniqueXCoord D \<Longrightarrow> \<forall> a < length L. L!a \<in> set D \<Longrightarrow> distinct L \<Longrightarrow> uniqueXCoord L"
  apply (induct D, auto)
  apply (simp add: uniqueXCoord_def)
  apply (subgoal_tac "\<forall>b<length D. xCoord (D!b) \<noteq> xCoord a", auto)
  apply (simp add: distinct_conv_nth in_set_conv_nth uniqueXCoordAppend uniqueXCoord_def)
  apply (metis Suc_mono nth_Cons_Suc)
  apply (metis Suc_mono gr_implies_not0 length_Cons length_greater_0_conv lessI list.distinct(1)
    list.sel(3) nth_Cons_0 nth_tl uniqueXCoord_def)
done
lemma uniqueXCoordAppend2[intro]: "uniqueXCoord (D @ [P,Q]) \<longrightarrow> uniqueXCoord (D @ [P])"
  apply (safe, cut_tac D="D @ [P,Q]" and L="D @ [P]" in uniqueXSub, auto)
  apply (metis less_antisym nth_append nth_append_length nth_mem)
  using distinct_append uniqueXCoordToDistinct apply blast
by (smt append_Cons append_assoc in_set_conv_decomp_last uniqueXCoordAppend1 uniqueX_notIn)
lemma uniqueXCoordAppend3[intro]: "uniqueXCoord (D @ [P,Q]) \<longrightarrow> uniqueXCoord (D @ [Q])"
    apply (safe, cut_tac D="D @ [P,Q]" and L="D @ [Q]" in uniqueXSub, auto)
    apply (metis less_antisym nth_append nth_append_length nth_mem)
    using distinct_append uniqueXCoordToDistinct apply blast
by (smt append_Cons append_assoc in_set_conv_decomp_first rotate1.simps(2) set_rotate1
  uniqueXCoordAppend1 uniqueX_notIn)
lemma uniqueXCoordPermutation: "uniqueXCoord (A @ B) \<Longrightarrow> distinct TM \<Longrightarrow>
  \<forall>a \<in> set (TM). a \<in> set (A @ B) \<Longrightarrow> uniqueXCoord(TM)"
  apply (induct A, auto)
  using nth_mem uniqueXSub apply blast
by (smt Un_iff insert_iff list.set(2) nth_mem set_append uniqueXSub)
lemma uniqueXCoordPointList: "3 \<le> length L \<Longrightarrow> uniqueXCoord L \<Longrightarrow> pointList (L)"
  by (simp add: uniqueXCoord_def pointList_def, metis distinct_conv_nth)

(*all edges of pointList are segments*)
lemma pointsSegments: "pointList L \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < (size L - 1) \<Longrightarrow> segment (L!i) (L! Suc i)"
  apply (auto simp add: segment_def pointList_def pointsEqual_def)
by (cut_tac L=L and i=i in distinctElem, auto)

(*if you extend pointsList by one segment, all elements of the new list are also segments*)
lemma pointsSegmentsAppend1: "pointList L \<Longrightarrow> segment (last L) a \<Longrightarrow> k < (length (L @ [a]) - 1) \<Longrightarrow>
  segment ((L @ [a]) ! k) ((L @ [a]) ! Suc k)"
  by (auto, metis One_nat_def Suc_leI Suc_lessI diff_Suc_Suc diff_less_mono diff_zero
    last_conv_nth le0 length_0_conv nth_append nth_append_length pointsSegments zero_less_Suc)
lemma pointsSegmentsAppend2: "length L \<ge> 1 \<Longrightarrow> \<forall>i < length L. segment ((L@[a])!i) ((L@[a]) ! Suc i)
  \<Longrightarrow> segment (last L) a"
  apply (erule_tac x="length L - 1" in allE, auto simp add: nth_append)
  by (smt Suc_eq_plus1 Suc_pred add.commute diff_self_eq_0 last_conv_nth le_Suc_ex less_not_refl
    list.size(3) monoid_add_class.add.left_neutral neq0_conv nth_Cons_0 old.nat.distinct(2))
theorem pointsSegmentsAppend: "pointList L \<Longrightarrow> k < size L - 1 \<Longrightarrow>
  (\<forall>i < (size (L @ [a]) - 1). segment ((L @ [a])!i) ((L @ [a])! Suc i))
  = (segment (L!k) (L ! Suc k) \<and> segment (last L) a)"
  apply (safe, simp add: pointsSegments, simp add: pointsSegmentsAppend2)
by (metis pointsSegmentsAppend1)

(*any 3 corners in the point list are collinear.*)
definition collinearList :: "point2d list \<Rightarrow> bool" where
  "collinearList L \<equiv> (\<exists> a b c. a < length L \<and> b < length L \<and> c < length L \<and>
  a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c \<and> collinear (L!a) (L!b) (L!c))"
lemma collinearListThree: "length L = 3 \<Longrightarrow> collinearList L = collinear (L!0) (L!1) (L!2)"
  apply (auto simp add: collinearList_def)
  apply (case_tac "a=0", case_tac "b=1", subgoal_tac "c=2", auto)
    apply (case_tac "b=2", subgoal_tac "c=1", auto)
  apply (case_tac "a=1", case_tac "b=0", subgoal_tac "c=2", auto)
    apply (simp add: less_Suc_eq numeral_2_eq_2 numeral_3_eq_3)
  apply (case_tac "b=0", subgoal_tac "c=1", auto)
    apply (simp add: less_Suc_eq numeral_2_eq_2 numeral_3_eq_3)
  apply (subgoal_tac "b=1", subgoal_tac "c=0", auto)
    apply (simp add: less_Suc_eq numeral_2_eq_2 numeral_3_eq_3)
  apply (rule_tac x=0 in exI, simp, rule_tac x=1 in exI, simp, rule_tac x=2 in exI, simp)
done
lemma collinearListLength[dest]: "length L < 3 \<Longrightarrow> collinearList L \<Longrightarrow> False"
  apply (simp add: collinearList_def, safe)
  apply (case_tac "a=0", subgoal_tac "b = 1", simp)
    using numeral_3_eq_3 apply linarith
  apply (subgoal_tac "b = 0", simp)
  using numeral_3_eq_3 apply linarith
done
lemma collinearListNoPointsEq: "length L \<ge> 3 \<Longrightarrow> \<not>collinearList L \<Longrightarrow> i < size L \<Longrightarrow> k < size L
  \<Longrightarrow> k \<noteq> i \<Longrightarrow> \<not>pointsEqual (L ! i) (L ! k)"
  apply (auto simp add: collinearList_def)
  apply (erule_tac x=i in allE, simp, erule_tac x=k in allE, safe)
  apply (case_tac "k=0")
    apply (case_tac "i = 1")
    apply (erule_tac x=2 in allE, simp)
    apply (subgoal_tac "i = 2")
    apply (erule_tac x=1 in allE, simp)
    apply (rule ccontr, erule_tac x=2 in allE, simp)
  apply (case_tac "i=0")
    apply (case_tac "k=1")
    apply (erule_tac x=2 in allE, simp)
    apply (erule_tac x=1 in allE, simp)
  apply (erule_tac x=0 in allE, simp)
done
(*mit der negation, brauche ich evtl. die Definition von pointList nicht mehr*)
lemma collinearPointList: "3 \<le> length L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> pointList L"
  apply (simp add: pointList_def collinearList_def)
  apply (subgoal_tac "\<forall> i k. i < size L \<and> k < size L \<and> k \<noteq> i \<longrightarrow> \<not>pointsEqual (L ! i) (L ! k)")
  apply (simp add: distinct_conv_nth)
using collinearListNoPointsEq collinearList_def by auto

lemma collinearList1[simp]: "collinearList [a,b,c] = collinear a b c"
  apply (simp add: collinearList_def, rule iffI) defer
  apply (rule_tac  x=0 in exI, simp, rule_tac  x=1 in exI, simp, rule_tac  x=2 in exI, simp, safe)
  apply (case_tac "aa = 0", subgoal_tac "ba > 0", case_tac "ba = 1", subgoal_tac "ca = 2", simp+)
  apply (case_tac "ba = 0", case_tac "aa = 1", subgoal_tac "ca = 2", simp+)
by (subgoal_tac "ca = 0", case_tac "aa = 1", subgoal_tac "ba = 2", simp+)
lemma collinearList2: "\<not>collinearList (a#xs) \<Longrightarrow> \<not>collinearList (xs)"
  apply (simp add: collinearList_def, safe)
  apply (erule_tac x="aa+1" in allE, simp, erule_tac x="b+1" in allE, simp)
by (erule_tac x="c+1" in allE, simp)
(*collinearList reverse is still a collinearList*)
lemma collinearListRev: "collinearList xs = collinearList (rev xs)"
  apply (simp add: collinearList_def, rule iffI, safe)
  apply (rule_tac x="(length xs - 1) - a" in exI, safe, simp)
  apply(rule_tac x="(length xs - 1) - b" in exI, safe, simp)
  apply(rule_tac x="(length xs - 1) - c" in exI, safe, simp)
  apply(simp add: rev_nth)+
  apply(rule_tac x="(length xs - 1) - a" in exI, safe, simp)
  apply(rule_tac x="(length xs - 1) - b" in exI, safe, simp)
  apply(rule_tac x="(length xs - 1) - c" in exI, safe, simp)
  apply(simp add: rev_nth)+
done

(*extend collinearList is still a collinearList*)
lemma collinearListAppend1: "collinearList xs \<Longrightarrow> collinearList (a#xs)"
  by (metis collinearList2)
lemma collinearListAppendB : "collinearList xs \<Longrightarrow> collinearList (x @ xs)"
  by (induction x, auto simp add: collinearListAppend1)
lemma collinearListAppend2: "collinearList xs \<Longrightarrow> collinearList (xs @ [a])"
  by (metis collinearList2 collinearListRev rev.simps(2) rev_rev_ident)
lemma collinearListAppend: "collinearList xs \<Longrightarrow> collinearList (xs @ x)"
  apply (cases xs, simp)
  apply (simp add: collinearList_def, safe)+
  apply (rule_tac x="aa" in exI, simp, rule_tac x=b in exI, simp, rule_tac x=c in exI, simp)
by (metis append_Cons length_Cons nth_append)

(*no 3 corners behind each other are collinear if \<not>collinearList L*)
lemma collinearListAdj: "\<not>collinearList L \<Longrightarrow> a < length L - 2 \<Longrightarrow>
    \<not>collinear (L ! a)(L! Suc a)(L! Suc(Suc a))"
  apply (simp add: collinearList_def, erule_tac x=a in allE, safe)
  apply (metis diff_less_Suc lessI less_trans_Suc lift_Suc_mono_less_iff)
  apply (erule_tac x="Suc a" in allE, safe, metis Suc_lessD add_2_eq_Suc' less_diff_conv)
by (erule_tac x="Suc (Suc a)" in allE, safe, (simp add: less_diff_conv n_not_Suc_n)+)

(*no 2 adjacent segment intersect, if \<not>collinearList L*)
lemma collinearListIntersect:"\<not>collinearList L \<Longrightarrow> a < length L - 2 \<Longrightarrow>
  \<not>intersect (L ! a) (L! Suc a) (L! Suc a) (L! Suc(Suc a))"
  apply (auto simp add: intersect_def)
  using collinearListAdj isBetweenImpliesCollinear3 apply blast
using collinearListAdj isBetweenImpliesCollinear by blast

(*none of the segments from point list intersects(real) with another segment form this point list*)
definition crossingFreePList :: "point2d list \<Rightarrow> bool" where
 "crossingFreePList P \<equiv> \<forall>i k. ((k < length P - 1 \<and> i < length P - 1) \<longrightarrow>
 \<not>crossing (P ! i) (P ! Suc i) (P ! k) (P ! Suc k))"

(*none of the segments from the point list intersect with another segment of the point list
  (except of course the each adjacent edge)*)
definition intersectionFreePList :: "point2d list \<Rightarrow> bool" where
 "intersectionFreePList P \<equiv> \<forall>i k. (k < length P - 1 \<and> i < length P - 1) \<longrightarrow>
    \<not>intersect (P ! i) (P ! Suc i) (P ! k) (P ! Suc k)"

(*if in the first place no intersection, then at the second position*)
lemma sizeOfList: "\<not> intersect a b A B \<Longrightarrow> intersect ((a#b# L) ! k) ((a#b# L) ! Suc k) A B \<Longrightarrow> k\<ge>1"
  by (cases k, auto)
lemma listIntersectNth: "\<not>intersect a b A B \<Longrightarrow> intersect ((a#b# L) ! i) ((a#b# L) ! Suc i) A B \<Longrightarrow>
  intersect ((b#L) ! (i - 1)) ((b#L) ! (Suc i - 1)) A B"
  by (cut_tac A=A and B=B and a=a and b=b and L=L and k=i in sizeOfList, auto)

(*if a segment from the segment list and the segment AB intersects, then the extension of this list,
 intersect with the segment AB too*)
lemma listIntersectionAppend: "segment A B \<Longrightarrow> i < length L - 1 \<Longrightarrow>
  intersect (L ! i) (L ! Suc i) A B \<Longrightarrow> \<exists>k l::nat. 0 \<le> k \<and> l = k + 1 \<and> l < length (a # b # L)
  \<and> intersect ((a # b # L) ! k) ((a # b # L) ! l) A B"
  by (rule_tac x="i + 2" in exI, rule_tac x="i + 3" in exI, auto)
lemma listIntersectionDel : "segment A B \<Longrightarrow> length L \<ge> 1 \<Longrightarrow> \<not>intersect a b A B \<Longrightarrow>
  (\<exists> k. k \<ge> 0 \<and> (k + 1) < length (a # b # L) \<and> intersect ((a#b# L) ! k) ((a#b# L) ! (k + 1)) A B)
  \<longleftrightarrow> ((\<exists> i. i\<ge>0 \<and> i + 1 < length L \<and> intersect (L!i) ( L!(i + 1)) A B) \<or> intersect b (hd L) A B)"
  apply (auto, rule_tac x="k - 2" in exI, subgoal_tac "k \<ge> 2")
  apply (auto, subgoal_tac "Suc (k - 2) = k - 1 \<and> (k - 2) = k - Suc (Suc 0)", auto)
  apply (metis One_nat_def Suc_1 hd_conv_nth le_0_eq le_Suc_eq length_0_conv not_less_eq_eq
    nth_Cons_0 nth_Cons_Suc)
  apply (rule_tac x="1" in exI, auto, subgoal_tac "L ! 0 = hd L")
by (auto, metis Suc_n_not_le_n gen_length_code(1) hd_conv_nth length_code)
lemma listIntersection1: "segment A B \<Longrightarrow> length L \<ge> 1 \<Longrightarrow> \<not> intersect a b A B \<Longrightarrow>
  (intersect ((a#b#L)!k) ((a#b#L)!Suc k) A B
  \<longleftrightarrow> ( k\<ge>2 \<and> intersect (L ! (k - 2)) ( L ! (k - 1)) A B)) \<or> intersect b (hd L) A B"
  apply (safe,metis (erased, hide_lams) Suc_eq_plus1 add.commute add_leE hd_conv_nth not_less_eq_eq
    list.size(3) monoid_add_class.add.right_neutral  nth_Cons_0 nth_Cons_Suc one_add_one le_antisym)
  apply (subgoal_tac "k \<ge> 2", subgoal_tac "(k - Suc (Suc 0)) = k - 2")
  apply (simp, simp, simp)
  apply (metis One_nat_def Suc_1 hd_conv_nth le_0_eq le_Suc_eq length_0_conv not_less_eq_eq
    nth_Cons_0 nth_Cons_Suc)
by (subgoal_tac "(k - Suc (Suc 0)) = k - 2", auto)

theorem listIntersection: "segment A B \<Longrightarrow> length L \<ge> 1 \<Longrightarrow>
  (intersect ((a#b#L) ! k) ((a#b# L) ! Suc k) A B) \<longleftrightarrow> ((k = 0 \<and> intersect a b A B)
    \<or> (k = 1 \<and> intersect b (hd L) A B)) \<or> (k\<ge>2 \<and> intersect ( L ! (k - 2)) ( L ! (k - 1)) A B)"
  apply (safe, simp, simp, metis less_2_cases not_less nth_Cons_0, simp)
  apply (metis One_nat_def diff_self_eq_0 hd_conv_nth le_imp_less_Suc length_0_conv less_2_cases
    less_imp_le_nat not_less nth_Cons')
  apply (metis One_nat_def listIntersection1 nth_Cons_Suc)
  apply (simp , metis Suc_1 diff_0_eq_0 diff_Suc_eq_diff_pred diff_self_eq_0
    diffs0_imp_equal nth_Cons' old.nat.exhaust)
  apply (simp, metis One_nat_def Suc_1 Suc_pred diff_Suc_eq_diff_pred neq0_conv nth_Cons')
  apply (metis Suc_1 diff_Suc_1 diff_Suc_eq_diff_pred intersectNext nth_Cons' nth_Cons_Suc)
  apply (metis  listIntersection1, simp, simp)
by (metis One_nat_def hd_conv_nth list.size(3) not_one_le_zero, simp, metis One_nat_def Suc_1)

lemma intersectionFreePListAdjacentColl: "pointList P \<Longrightarrow> intersectionFreePList P \<Longrightarrow>
   i < length P - 2 \<Longrightarrow> \<not> (P!i) isBetween (P!Suc i) (P!Suc(Suc i))"
  apply (auto simp add: intersectionFreePList_def)
  apply (subgoal_tac "segment (P ! Suc i) (P ! Suc (Suc i))")
  apply (simp add: Suc_diff_Suc intersectBetween less_SucI nat_diff_split not_less_eq
    numeral_2_eq_2 pointsSegments)
  apply (smt One_nat_def Suc_diff_Suc Suc_eq_plus1 Suc_less_eq diff_Suc_1 intersect_def le0
    less_SucI list.size(3) nat.distinct(1) pointsSegments)
by (simp add: isBetweenPointsDistinct segment_def)

(*evtl. noch nütlich*)

(*(*Define order of point list after x-Coord and after x-Coord.
  Needed to say which point on the X and Y axes is far right/left/top/bottom*)
definition xCoordSort :: "point2d list \<Rightarrow> point2d list" where
"xCoordSort P \<equiv> sort_key (xCoord) P"
definition yCoordSort :: "point2d list \<Rightarrow> point2d list" where
"yCoordSort P \<equiv> sort_key (yCoord) P"
(*x/y-Sort gibt returns a sorted list*)
lemma xCoordSorted :  "sorted (map xCoord (xCoordSort xs))"
  by(induct xs, auto simp:sorted_insort_key xCoordSort_def)
theorem xCoordSorted1 : "sorted (map xCoord (x # xs)) \<longleftrightarrow>
    (sorted (map xCoord xs) \<and> (\<forall> y \<in> set xs. xCoord x \<le> xCoord y))"
  by (rule sortedKey)
lemma yCoordSorted :  "sorted (map yCoord (yCoordSort xs))"
  by (induct xs, auto simp:sorted_insort_key yCoordSort_def)
theorem yCoordSorted1 :  "sorted (map yCoord (x # xs)) \<longleftrightarrow>
    (sorted (map yCoord xs) \<and> (\<forall> y \<in> set xs. yCoord x \<le> yCoord y))"
  by (rule sortedKey)
(*All the points in the list are still there after sort*)
lemma inXCoord : "a \<in> set xs \<longrightarrow> a \<in> set (xCoordSort xs)"
  by (auto simp add: xCoordSort_def)
lemma inYCoord : "a \<in> set xs \<longrightarrow>  a \<in> set (yCoordSort xs)"
  by (auto simp add: yCoordSort_def)

(*first element of the sorted list is less or equal than the last.*)
lemma xCoordOrd : "size L > 0 \<Longrightarrow> xCoord (last (xCoordSort L)) \<ge> xCoord (hd (xCoordSort L))"
  apply (cases L, simp, insert inXCoord xCoordSorted xCoordSorted1)
  by (metis empty_iff in_set_member last_in_set list.collapse list.set(1) member_rec(1) order_refl)
lemma yCoordOrd : "size L > 0 \<Longrightarrow> yCoord (last (yCoordSort L)) \<ge> yCoord (hd (yCoordSort L))"
  apply (cases L, simp, insert inYCoord yCoordSorted yCoordSorted1)
  by (metis empty_iff in_set_member last_in_set list.collapse list.set(1) member_rec(1) order_refl)*)

end


theory Punc_Security
  imports Punc_Proofs
begin

section \<open>Security results\<close>

(* Lemma 3.1, first part *)
lemma correctness_punc:
  "correctness params keygen enc dec msg_space \<le> correctness params0 keygen0 enc0 dec0 msg_space0"
  (is "?lhs \<le> ?rhs")
proof -
  have ex1: "expectation_exists' (keygen0 ()) (\<lambda>(x, y). correctness_pksk enc dec0 msg_space () x y)"
    apply (rule expectation_exists_bounded[where a=0 and b=1])
    by (auto simp: case_prod_beta)
  have ex2: "expectation_exists' (keygen0 ()) (\<lambda>(x, y). correctness_pksk enc0 dec0 msg_space0 () x y)"
    apply (rule expectation_exists_bounded[where a=0 and b=1])
    by (auto simp: nonempty_msg_space0 case_prod_beta)
  have "?lhs = correctness params keygen enc dec0 msg_space"
  proof -
    have "(case dec0 () sk c of None \<Rightarrow> None | Some m \<Rightarrow> if m \<in> msg_space p then Some m else None) \<noteq> Some m
      \<longleftrightarrow> dec0 () sk c \<noteq> Some m" if "m \<in> msg_space p" for p sk m c
      using that apply (cases "dec0 () sk c") by auto
    then have "correctness_pkskm enc dec p pk sk m = correctness_pkskm enc dec0 p pk sk m" if "m \<in> msg_space p" for p pk sk m
      using that unfolding correctness_pkskm_def dec_def unit_eq by auto
    then show ?thesis
      unfolding correctness_def correctness_pksk_def by auto
  qed
  also have "\<dots> \<le> ?rhs"
    unfolding correctness_def keygen_def
    unfolding params0_def params_def expectation_point_distr
    apply simp
    using ex1 ex2 apply (rule expectation_mono, simp add: case_prod_beta)
    unfolding correctness_pksk_def
    using nonempty_msg_space _ msg_space apply (rule cSUP_subset_mono)
    unfolding enc_def encr_def enc0_def by auto
  finally show ?thesis by -
qed

(* Lemma 3.1, third part *)
lemma disjointness_punc:
  assumes "injective_enc params0 keygen0 enc0 msg_space0"
  shows "disjointness_punc = 0"
proof -
  have prob: "Prob (fakeenc () pk) (\<Union>m\<in>msg_space (). supp (enc () pk m)) \<le> 0" if "(pk,sk) \<in> supp (keygen p)" for pk sk p
  proof -
    from assms that have "injective_enc_pk () enc0 msg_space0 pk"
      unfolding injective_enc_def keygen_def by auto
    then have "disjnt (supp (enc0 () pk puncture)) (supp (enc0 () pk m2))" if "m2\<in>msg_space0 ()" for m2
      unfolding injective_enc_pk_def using puncture that by auto
    then have "disjnt (supp (fakeenc () pk)) (supp (enc () pk m2))" if "m2\<in>msg_space ()" for m2
      unfolding fakeenc_def enc_def enc0_def encr_def using that msg_space by auto
    then have disjnt: "disjnt (supp (fakeenc () pk)) (\<Union>x\<in>msg_space (). supp (enc () pk x))"
      using disjoint_UN_iff by blast
    show "Prob (fakeenc () pk) (\<Union>m\<in>msg_space (). supp (enc () pk m)) \<le> 0"
      apply (rule eq_refl, subst Prob_is_0)
      using disjnt by assumption
  qed
  have "disjointness params keygen enc fakeenc msg_space \<le> 0"
    unfolding disjointness_def
    apply (rule cSUP_least, simp)
    apply (rule cSUP_least, simp)
    using prob by auto
  moreover have "disjointness params keygen enc fakeenc msg_space \<ge> 0"
    apply (rule disjointness_geq0)
    by auto
  ultimately show ?thesis
    unfolding disjointness_punc_def
    by simp
qed

end


theory ScottVariant imports IHOML ModalUltrafilter
begin
(**Positiveness**) consts positiveProperty::"\<gamma>\<Rightarrow>\<sigma>" ("\<P>")
(**Part I**)
 (*D1*) definition G::\<gamma> ("G") where "G x \<equiv> \<^bold>\<forall>Y::\<gamma>. \<P> Y \<^bold>\<rightarrow> Y x"
 (*A1*) axiomatization where A1a: "\<lfloor>\<^bold>\<forall>X. \<P>(\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X)\<rfloor>" and A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X)\<rfloor>" and
 (*A2*) A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and
 (*A3*) A3: "\<lfloor>\<^bold>\<forall>Z X. ((\<^bold>\<forall>Y. Z Y \<^bold>\<rightarrow> \<P> Y) \<^bold>\<and> \<^bold>\<box>(\<^bold>\<forall>x. X x \<^bold>\<leftrightarrow> (\<^bold>\<forall>Y. Z Y \<^bold>\<rightarrow> Y x))) \<^bold>\<rightarrow> \<P> X\<rfloor>"
 (*T1*) theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" by (metis A1a A2)
 (*T2*) theorem T2: "\<lfloor>\<P> G\<rfloor>" by (smt A3 G_def)
 (*T3*) theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T1 T2 by simp
(**Part II**)
 (*Logic KB*)  axiomatization where symm: "\<forall>x y. x r y \<longrightarrow> y r x"
 (*A4*) axiomatization where A4: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>"
 (*D2*) definition ess::"\<gamma>\<Rightarrow>\<gamma>" ("\<E>") where  "\<E> Y x \<equiv> Y x \<^bold>\<and> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. Y z \<^bold>\<rightarrow>  Z z))"
 (*T4*) theorem T4: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)\<rfloor>" by (metis A1b A4 G_def ess_def)
 (*D3*) definition NE::\<gamma> ("NE") where "NE x \<equiv> \<^bold>\<forall>Y. \<E> Y x \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y"
 (*A5*) axiomatization where A5: "\<lfloor>\<P> NE\<rfloor>"
 (*T5*) theorem T5: "\<lfloor>(\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" by (metis A5 G_def NE_def T4 symm)
 (*T6*) theorem T6: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T3 T5 by blast
(**Consistency**) lemma True nitpick[satisfy,user_axioms] oops  (*Model found by Nitpick*)
(**Modal collapse**)
  lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>"
    proof - {fix w fix Q
      have "\<forall>x. G x w \<longrightarrow> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Z z)) w" by (metis A1b A4 G_def)
      hence 1: "(\<exists>x. G x w) \<longrightarrow> ((Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w)" by force
      have "\<exists>x. G x w" using T3 T6 symm by blast
      hence "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q) w" using 1 T6 by blast}
    thus ?thesis by auto qed
(**Analysis of positive properties using ultrafilters**)
 (*unimportant*) declare [[smt_solver = cvc4, smt_oracle]]
 (*U1*) theorem U1: "\<lfloor>\<gamma>-Ultrafilter \<P>\<rfloor>" (*Sledgehammer succeeds, reconstruction fails*)
          proof - have 1: "\<lfloor>\<^bold>U\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<^bold>\<not>\<^bold>\<emptyset>\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" using A1b T1 by auto
                  have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<phi>\<^bold>\<subseteq>\<^sup>\<gamma>\<psi>) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" by (metis A1b G_def T1 T6 symm)
                  have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<P>) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<^sup>\<gamma>\<psi>)\<^bold>\<in>\<^sup>\<gamma>\<P>)\<rfloor>" by (metis A1b G_def T1 T6 symm)
                  have 4: "\<lfloor>\<^bold>\<forall>\<phi>. \<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<or> (\<inverse>\<^sup>\<gamma>\<phi>)\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" using A1b by blast
                  thus ?thesis by (simp add: 1 2 3 4) qed
 (*U2*) abbreviation "\<P>' \<equiv> \<lambda>\<phi>.(\<P>\<^bold>\<down>\<phi>)" (*Set of \<phi>'s whose rigidly intens. extensions are positive*)
theorem U2: "\<lfloor>\<gamma>-Ultrafilter \<P>'\<rfloor>"  (*Sledgehammer succeeds, reconstruction fails*)
          proof - have 1: "\<lfloor>\<^bold>U\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<^bold>\<not>\<^bold>\<emptyset>\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" using A1b T1 by auto
                  have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<phi>\<^bold>\<subseteq>\<^sup>\<gamma>\<psi>) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" by (metis A1b G_def T1 T6 symm)
                  have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<P>) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<^sup>\<gamma>\<psi>)\<^bold>\<in>\<^sup>\<gamma>\<P>)\<rfloor>" by (metis A1b G_def T1 T6 symm)
                  have 4: "\<lfloor>\<^bold>\<forall>\<phi>. \<phi>\<^bold>\<in>\<^sup>\<gamma>\<P> \<^bold>\<or> (\<inverse>\<^sup>\<gamma>\<phi>)\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" using A1b by blast
                  thus ?thesis by (simp add: 1 2 3 4) qed
 (*U3*) theorem U3: "\<lfloor>\<^bold>\<forall>\<phi>. \<phi>\<^bold>\<in>\<^sup>\<gamma>\<P>' \<^bold>\<leftrightarrow> \<phi>\<^bold>\<in>\<^sup>\<gamma>\<P>\<rfloor>" by (metis A1b G_def T1 T6 symm) (*\<P>' and \<P> are equal*)
(**Modal logic S5**)
  axiomatization where refl: "\<forall>x. x r x" and trans: "\<forall>x y z. x r y \<and> y r z \<longrightarrow> x r z"
  lemma True nitpick[satisfy,user_axioms] oops (*Model found by Nitpick*)
(**Barcan and converse Barcan formula for individuals (type e) and properties (type e\<Rightarrow>i\<Rightarrow>bool)**)
  lemma Bind1: "\<lfloor>(\<^bold>\<forall>\<^sup>Ex::e.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex::e. \<phi> x)\<rfloor>" using MC symm by blast
  lemma CBind1: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex::e. \<phi> x) \<^bold>\<rightarrow> (\<^bold>\<forall>\<^sup>Ex::e.\<^bold>\<box>(\<phi> x))\<rfloor>" using MC by blast
  lemma Bpred1: "\<lfloor>(\<^bold>\<forall>x::e\<Rightarrow>i\<Rightarrow>bool. \<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x::e\<Rightarrow>i\<Rightarrow>bool. \<phi> x)\<rfloor>" by simp
  lemma CBpred1: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x::e\<Rightarrow>i\<Rightarrow>bool. \<phi> x) \<^bold>\<rightarrow> (\<^bold>\<forall>x::e\<Rightarrow>i\<Rightarrow>bool. \<^bold>\<box>(\<phi> x))\<rfloor>" by simp
end