theory Sestoft
imports SestoftConf
begin

inductive step :: "conf \<Rightarrow> conf \<Rightarrow> bool" (infix "\<Rightarrow>" 50) where
  app\<^sub>1:  "(\<Gamma>, App e x, S) \<Rightarrow> (\<Gamma>, e , Arg x # S)"
| app\<^sub>2:  "(\<Gamma>, Lam [y]. e, Arg x # S) \<Rightarrow> (\<Gamma>, e[y ::= x] , S)"
| var\<^sub>1:  "map_of \<Gamma> x = Some e \<Longrightarrow> (\<Gamma>, Var x, S) \<Rightarrow> (delete x \<Gamma>, e , Upd x # S)"
| var\<^sub>2:  "x \<notin> domA \<Gamma> \<Longrightarrow> isVal e \<Longrightarrow> (\<Gamma>, e, Upd x # S) \<Rightarrow> ((x,e)# \<Gamma>, e , S)"
| let\<^sub>1:  "atom ` domA \<Delta> \<sharp>* \<Gamma> \<Longrightarrow> atom ` domA \<Delta> \<sharp>* S
                           \<Longrightarrow> (\<Gamma>, Let \<Delta> e, S) \<Rightarrow> (\<Delta>@\<Gamma>, e , S)"
| if\<^sub>1:  "(\<Gamma>, scrut ? e1 : e2, S) \<Rightarrow> (\<Gamma>, scrut, Alts e1 e2 # S)"
| if\<^sub>2:  "(\<Gamma>, Bool b, Alts e1 e2 # S) \<Rightarrow> (\<Gamma>, if b then e1 else e2, S)"

abbreviation steps (infix "\<Rightarrow>\<^sup>*" 50) where "steps \<equiv> step\<^sup>*\<^sup>*"

lemma SmartLet_stepI:
   "atom ` domA \<Delta> \<sharp>* \<Gamma> \<Longrightarrow> atom ` domA \<Delta> \<sharp>* S \<Longrightarrow> (\<Gamma>, SmartLet \<Delta> e, S) \<Rightarrow>\<^sup>*  (\<Delta>@\<Gamma>, e , S)"
unfolding SmartLet_def by (auto intro: let\<^sub>1)

lemma lambda_var: "map_of \<Gamma> x = Some e \<Longrightarrow> isVal e  \<Longrightarrow> (\<Gamma>, Var x, S) \<Rightarrow>\<^sup>* ((x,e) # delete x \<Gamma>, e , S)"
  by (rule rtranclp_trans[OF r_into_rtranclp r_into_rtranclp])
     (auto intro: var\<^sub>1 var\<^sub>2)

lemma let\<^sub>1_closed:
  assumes "closed (\<Gamma>, Let \<Delta> e, S)"
  assumes "domA \<Delta> \<inter> domA \<Gamma> = {}"
  assumes "domA \<Delta> \<inter> upds S = {}"
  shows "(\<Gamma>, Let \<Delta> e, S) \<Rightarrow> (\<Delta>@\<Gamma>, e , S)"
proof
  from \<open>domA \<Delta> \<inter> domA \<Gamma> = {}\<close> and \<open>domA \<Delta> \<inter> upds S = {}\<close>
  have "domA \<Delta> \<inter> (domA \<Gamma> \<union> upds S) = {}" by auto
  with \<open>closed _\<close>
  have "domA \<Delta> \<inter> fv (\<Gamma>, S) = {}" by auto
  hence "atom ` domA \<Delta> \<sharp>* (\<Gamma>, S)"
    by (auto simp add: fresh_star_def fv_def fresh_def)
  thus "atom` domA \<Delta> \<sharp>* \<Gamma>" and "atom ` domA \<Delta> \<sharp>* S" by (auto simp add: fresh_star_Pair)
qed

text \<open>An induction rule that skips the annoying case of a lambda taken off the heap\<close>

lemma step_invariant_induction[consumes 4, case_names app\<^sub>1 app\<^sub>2 thunk lamvar var\<^sub>2 let\<^sub>1 if\<^sub>1 if\<^sub>2 refl trans]:
  assumes "c \<Rightarrow>\<^sup>* c'"
  assumes "\<not> boring_step c'"
  assumes "invariant (\<Rightarrow>) I"
  assumes "I c"
  assumes app\<^sub>1:  "\<And> \<Gamma> e x S . I (\<Gamma>, App e x, S) \<Longrightarrow> P (\<Gamma>, App e x, S)  (\<Gamma>, e , Arg x # S)"
  assumes app\<^sub>2:  "\<And> \<Gamma> y e x S . I (\<Gamma>, Lam [y]. e, Arg x # S) \<Longrightarrow> P (\<Gamma>, Lam [y]. e, Arg x # S) (\<Gamma>, e[y ::= x] , S)"
  assumes thunk:  "\<And> \<Gamma> x e S . map_of \<Gamma> x = Some e \<Longrightarrow> \<not> isVal e \<Longrightarrow> I (\<Gamma>, Var x, S) \<Longrightarrow>  P (\<Gamma>, Var x, S) (delete x \<Gamma>, e , Upd x # S)"
  assumes lamvar:  "\<And> \<Gamma> x e S . map_of \<Gamma> x = Some e \<Longrightarrow> isVal e \<Longrightarrow> I (\<Gamma>, Var x, S) \<Longrightarrow> P (\<Gamma>, Var x, S) ((x,e) # delete x \<Gamma>, e , S)"
  assumes var\<^sub>2:  "\<And> \<Gamma> x e S . x \<notin> domA \<Gamma> \<Longrightarrow> isVal e \<Longrightarrow> I (\<Gamma>, e, Upd x # S) \<Longrightarrow> P (\<Gamma>, e, Upd x # S) ((x,e)# \<Gamma>, e , S)"
  assumes let\<^sub>1:  "\<And> \<Delta> \<Gamma> e S . atom ` domA \<Delta> \<sharp>* \<Gamma> \<Longrightarrow> atom ` domA \<Delta> \<sharp>* S \<Longrightarrow> I (\<Gamma>, Let \<Delta> e, S) \<Longrightarrow> P (\<Gamma>, Let \<Delta> e, S) (\<Delta>@\<Gamma>, e, S)"
  assumes if\<^sub>1:   "\<And>\<Gamma> scrut e1 e2 S. I  (\<Gamma>, scrut ? e1 : e2, S) \<Longrightarrow> P (\<Gamma>, scrut ? e1 : e2, S) (\<Gamma>, scrut, Alts e1 e2 # S)"
  assumes if\<^sub>2:   "\<And>\<Gamma> b e1 e2 S. I  (\<Gamma>, Bool b, Alts e1 e2 # S) \<Longrightarrow> P (\<Gamma>, Bool b, Alts e1 e2 # S) (\<Gamma>, if b then e1 else e2, S)"
  assumes refl: "\<And> c. P c c"
  assumes trans[trans]: "\<And> c c' c''. c \<Rightarrow>\<^sup>* c' \<Longrightarrow> c' \<Rightarrow>\<^sup>* c'' \<Longrightarrow> P c c' \<Longrightarrow> P c' c'' \<Longrightarrow> P c c''"
  shows "P c c'"
proof-
  from assms(1,3,4)
  have "P c c' \<or> (boring_step c' \<and> (\<forall> c''. c' \<Rightarrow> c'' \<longrightarrow> P c c''))"
  proof(induction rule: rtranclp_invariant_induct)
  case base
    have "P c c" by (rule refl)
    thus ?case..
  next
  case (step y z)
    from step(5)
    show ?case
    proof
      assume "P c y"

      note t = trans[OF \<open>c \<Rightarrow>\<^sup>* y\<close> r_into_rtranclp[where r = step, OF \<open>y \<Rightarrow> z\<close>]]

      from \<open>y \<Rightarrow> z\<close>
      show ?thesis
      proof (cases)
        case app\<^sub>1 hence "P y z" using assms(5) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      next
        case app\<^sub>2 hence "P y z" using assms(6) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      next
        case (var\<^sub>1 \<Gamma> x e S)
        show ?thesis
        proof (cases "isVal e")
          case False with var\<^sub>1 have "P y z" using assms(7) \<open>I y\<close> by metis
          with \<open>P c y\<close> show ?thesis by (metis t)
        next
          case True
          have *: "y \<Rightarrow>\<^sup>* ((x,e) # delete x \<Gamma>, e , S)" using var\<^sub>1 True lambda_var by metis

          have "boring_step (delete x \<Gamma>, e, Upd x # S)" using True ..
          moreover
          have "P y ((x,e) # delete x \<Gamma>, e , S)" using var\<^sub>1 True assms(8) \<open>I y\<close> by metis
          with \<open>P c y\<close> have "P c ((x,e) # delete x \<Gamma>, e , S)" by (rule trans[OF \<open>c \<Rightarrow>\<^sup>* y\<close> *])
          ultimately
          show ?thesis using var\<^sub>1(2,3) True by (auto elim!: step.cases)
        qed
      next
        case var\<^sub>2 hence "P y z" using assms(9) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      next
        case let\<^sub>1 hence "P y z" using assms(10) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      next
        case if\<^sub>1 hence "P y z" using assms(11) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      next
        case if\<^sub>2 hence "P y z" using assms(12) \<open>I y\<close> by metis
        with \<open>P c y\<close> show ?thesis by (metis t)
      qed
    next
      assume "boring_step y \<and> (\<forall>c''. y \<Rightarrow> c'' \<longrightarrow> P c c'')"
      with \<open>y \<Rightarrow> z\<close>
      have "P c z" by blast
      thus ?thesis..
    qed
  qed
  with assms(2)
  show ?thesis by auto
qed

lemma step_induction[consumes 2, case_names app\<^sub>1 app\<^sub>2 thunk lamvar var\<^sub>2 let\<^sub>1 if\<^sub>1 if\<^sub>2 refl trans]:
  assumes "c \<Rightarrow>\<^sup>* c'"
  assumes "\<not> boring_step c'"
  assumes app\<^sub>1:  "\<And> \<Gamma> e x S . P (\<Gamma>, App e x, S)  (\<Gamma>, e , Arg x # S)"
  assumes app\<^sub>2:  "\<And> \<Gamma> y e x S . P (\<Gamma>, Lam [y]. e, Arg x # S) (\<Gamma>, e[y ::= x] , S)"
  assumes thunk:  "\<And> \<Gamma> x e S . map_of \<Gamma> x = Some e \<Longrightarrow> \<not> isVal e \<Longrightarrow> P (\<Gamma>, Var x, S) (delete x \<Gamma>, e , Upd x # S)"
  assumes lamvar:  "\<And> \<Gamma> x e S . map_of \<Gamma> x = Some e \<Longrightarrow> isVal e \<Longrightarrow> P (\<Gamma>, Var x, S) ((x,e) # delete x \<Gamma>, e , S)"
  assumes var\<^sub>2:  "\<And> \<Gamma> x e S . x \<notin> domA \<Gamma> \<Longrightarrow> isVal e \<Longrightarrow> P (\<Gamma>, e, Upd x # S) ((x,e)# \<Gamma>, e , S)"
  assumes let\<^sub>1:  "\<And> \<Delta> \<Gamma> e S . atom ` domA \<Delta> \<sharp>* \<Gamma> \<Longrightarrow> atom ` domA \<Delta> \<sharp>* S \<Longrightarrow> P (\<Gamma>, Let \<Delta> e, S) (\<Delta>@\<Gamma>, e, S)"
  assumes if\<^sub>1:   "\<And>\<Gamma> scrut e1 e2 S. P (\<Gamma>, scrut ? e1 : e2, S) (\<Gamma>, scrut, Alts e1 e2 # S)"
  assumes if\<^sub>2:   "\<And>\<Gamma> b e1 e2 S. P (\<Gamma>, Bool b, Alts e1 e2 # S) (\<Gamma>, if b then e1 else e2, S)"
  assumes refl: "\<And> c. P c c"
  assumes trans[trans]: "\<And> c c' c''. c \<Rightarrow>\<^sup>* c' \<Longrightarrow> c' \<Rightarrow>\<^sup>* c'' \<Longrightarrow> P c c' \<Longrightarrow> P c' c'' \<Longrightarrow> P c c''"
  shows "P c c'"
by (rule step_invariant_induction[OF _ _ invariant_True, simplified, OF assms])

subsubsection \<open>Equivariance\<close>

lemma step_eqvt[eqvt]: "step x y \<Longrightarrow> step (\<pi> \<bullet> x) (\<pi> \<bullet> y)"
  apply (induction  rule: step.induct)
  apply (perm_simp, rule step.intros)
  apply (perm_simp, rule step.intros)
  apply (perm_simp, rule step.intros)
  apply (rule permute_boolE[where p = "-\<pi>"], simp add: pemute_minus_self)
  apply (perm_simp, rule step.intros)
  apply (rule permute_boolE[where p = "-\<pi>"], simp add: pemute_minus_self)
  apply (rule permute_boolE[where p = "-\<pi>"], simp add: pemute_minus_self)
  apply (perm_simp, rule step.intros)
  apply (rule permute_boolE[where p = "-\<pi>"], simp add: pemute_minus_self)
  apply (rule permute_boolE[where p = "-\<pi>"], simp add: pemute_minus_self)
  apply (perm_simp, rule step.intros)
  apply (perm_simp, rule step.intros)
  done

subsubsection \<open>Invariants\<close>

lemma closed_invariant:
  "invariant step closed"
proof
  fix c c'
  assume "c \<Rightarrow> c'" and "closed c"
  thus "closed c'"
  by (induction rule: step.induct) (auto simp add: fv_subst_eq dest!: subsetD[OF fv_delete_subset] dest: subsetD[OF map_of_Some_fv_subset])
qed

lemma heap_upds_ok_invariant:
  "invariant step heap_upds_ok_conf"
proof
  fix c c'
  assume "c \<Rightarrow> c'" and "heap_upds_ok_conf c"
  thus "heap_upds_ok_conf c'"
  by (induction rule: step.induct) auto
qed

end


header {* \isaheader{Iterators} *}
theory Gen_Iterator
imports "../../Refine_Monadic/Refine_Monadic" "Proper_Iterator"
begin
  text {*
    Iterators are realized by to-list functions followed by folding.
    A post-optimization step then replaces these constructions by
    real iterators. *}

  lemma param_it_to_list[param]: "(it_to_list,it_to_list) \<in>
    (Rs \<rightarrow> (Ra \<rightarrow> bool_rel) \<rightarrow>
    (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel) \<rightarrow> \<langle>Rc\<rangle>list_rel \<rightarrow> Rd) \<rightarrow> Rs \<rightarrow> Rd"
    unfolding it_to_list_def[abs_def]
    by parametricity

  definition key_rel :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) \<Rightarrow> ('k\<times>'v) \<Rightarrow> bool"
    where "key_rel R a b \<equiv> R (fst a) (fst b)"

  lemma key_rel_UNIV[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
    unfolding key_rel_def[abs_def] by auto

  subsection {* Setup for Autoref *}
  text {* Default pattern rules for @{text "it_to_sorted_list"}*}
  definition "set_to_sorted_list R S \<equiv> it_to_sorted_list R S"

context begin interpretation autoref_syn .
  lemma set_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list R S \<equiv> OP (set_to_sorted_list R) S"
    unfolding set_to_sorted_list_def[abs_def] by auto
end

  definition "map_to_sorted_list R M
    \<equiv> it_to_sorted_list (key_rel R) (map_to_set M)"
  lemma map_to_sorted_list_itype[autoref_itype]:
    "map_to_sorted_list R ::\<^sub>i \<langle>Rk,Rv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Rk,Rv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres"
    by simp

context begin interpretation autoref_syn .
  lemma map_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list (key_rel R) (map_to_set M)
      \<equiv> OP (map_to_sorted_list R) M"
    "it_to_sorted_list (\<lambda>_ _. True) (map_to_set M)
      \<equiv> OP (map_to_sorted_list (\<lambda>_ _. True)) M"
    unfolding map_to_sorted_list_def[abs_def] by auto
end

  subsection {* Set iterators *}
  (*definition "is_set_to_sorted_list_deprecated ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs \<longrightarrow>
      (RETURN (tsl s),it_to_sorted_list ordR s')\<in>\<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    *)

  definition "is_set_to_sorted_list ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs
      \<longrightarrow> ( \<exists>l'. (tsl s,l')\<in>\<langle>Rk\<rangle>list_rel
            \<and> RETURN l' \<le> it_to_sorted_list ordR s')"

  definition "is_set_to_list \<equiv> is_set_to_sorted_list (\<lambda>_ _. True)"

  lemma is_set_to_sorted_listE:
    assumes "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    obtains l' where "(tsl s,l')\<in>\<langle>Rk\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list ordR s'"
    using assms unfolding is_set_to_sorted_list_def by blast

  (* TODO: Move *)
  lemma it_to_sorted_list_weaken:
    "R\<le>R' \<Longrightarrow> it_to_sorted_list R s \<le> it_to_sorted_list R' s"
    unfolding it_to_sorted_list_def
    by (auto intro!: sorted_by_rel_weaken[where R=R])

  lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "is_set_to_list Rk Rs tsl"
    using assms
    unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    by blast

  definition "det_fold_set R c f \<sigma> result \<equiv>
    \<forall>l. distinct l \<and> sorted_by_rel R l \<longrightarrow> foldli l c f \<sigma> = result (set l)"

  lemma det_fold_setI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct l; sorted_by_rel R l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (set l)"
    shows "det_fold_set R c f \<sigma> result"
    using assms unfolding det_fold_set_def by auto

  text {* Template lemma for generic algorithm using set iterator *}
  lemma det_fold_sorted_set:
    assumes 1: "det_fold_set ordR c' f' \<sigma>' result"
    assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes SREF[param]: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list ordR s'"
      using 2 SREF
      by (rule is_set_to_sorted_listE)

    have "(foldli (tsl s) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result s'"
      using 1 IT
      unfolding det_fold_set_def it_to_sorted_list_def
      by simp
    finally show ?thesis .
  qed

  lemma det_fold_set:
    assumes "det_fold_set (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_set_to_list Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
    using assms
    unfolding  is_set_to_list_def
    by (rule det_fold_sorted_set)

  subsection {* Map iterators *}

  text {* Build relation on keys *}

  (*definition "is_map_to_sorted_list_deprecated ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow>
      (RETURN (tsl m),it_to_sorted_list (key_rel ordR) (map_to_set m'))
      \<in>\<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"*)

  definition "is_map_to_sorted_list ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow> (
      \<exists>l'. (tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<and> RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m'))"

  definition "is_map_to_list Rk Rv Rm tsl
    \<equiv> is_map_to_sorted_list (\<lambda>_ _. True) Rk Rv Rm tsl"

  lemma is_map_to_sorted_listE:
    assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    obtains l' where "(tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
    using assms unfolding is_map_to_sorted_list_def by blast

  lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
    shows "is_map_to_list Rk Rv Rm tsl"
    using assms
    unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    unfolding key_rel_def[abs_def]
    by blast

  definition "det_fold_map R c f \<sigma> result \<equiv>
    \<forall>l. distinct (map fst l) \<and> sorted_by_rel (key_rel R) l
      \<longrightarrow> foldli l c f \<sigma> = result (map_of l)"

  lemma det_fold_mapI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct (map fst l); sorted_by_rel (key_rel R) l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    shows "det_fold_map R c f \<sigma> result"
    using assms unfolding det_fold_map_def by auto

  lemma det_fold_map_aux:
    assumes 1: "\<lbrakk>distinct (map fst l); sorted_by_rel (key_rel R) l \<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    assumes 2: "RETURN l \<le> it_to_sorted_list (key_rel R) (map_to_set m)"
    shows "foldli l c f \<sigma> = result m"
  proof -
    from 2 have "distinct l" and "set l = map_to_set m"
      and SORTED: "sorted_by_rel (key_rel R) l"
      unfolding it_to_sorted_list_def by simp_all
    hence "\<forall>(k,v)\<in>set l. \<forall>(k',v')\<in>set l. k=k' \<longrightarrow> v=v'"
      apply simp
      unfolding map_to_set_def
      apply auto
      done
    with `distinct l` have DF: "distinct (map fst l)"
      apply (induct l)
      apply simp
      apply force
      done
    with `set l = map_to_set m` have [simp]: "m = map_of l"
      by (metis map_of_map_to_set)

    from 1[OF DF SORTED] show ?thesis by simp
  qed

  text {* Template lemma for generic algorithm using map iterator *}
  lemma det_fold_sorted_map:
    assumes 1: "det_fold_map ordR c' f' \<sigma>' result"
    assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes MREF[param]: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl m,tsl') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
      using 2 MREF by (rule is_map_to_sorted_listE)

    have "(foldli (tsl m) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result m'"
      using det_fold_map_aux[of tsl' ordR c' f' \<sigma>' result] 1 IT
      unfolding det_fold_map_def
      by clarsimp
    finally show ?thesis .
  qed

  lemma det_fold_map:
    assumes "det_fold_map (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_map_to_list Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
    using assms
    unfolding is_map_to_list_def
    by (rule det_fold_sorted_map)

lemma set_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes SV: "PREFER single_valued Rk"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), set_to_sorted_list R)
    \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>Rk\<rangle>list_rel"
      and R2: "RETURN l' \<le> set_to_sorted_list R s'"
    unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>Rk\<rangle>list_rel) (RETURN l')"
    apply (rule RETURN_refine_sv)
    using SV unfolding autoref_tag_defs apply tagged_solver
    by fact
  also note R2
  finally show "RETURN (tsl s) \<le> \<Down> (\<langle>Rk\<rangle>list_rel) (set_to_sorted_list R s')" .
qed

lemma map_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes SV: "PREFER single_valued Rk" "PREFER single_valued Rv"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list R)
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk,Rv\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and R2: "RETURN l' \<le> map_to_sorted_list R s'"
    unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (RETURN l')"
    apply (rule RETURN_refine_sv)
    using SV unfolding autoref_tag_defs apply tagged_solver
    by fact
  also note R2
  finally show
    "RETURN (tsl s) \<le> \<Down> (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (map_to_sorted_list R s')" .
qed

lemma map_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes SV: "PREFER single_valued Rk" "PREFER single_valued Rv"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list (\<lambda>_ _. True))
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
  using assms(2-) unfolding is_map_to_list_def
  by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])

(*lemma dres_it_FOREACH_it_simp[iterator_simps]:
  "dres_it_FOREACH (\<lambda>s. dRETURN (i s)) s c f \<sigma>
    = foldli (i s) (case_dres False False c) (\<lambda>x s. s \<guillemotright>= f x) (dRETURN \<sigma>)"
  unfolding dres_it_FOREACH_def
  by simp
*)

text {*
  TODO/FIXME:
    * Integrate mono-prover properly into solver-infrastructure,
        i.e. tag a mono-goal.
    * Tag iterators, such that, for the mono-prover, we can just convert
        a proper iterator back to its foldli-equivalent!
*}
lemma proper_it_mono_dres_pair:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. f k v x \<le> f' k v x"
  shows "
    it' s (case_dres False False c) (\<lambda>(k,v) s. s \<guillemotright>= f k v) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>(k,v) s. s \<guillemotright>= f' k v) \<sigma>" (is "?a \<le> ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<guillemotright>= f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<guillemotright>= f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. case_prod f kv x \<le> case_prod f' kv x"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    it' s (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= f kv) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= f' kv) \<sigma>"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres[OF A])
  done

lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it'
  \<Longrightarrow> proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
  apply (rule proper_it'I)
  apply (simp add: comp_def)
  apply (rule icf_proper_iteratorI)
  apply (erule proper_it'D)
  done

lemma proper_it_mono_dres_dom:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= f kv) \<sigma>
    \<le>
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<guillemotright>= f' kv) \<sigma>"

  apply (rule proper_it_mono_dres)
  apply (rule icf_proper_iteratorI)
  by fact+

(* TODO/FIXME: Hack! Mono-prover should be able to find proper-iterators itself
*)
lemmas proper_it_monos =
  proper_it_mono_dres_pair proper_it_mono_dres proper_it_mono_dres_dom

(* TODO: Conceptually, this leads to some kind of bundles:
  Each bundle has a list of processors, that are invoked for every registered
  theorem. *)

attribute_setup "proper_it" = {*
  Scan.succeed (Thm.declaration_attribute (fn thm => fn context =>
    let
      val mono_thms = map_filter (try (curry op RS thm)) @{thms proper_it_monos}
      (*val mono_thms = map (fn mt => thm RS mt) @{thms proper_it_monos}*)
      val context = context
        |> Icf_Proper_Iterator.add_thm thm
        |> fold Refine_Misc.refine_mono.add_thm mono_thms
    in
      context
    end
  ))
  *}
  "Proper iterator declaration"

end


(*
    Title:      Bases_Of_Fundamental_Subspaces_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Bases of the four fundamental subspaces over IArrays*}

theory Bases_Of_Fundamental_Subspaces_IArrays
imports
  Bases_Of_Fundamental_Subspaces
  Gauss_Jordan_PA_IArrays
begin

subsection{*Computation of bases of the fundamental subspaces using IArrays*}

text{*We have made the definitions as efficient as possible.*}
definition "basis_left_null_space_iarrays A
  = (let GJ = Gauss_Jordan_iarrays_PA A;
          rank_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x]
          in set (map (\<lambda>i. row_iarray i (fst GJ)) [(rank_A)..<(nrows_iarray A)]))"
definition "basis_null_space_iarrays A
    = (let GJ= Gauss_Jordan_iarrays_PA (transpose_iarray A);
          rank_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x]
          in set (map (\<lambda>i. row_iarray i (fst GJ)) [(rank_A)..<(ncols_iarray A)]))"
definition "basis_row_space_iarrays A =
  (let GJ= Gauss_Jordan_iarrays A;
       rank_A = length [x\<leftarrow>IArray.list_of (GJ) . \<not> is_zero_iarray x]
       in set (map (\<lambda>i. row_iarray i (GJ)) [0..<rank_A]))"
definition "basis_col_space_iarrays A = basis_row_space_iarrays (transpose_iarray A)"

text{*The following lemmas make easier the proofs of equivalence between abstract versions and concrete versions.
      They are false if we remove @{text "matrix_to_iarray"}*}

lemma basis_null_space_iarrays_eq:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_null_space_iarrays (matrix_to_iarray A)
  = set (map (\<lambda>i. row_iarray i (fst (Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A))))) [(rank_iarray (matrix_to_iarray A))..<(ncols_iarray (matrix_to_iarray A))])"
unfolding basis_null_space_iarrays_def Let_def
unfolding matrix_to_iarray_rank[symmetric, of A]
unfolding rank_transpose[symmetric, of A]
unfolding matrix_to_iarray_rank
unfolding rank_iarrays_code
unfolding matrix_to_iarray_transpose[symmetric]
unfolding snd_Gauss_Jordan_iarrays_PA_eq ..

lemma basis_row_space_iarrays_eq:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_row_space_iarrays (matrix_to_iarray A) = set (map (\<lambda>i. row_iarray i (Gauss_Jordan_iarrays (matrix_to_iarray A))) [0..<(rank_iarray (matrix_to_iarray A))])"
unfolding basis_row_space_iarrays_def Let_def rank_iarrays_code ..

lemma basis_left_null_space_iarrays_eq:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_left_null_space_iarrays (matrix_to_iarray A) = basis_null_space_iarrays (transpose_iarray (matrix_to_iarray A))"
unfolding basis_left_null_space_iarrays_def
unfolding basis_null_space_iarrays_def Let_def
unfolding matrix_to_iarray_transpose[symmetric]
unfolding transpose_transpose
unfolding matrix_to_iarray_ncols[symmetric]
unfolding ncols_transpose
unfolding matrix_to_iarray_nrows ..

subsection{*Code equations*}

lemma vec_to_iarray_basis_null_space[code_unfold]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows  "vec_to_iarray` (basis_null_space A) = basis_null_space_iarrays (matrix_to_iarray A)"
proof (unfold basis_null_space_def basis_null_space_iarrays_eq, auto, unfold image_def, auto)
fix i::'cols
assume rank_le_i: "rank A \<le> to_nat i"
show "\<exists>x\<in>{rank_iarray (matrix_to_iarray A)..<ncols_iarray (matrix_to_iarray A)}.
vec_to_iarray (row i (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A))) = row_iarray x (fst (Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A))))"
proof (rule bexI[of _ "to_nat i"])
show "to_nat i \<in> {rank_iarray (matrix_to_iarray A)..<ncols_iarray (matrix_to_iarray A)}"
  unfolding matrix_to_iarray_ncols[symmetric]
  using rank_le_i to_nat_less_card[of i]
  unfolding matrix_to_iarray_rank ncols_def by fastforce
show "vec_to_iarray (row i (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A)))
    = row_iarray (to_nat i) (fst (Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A))))"
unfolding matrix_to_iarray_transpose[symmetric]
unfolding matrix_to_iarray_fst_Gauss_Jordan_PA[symmetric]
unfolding P_Gauss_Jordan_def
unfolding vec_to_iarray_row ..
qed
next
fix i assume rank_le_i: "rank_iarray (matrix_to_iarray A) \<le> i"
        and i_less_nrows: "i < ncols_iarray (matrix_to_iarray A)"
hence i_less_card:"i < CARD ('cols)"
  unfolding matrix_to_iarray_ncols[symmetric] ncols_def by simp
show "\<exists>x. (\<exists>i. x = row i (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A)) \<and> rank A \<le> to_nat i) \<and>
            row_iarray i (fst (Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A)))) = vec_to_iarray x"
proof (rule exI[of _ "row (from_nat i) (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A))"], rule conjI)
show "\<exists>ia. row (from_nat i) (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A)) = row ia (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A)) \<and>
         rank A \<le> to_nat ia"
         by (rule exI[of _ "from_nat i"],simp add: rank_le_i to_nat_from_nat_id[OF i_less_card] matrix_to_iarray_rank)
show "row_iarray i (fst (Gauss_Jordan_iarrays_PA (transpose_iarray (matrix_to_iarray A)))) =
    vec_to_iarray (row (from_nat i) (P_Gauss_Jordan (Cartesian_Euclidean_Space.transpose A)))"
unfolding matrix_to_iarray_transpose[symmetric]
unfolding matrix_to_iarray_fst_Gauss_Jordan_PA[symmetric]
unfolding P_Gauss_Jordan_def
unfolding vec_to_iarray_row to_nat_from_nat_id[OF i_less_card] ..
qed
qed

corollary vec_to_iarray_basis_left_null_space[code_unfold]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec_to_iarray` (basis_left_null_space A) = basis_left_null_space_iarrays (matrix_to_iarray A)"
proof -
have rw: "basis_left_null_space A = basis_null_space (transpose A)"
by (metis transpose_transpose basis_null_space_eq_basis_left_null_space_transpose)
show ?thesis unfolding rw unfolding basis_left_null_space_iarrays_eq
using vec_to_iarray_basis_null_space[of "transpose A"]
unfolding matrix_to_iarray_transpose[symmetric] .
qed

lemma vec_to_iarray_basis_row_space[code_unfold]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows  "vec_to_iarray` (basis_row_space A) = basis_row_space_iarrays (matrix_to_iarray A)"
proof (unfold basis_row_space_def basis_row_space_iarrays_eq, auto, unfold image_def, auto)
fix i
assume i: "row i (Gauss_Jordan A) \<noteq> 0"
show "\<exists>x\<in>{0..<rank_iarray (matrix_to_iarray A)}. vec_to_iarray (row i (Gauss_Jordan A)) = row_iarray x (Gauss_Jordan_iarrays (matrix_to_iarray A))"
  proof (rule bexI[of _ "to_nat i"])
    show "vec_to_iarray (row i (Gauss_Jordan A)) = row_iarray (to_nat i) (Gauss_Jordan_iarrays (matrix_to_iarray A))"
      unfolding vec_to_iarray_row matrix_to_iarray_Gauss_Jordan ..
    show "to_nat i \<in> {0..<rank_iarray (matrix_to_iarray A)}"
    by (auto, unfold matrix_to_iarray_rank[symmetric],
      metis (full_types) i iarray_to_vec_vec_to_iarray not_less rank_less_row_i_imp_i_is_zero row_iarray_def vec_matrix vec_to_iarray_row)
  qed
next
fix i
assume i: "i < rank_iarray (matrix_to_iarray A)"
hence i_less_rank: "i < rank A" unfolding matrix_to_iarray_rank .
show "\<exists>x. (\<exists>i. x = row i (Gauss_Jordan A) \<and> row i (Gauss_Jordan A) \<noteq> 0) \<and> row_iarray i (Gauss_Jordan_iarrays (matrix_to_iarray A)) = vec_to_iarray x"
proof (rule exI[of _ "row (from_nat i) (Gauss_Jordan A)"], rule conjI)
have not_zero_i: "\<not> is_zero_row (from_nat i) (Gauss_Jordan A)"
 proof (unfold is_zero_row_def, rule greatest_ge_nonzero_row')
 show "reduced_row_echelon_form_upt_k (Gauss_Jordan A) (ncols (Gauss_Jordan A))" by (metis rref_Gauss_Jordan rref_implies_rref_upt)
 have A_not_0: "A \<noteq> 0" using i_less_rank by (metis less_nat_zero_code rank_0)
 hence Gauss_not_0: "Gauss_Jordan A \<noteq> 0" by (metis Gauss_Jordan_not_0)
have "i \<le> to_nat (GREATEST' a. \<not> is_zero_row a (Gauss_Jordan A))" using i_less_rank unfolding rank_eq_suc_to_nat_greatest[OF A_not_0] by auto
thus "from_nat i \<le> (GREATEST' m. \<not> is_zero_row_upt_k m (ncols (Gauss_Jordan A)) (Gauss_Jordan A))" unfolding is_zero_row_def[symmetric] by (metis leD not_leE to_nat_le)
 show "\<not> (\<forall>a. is_zero_row_upt_k a (ncols (Gauss_Jordan A)) (Gauss_Jordan A))" using Gauss_not_0 unfolding is_zero_row_def[symmetric] is_zero_row_def' by (metis vec_eq_iff zero_index)
qed
have i_less_card: "i<CARD('rows)" using i_less_rank rank_le_nrows[of A] unfolding nrows_def by simp
show "\<exists>ia. row (from_nat i) (Gauss_Jordan A) = row ia (Gauss_Jordan A) \<and> row ia (Gauss_Jordan A) \<noteq> 0"
  apply (rule exI[of _ "from_nat i"], simp) using not_zero_i unfolding row_def is_zero_row_def' vec_nth_inverse by auto
show "row_iarray i (Gauss_Jordan_iarrays (matrix_to_iarray A)) = vec_to_iarray (row (from_nat i) (Gauss_Jordan A))"
unfolding matrix_to_iarray_Gauss_Jordan[symmetric] vec_to_iarray_row to_nat_from_nat_id[OF i_less_card] by rule
qed
qed

corollary vec_to_iarray_basis_col_space[code_unfold]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows  "vec_to_iarray` (basis_col_space A) = basis_col_space_iarrays (matrix_to_iarray A)"
unfolding basis_col_space_eq_basis_row_space_transpose basis_col_space_iarrays_def
unfolding matrix_to_iarray_transpose[symmetric]
unfolding vec_to_iarray_basis_row_space ..

end


theory roadMap
imports trapezoidalMap
begin

(*jede Strecke von der linken Vertikale zur der rechten Vertikal eines beliebigen Trapezes
  aus der TrapezoidalMap schneidet keine der Polygone aus der Polygonen-Liste*)
lemma segmentInTrapezIntersectFree: "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> uniqueXCoord (concat PL)
  \<Longrightarrow> rBoxTrapezS (concat PL) R \<Longrightarrow> polygonsDisjoint PL \<Longrightarrow> D = buildTrapezoidalMap R PL \<Longrightarrow>
  i < length (tDagList D) \<Longrightarrow> k < length PL \<Longrightarrow> A \<noteq> leftP ((tDagList D)!i) \<Longrightarrow>
  B \<noteq> rightP ((tDagList D)!i) \<Longrightarrow> (pointOnLeftT ((tDagList D)!i) A \<Longrightarrow>
  pointOnRightT ((tDagList D)!i) B \<Longrightarrow> \<not>lineCyclePathInters (cyclePath (PL!k)) A C)"
oops

(*es gibt einen Kanten-Zug für zwei beliebige benachbarten Trapeze aus der TrapezoidalMap,
  von der linken Vertikale zu der rechten Vertikale, so dass der Kanten-Zug
  keine der Polygone aus der Polygonen-Liste schneidet*)
lemma edgePathInTrapezoidalMap: "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> uniqueXCoord (concat PL) \<Longrightarrow>
  rBoxTrapezS (concat PL) R \<Longrightarrow> polygonsDisjoint PL \<Longrightarrow> D = buildTrapezoidalMap R PL \<Longrightarrow>
  i < length (tDagList D) \<Longrightarrow> j < length (tDagList D) \<Longrightarrow> k < length PL \<Longrightarrow>
  A \<noteq> leftP ((tDagList D)!i) \<Longrightarrow> C \<noteq> rightP ((tDagList D)!j) \<Longrightarrow>
  trapezNeighbor ((tDagList D)!i) ((tDagList D)!j) \<Longrightarrow>  (pointOnLeftT ((tDagList D)!i) A \<Longrightarrow>
  pointOnRightT ((tDagList D)!j) C \<Longrightarrow> \<exists> B. \<not>cyclePathIntersect(cyclePath (PL!k)) [A,B,C])"
oops

(*beweise dass wenn Trapeze benachbart, dann kommt man immer von rechten ecke zu der anderen rechten Ecke
ohne überschneidung von Polygonen*)
(*lemma "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> uniqueXCoord (concat PL) \<Longrightarrow> rBoxTrapezS (concat PL) R
  \<Longrightarrow> polygonsDisjoint PL \<Longrightarrow> D = buildTrapezoidalMap R PL \<Longrightarrow>
  \<forall> i j k. ((i \<noteq> j \<and> i < length (tDagList D) \<and> j < length (tDagList D) \<and> k < length (tDagList D)
    \<and> trapezNeighbor ((tDagList D)!i) ((tDagList D)!j))
    \<longrightarrow> (pointOnRightT ((tDagList D)!i) P \<and>
    \<not>lineCyclePathInters (PL!k) (rightP ((tDagList D)!i)) (rightP ((tDagList D)!i))))"
  (*intersectFree nur wenn ich nicht die Knotenpunkte nehme!*)
  (*nehme Punkte die auf der vertikalen liegen und überprüfe ob diese über rightP oder unter liegen müssen
    benutze dafür den test auf die gemeinsaben topT oder bottomT*)
oops*)

(*rückgabe als Baum nur möglich, wenn man ein leeren Tip Knoten einfügt*)
fun freeSpace :: "tDag \<Rightarrow> (point2d list) list \<Rightarrow> tDag" where
  "freeSpace (Tip R) PL = Tip R" (*überprüfe of bottomT und topT zum selben Polygon gehören*)
  | "freeSpace (Node Tl n Tr) PL = Node (freeSpace Tl PL) n (freeSpace Tr PL)"

(*entferne die übrigen strecken die noch innerhalb der Polygone sind*)
definition computeFreeSpace :: "tDag \<Rightarrow> (point2d list) list \<Rightarrow> tDag" where
  "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> uniqueXCoord (concat PL) \<Longrightarrow> rBoxTrapezS (concat PL) R \<Longrightarrow>
  polygonsDisjoint PL \<Longrightarrow> D = addPolygonsToTrapezoidalMap (Tip R) PL \<Longrightarrow>
  computeFreeSpace D PL \<equiv> freeSpace D PL"

(*zeige das keine der Strecken von trapezoidalMap im Polygon sind*)

(*zeige das die trapezoidalMap jetzt eine Einteilung der Freien-Räume innerhalb der rBox ist*)

(*linke und rechte Strecke von trapezen schneiden die Polygone nicht(echt).
dafür müsste man jedoch leftT und rightT ausrechnen. einfacher wäre es evtl., wenn man impliziet zeigt
dass leftT und rightT vertikale(müssen die das sein?) sind und von topT und bottomT begrenzt werden,
d.h. andere segmente nicht schneiden*)
lemma "pointLists L \<Longrightarrow> P = cyclePath L \<Longrightarrow> polygon P \<Longrightarrow> uniqueXCoord L \<Longrightarrow> rBoxS R L \<Longrightarrow>
  TL = tDagList (simpTrapezoidalMap R P)
  \<Longrightarrow> i < length TL \<Longrightarrow> j < length TL \<Longrightarrow> \<not>polygonCrossing (PL!j) (TL!i)" (*lineCyclePathInters*)
oops

(*beweise das Strecken zwischen RaodMap immer Kollisionsfrei*)

end


theory javabip
  imports Main "/Volumes/Setup/Isabelle/Isabelle-Code/Jan21-Isab/trinhlibs"
begin

value "t_betaSet_1"
value "mk_pair_4 t_TrigInstance_1"

(*---- JavaBIP encoding ----*)
(*
(\<not>P(t,l) \<or> (Q(el1, el1) \<and> \<not>Q(el1,h))) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)
\<equiv> [\<not>P(t,l) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)] \<or> [Q(el1, el1) \<and> \<not>Q(el1,h) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)]
*)
value "(\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l \<or> (\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)))
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1)"

(*---- JavaBIP encoding - 1st transform ----*)
(*[\<not>P(t,l) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)]*)
value "((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))"

(*[Q(el1, el1) \<and> \<not>Q(el1,h) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)]*)
value "((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))"

(*[\<not>P(t,l) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)] \<or> [Q(el1, el1) \<and> \<not>Q(el1,h) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)]*)
value "
((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or>
((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
"

lemma fst_transform: "(\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l \<or> (\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)))
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1)
\<Longrightarrow> ((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or>
((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
"
  unfolding t_TrigInstance_1_def t_betaSet_1_def t_SyncInstance_1_def
  by blast

(*---- JavaBIP encoding - 2nd transform ----*)
(*[Q(el1, el1) \<and> \<not>Q(el1,h) \<and> \<not>P(t,l1) \<and> \<not>Q(k,h1)]*)
value "((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))"

value "((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or> ((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1))
\<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h))
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1))"

lemma snd_transform: "
((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or>
((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<Longrightarrow>
((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or> ((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1))"
  unfolding t_TrigInstance_1_def t_betaSet_1_def t_SyncInstance_1_def
  by blast

value "((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))"

value "((\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j.\<forall>t \<in> set u. \<forall>l \<in> set (snd t). \<not>P (fst t) l)
\<and> (\<forall>i \<in> set t_TrigInstance_1. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
\<or> ((\<exists>bet \<in> set t_betaSet_1. (\<forall>elm \<in> set bet.\<exists>el1 \<in> set elm. Q (fst el1) (snd el1)) \<and> (\<forall>elm \<in> set bet.\<forall>el1 \<in> set elm.\<forall>h \<in> set (lookup_3 (fst el1) t_TrigInstance_1) - {snd el1}. \<not>Q (fst el1) h)) \<and> (\<forall>j \<in> set t_SyncInstance_1. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t)  l1))"
end


(*
  Goal verification framework
    - Mental States
*)

\<comment> \<open>This theory introduces mental states and mental state formulas.
  The syntax and semantics of mental state formulas is defined.
  A proof system for mental state formulas is proved sound.\<close>

theory Gvf_Mental_States imports Gvf_Logic begin

section \<open>Properties of mental states\<close>

\<comment> \<open>We set up a type for mental states.\<close>
type_synonym mental_state = \<open>(\<Phi>\<^sub>L list \<times> \<Phi>\<^sub>L list)\<close>
\<comment> \<open>A mental state is a tuple of sets of propositional logic formulas.\<close>

\<comment> \<open>The definition filters those elements that are 'tuples of sets of propositional logic formulas'.
    Not all elements of this type are in fact mental states: a number of restrictions apply.\<close>
definition is_mental_state :: \<open>mental_state \<Rightarrow> bool\<close> (\<open>\<nabla>\<close>) where
  \<open>\<nabla> M \<equiv> let (\<Sigma>, \<Gamma>) = M in \<comment> \<open>Pattern matching to have variables for belief and goal base.\<close>
    \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom> \<comment> \<open>\<Sigma> is consistent.\<close>
      \<and> (\<forall>\<gamma>\<in>set \<Gamma>. \<comment> \<open>for all goals \<gamma> \<in> \<Gamma>:\<close>
        \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<gamma> \<comment> \<open>(i) \<gamma> is not entailed by the agent's beliefs,\<close>
        \<and> \<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<gamma>))\<close> \<comment> \<open>(ii) \<gamma> is consistent.\<close>
\<comment> \<open>Note that the subgoal property for goals is missing. It will be defined in the semantics.\<close>

\<comment> \<open>Every member (of the goal set) must be weaker than \<bottom>, but not weaker than any belief \<sigma>.\<close>
lemma \<open>\<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<forall>\<gamma>\<in>set \<Gamma>. \<Turnstile>\<^sub>P (\<^bold>\<bottom> \<^bold>\<longrightarrow> \<gamma>) \<and> \<not> (\<exists>\<sigma>\<in>set \<Sigma>. \<Turnstile>\<^sub>P (\<sigma> \<^bold>\<longrightarrow> \<gamma>)))\<close>
  unfolding is_mental_state_def by fastforce

section \<open>Syntax of mental state formulas\<close>

\<comment> \<open>Atoms are now the special belief and goal modalities.\<close>
datatype Atom\<^sub>M = Bl \<Phi>\<^sub>L | Gl \<Phi>\<^sub>L
\<comment> \<open>We now use a more complex type for atoms compared to simply natural numbers.
    Bl and Gl are the constructors taking a propositional logic formula as input.
    We introduce a nicer syntax below that hides the nesting of constructors.\<close>

\<comment> \<open>We set up a type for mental state formulas.\<close>
type_synonym \<Phi>\<^sub>M = \<open>Atom\<^sub>M \<Phi>\<^sub>P\<close>
\<comment> \<open>We instantiate the general logic parsing the type for atoms.\<close>

abbreviation \<open>B \<Phi> \<equiv> Atom (Bl \<Phi>)\<close>
abbreviation \<open>G \<Phi> \<equiv> Atom (Gl \<Phi>)\<close>

section \<open>Semantics\<close>

\<comment> \<open>Semantics of atoms for mental state formulas is derived given a mental state.\<close>
fun semantics\<^sub>M' :: \<open>mental_state \<Rightarrow> Atom\<^sub>M \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>M*\<close> 50) where
\<comment> \<open>Does the belief base entail \<Phi>?\<close>
  \<open>(\<Sigma>, _) \<Turnstile>\<^sub>M* Bl \<Phi> = (\<Sigma> \<^bold>\<Turnstile>\<^sub>P \<Phi>)\<close> |
\<comment> \<open>Is \<Phi> not entailed by the belief base and a (sub)goal?\<close>
  \<open>(\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M* Gl \<Phi> = (\<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<Phi> \<and> (\<exists>\<gamma>\<in>set \<Gamma>. \<Turnstile>\<^sub>P (\<gamma> \<^bold>\<longrightarrow> \<Phi>)))\<close>

\<comment> \<open>Semantics of formulas.\<close>
abbreviation semantics\<^sub>M :: \<open>mental_state \<Rightarrow> \<Phi>\<^sub>M \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>M\<close> 50) where
  \<open>M \<Turnstile>\<^sub>M \<phi> \<equiv> semantics\<^sub>P (semantics\<^sub>M' M) \<phi>\<close>
\<comment> \<open>The semantics for atoms, given a mental state, matches the type for an interpretation.
    The curried function is parsed on to the general semantics as an interpretation which allows
    reuse of the existing definition.\<close>

\<comment> \<open>Examples.\<close>
lemma \<open>([\<Phi>], []) \<Turnstile>\<^sub>M B \<Phi>\<close> by simp

lemma \<open>([ Atom ''0'' ], [ Atom ''2'' ]) \<Turnstile>\<^sub>M G (Atom ''1'' \<^bold>\<longrightarrow> Atom ''2'')\<close> (is \<open>([ ?R ], [ ?Q ]) \<Turnstile>\<^sub>M G (?P \<^bold>\<longrightarrow> ?Q)\<close>)
proof -
  have \<open>?R \<noteq> ?Q\<close> by simp
  have \<open>\<not> [ ?R ] \<^bold>\<Turnstile>\<^sub>P ?P \<^bold>\<longrightarrow> ?Q\<close>
  proof
    assume \<open>[ ?R ] \<^bold>\<Turnstile>\<^sub>P ?P \<^bold>\<longrightarrow> ?Q\<close>
    then have \<open>\<forall>f. semantics\<^sub>P f ?R \<longrightarrow> semantics\<^sub>P f (?P \<^bold>\<longrightarrow> ?Q)\<close> by auto
    moreover have \<open>\<exists>f. \<not> (semantics\<^sub>P f ?R \<longrightarrow> semantics\<^sub>P f (?P \<^bold>\<longrightarrow> ?Q))\<close>
    proof
      let ?f = \<open>(\<lambda>_. True)(''0'' := True, ''1'' := True, ''2'' := False)\<close>
      show \<open>\<not> (semantics\<^sub>P ?f ?R \<longrightarrow> semantics\<^sub>P ?f (?P \<^bold>\<longrightarrow> ?Q))\<close> by simp
    qed
    ultimately show False by auto
  qed
  then show ?thesis by simp
qed

section \<open>Various proofs\<close>

\<comment> \<open>An agent cannot have a goal to achieve a tautology.\<close>
lemma \<open>\<nabla> M \<Longrightarrow> \<not> M \<Turnstile>\<^sub>M G \<^bold>\<top>\<close>
  unfolding is_mental_state_def by auto

\<comment> \<open>An agent does not have inconsistent beliefs/goals.\<close>
lemma not_modal_False: \<open>\<nabla> M \<Longrightarrow> M \<Turnstile>\<^sub>M \<^bold>\<not> (B \<^bold>\<bottom>)\<close> \<open>\<nabla> M \<Longrightarrow> M \<Turnstile>\<^sub>M \<^bold>\<not> (G \<^bold>\<bottom>)\<close>
  unfolding is_mental_state_def by fastforce+

lemma bel_dist_conj: \<open>M \<Turnstile>\<^sub>M B (\<phi> \<^bold>\<and> \<psi>) \<longleftrightarrow> M \<Turnstile>\<^sub>M B \<phi> \<and> M \<Turnstile>\<^sub>M B \<psi>\<close>
  using semantics\<^sub>M'.elims(2) by fastforce

lemma is_mst_negB: \<open>\<nabla>M \<Longrightarrow> M \<Turnstile>\<^sub>M B (\<^bold>\<not> \<phi>) \<Longrightarrow> M \<Turnstile>\<^sub>M \<^bold>\<not> (B \<phi>)\<close>
  unfolding is_mental_state_def by fastforce

\<comment> \<open>Properties of the goal modality.\<close>
lemma G_properties:
  shows \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi>)\<close>
    and \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<and> (\<Phi> \<^bold>\<longrightarrow> \<psi>)) \<^bold>\<longrightarrow> G \<psi>)\<close>
    and \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<and> G \<psi> \<^bold>\<longrightarrow> G (\<Phi> \<^bold>\<and> \<psi>))\<close>
    and \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longleftrightarrow> \<psi>) \<longrightarrow> \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<longleftrightarrow> G \<psi>\<close>
proof -
  let ?\<Phi> = \<open>Atom ''0''\<close> and ?\<psi> = \<open>Atom ''1''\<close>
  show \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi>)\<close>
  proof
    assume *: \<open>\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi>\<close>
    \<comment> \<open>Counter example.\<close>
    moreover have \<open>\<exists>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<and> \<not> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi>\<close>
    proof -
      let ?\<Sigma> = \<open>[]\<close> and ?\<Gamma> = \<open>[ ?\<Phi> \<^bold>\<longrightarrow> ?\<psi>, ?\<Phi> ]\<close>
      have \<open>?\<Phi> \<noteq> ?\<psi>\<close> by simp
      then have \<open>\<not> (?\<Sigma>, ?\<Gamma>) \<Turnstile>\<^sub>M G (?\<Phi> \<^bold>\<longrightarrow> ?\<psi>) \<^bold>\<longrightarrow> G ?\<Phi> \<^bold>\<longrightarrow> G ?\<psi>\<close> by auto
      moreover have \<open>\<nabla> (?\<Sigma>, ?\<Gamma>)\<close> unfolding is_mental_state_def by auto
      ultimately show ?thesis by blast
    qed
    ultimately show False by blast
  qed
  show \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<and> (\<Phi> \<^bold>\<longrightarrow> \<psi>)) \<^bold>\<longrightarrow> G \<psi>)\<close>
  proof
    assume *: \<open>\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G (\<Phi> \<^bold>\<and> (\<Phi> \<^bold>\<longrightarrow> \<psi>)) \<^bold>\<longrightarrow> G \<psi>\<close>
    \<comment> \<open>Counter example.\<close>
    let ?\<Sigma> = \<open>[ ?\<psi> ]\<close> and ?\<Gamma> = \<open>[ ?\<Phi> \<^bold>\<and> (?\<Phi> \<^bold>\<longrightarrow> ?\<psi>) ]\<close>
    have \<open>\<not> (?\<Sigma>, ?\<Gamma>) \<Turnstile>\<^sub>M G (?\<Phi> \<^bold>\<and> (?\<Phi> \<^bold>\<longrightarrow> ?\<psi>)) \<^bold>\<longrightarrow> G ?\<psi>\<close> by auto
    moreover have \<open>\<nabla> (?\<Sigma>, ?\<Gamma>)\<close> unfolding is_mental_state_def by auto
    ultimately show False using * by blast
  qed
  show \<open>\<not> (\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<and> G \<psi> \<^bold>\<longrightarrow> G (\<Phi> \<^bold>\<and> \<psi>))\<close>
  proof
    assume *: \<open>\<forall>\<Sigma> \<Gamma> \<Phi> \<psi>. \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M (G \<Phi>) \<^bold>\<and> (G \<psi>) \<^bold>\<longrightarrow> G (\<Phi> \<^bold>\<and> \<psi>)\<close>
    \<comment> \<open>Counter example.\<close>
    let ?\<Sigma> = \<open>[]\<close> and
        ?\<Gamma> = \<open>[ ?\<Phi>, ?\<psi> ]\<close>
    have \<open>\<not> (?\<Sigma>, ?\<Gamma>) \<Turnstile>\<^sub>M (G ?\<Phi>) \<^bold>\<and> (G ?\<psi>) \<^bold>\<longrightarrow> G (?\<Phi> \<^bold>\<and> ?\<psi>)\<close>
      by auto
    moreover have \<open>\<nabla> (?\<Sigma>, ?\<Gamma>)\<close>
      unfolding is_mental_state_def by auto
    ultimately show False
      using * by blast
  qed
next
  show \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longleftrightarrow> \<psi>) \<longrightarrow> \<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<longleftrightarrow> G \<psi>\<close>
  proof
    assume \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longleftrightarrow> \<psi>) \<close>
    then have *: \<open>\<Sigma> \<^bold>\<Turnstile>\<^sub>P \<Phi> \<longleftrightarrow> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<psi>\<close> by auto
    show \<open>\<nabla> (\<Sigma>, \<Gamma>) \<longrightarrow> (\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<longleftrightarrow> G \<psi>\<close>
    proof
      assume \<open>\<nabla> (\<Sigma>, \<Gamma>)\<close>
      then have \<open>\<forall>\<gamma>\<in>set \<Gamma>. \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<gamma> \<and> \<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<gamma>)\<close> unfolding is_mental_state_def by simp
      with \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longleftrightarrow> \<psi>)\<close> have \<open>(\<exists>\<gamma>\<in>set \<Gamma>. \<Turnstile>\<^sub>P (\<gamma> \<^bold>\<longrightarrow> \<Phi>)) \<longleftrightarrow> (\<exists>\<gamma>\<in>set \<Gamma>. \<Turnstile>\<^sub>P (\<gamma> \<^bold>\<longrightarrow> \<psi>))\<close> by fastforce
      with * show \<open>(\<Sigma>, \<Gamma>) \<Turnstile>\<^sub>M G \<Phi> \<^bold>\<longleftrightarrow> G \<psi>\<close> by simp
    qed
  qed
qed

section \<open>Provability\<close>

inductive gen\<^sub>M :: \<open>Atom\<^sub>M gen_rules\<close> where
  R\<^sub>M_B: \<open>\<Turnstile>\<^sub>P \<Phi> \<Longrightarrow> B \<Phi> \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close> |
  A1\<^sub>M:  \<open>B (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> B \<Phi> \<^bold>\<longrightarrow> B \<psi> \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close> |
  A2\<^sub>M:  \<open>\<^bold>\<not> (B \<^bold>\<bottom>) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close> |
  A3\<^sub>M:  \<open>\<^bold>\<not> (G \<^bold>\<bottom>) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close> |
  A4\<^sub>M:  \<open>B \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (G \<Phi>) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close> |
  A5\<^sub>M:  \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<Longrightarrow> \<^bold>\<not> (B \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi> \<in> set \<Delta> \<Longrightarrow> gen\<^sub>M \<Gamma> \<Delta>\<close>

abbreviation derive\<^sub>M_multi :: \<open>\<Phi>\<^sub>M list \<Rightarrow> \<Phi>\<^sub>M list \<Rightarrow> bool\<close> (infix \<open>\<turnstile>\<^sub>M#\<close> 40) where
  \<open>\<Gamma> \<turnstile>\<^sub>M# \<Delta> \<equiv> gen_sc (Some gen\<^sub>M) \<Gamma> \<Delta>\<close>

abbreviation derive\<^sub>M :: \<open>\<Phi>\<^sub>M \<Rightarrow> bool\<close> (\<open>\<turnstile>\<^sub>M _\<close> 40) where
  \<open>\<turnstile>\<^sub>M \<phi> \<equiv> [] \<turnstile>\<^sub>M# [ \<phi> ]\<close>

lemma A4x: \<open>\<turnstile>\<^sub>M G \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (B \<Phi>)\<close>
proof -
  from A4\<^sub>M have \<open>gen\<^sub>M [] [B \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (G \<Phi>)]\<close> by simp
  then have \<open>\<turnstile>\<^sub>M B \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (G \<Phi>)\<close> by (simp add: Gen)
  moreover from neg_imp have \<open>\<turnstile>\<^sub>M (B \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (G \<Phi>)) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (B \<Phi>)\<close>
    using gen_sc_None by fastforce
  ultimately show ?thesis using gen_sc_mp by auto
qed

\<comment> \<open>Example.\<close>
lemma \<open>\<turnstile>\<^sub>M B \<Phi> \<^bold>\<or> \<^bold>\<not> (B \<Phi>)\<close> (is \<open>\<turnstile>\<^sub>M ?P \<^bold>\<or> \<^bold>\<not> ?P\<close>)
proof  -
  from R_Or have \<open>\<turnstile>\<^sub>P ?P \<^bold>\<or> \<^bold>\<not> ?P\<close> if \<open>[] \<turnstile>\<^sub>P# [ ?P, \<^bold>\<not> ?P ]\<close> using that by blast
  with R_Shift have \<open>\<turnstile>\<^sub>P ?P \<^bold>\<or> \<^bold>\<not> ?P\<close> if \<open>[] \<turnstile>\<^sub>P# [ \<^bold>\<not> ?P, ?P ]\<close> using that by force
  with R_Neg have \<open>\<turnstile>\<^sub>P ?P \<^bold>\<or> \<^bold>\<not> ?P\<close> if \<open>[ ?P ] \<turnstile>\<^sub>P# [ ?P ]\<close> using that by auto
  with Axiom have \<open>\<turnstile>\<^sub>P ?P \<^bold>\<or> \<^bold>\<not> ?P\<close> by force
  with gen_sc_None show ?thesis by auto
qed

section \<open>Soundness\<close>

\<comment> \<open>For the soundness theorem we assume the mental state properties for M.\<close>
lemma soundness\<^sub>_gen\<^sub>M:
  assumes \<open>\<nabla> M\<close>
  shows \<open>gen\<^sub>M \<Gamma> \<Delta> \<Longrightarrow> \<forall>\<gamma> \<in> set \<Gamma>. M \<Turnstile>\<^sub>M \<gamma> \<Longrightarrow> \<exists>\<Phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>M \<Phi>\<close>
proof (induct rule: gen\<^sub>M.induct)
  case (R\<^sub>M_B \<Phi> \<Delta> \<Gamma>)
  then have \<open>\<forall>M. \<nabla>M \<longrightarrow> M \<Turnstile>\<^sub>M (B \<Phi>) \<and> B \<Phi> \<in> set \<Delta>\<close> by simp
  with assms show ?case by blast
next
  case (A1\<^sub>M \<Phi> \<psi> \<Gamma> \<Delta>)
  moreover have \<open>\<forall>M. \<nabla>M \<longrightarrow> M \<Turnstile>\<^sub>M (B (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<^bold>\<longrightarrow> B \<Phi> \<^bold>\<longrightarrow> B \<psi>)\<close> by simp
  ultimately show ?case using assms by blast
next
  case (A2\<^sub>M \<Delta> \<Gamma>)
  moreover have \<open>M \<Turnstile>\<^sub>M (\<^bold>\<not> (B \<^bold>\<bottom>))\<close> using not_modal_False(1) assms by simp
  ultimately show ?case by fastforce
next
  case (A3\<^sub>M \<Delta> \<Gamma>)
  moreover have \<open>M \<Turnstile>\<^sub>M (\<^bold>\<not> (G \<^bold>\<bottom>))\<close> using not_modal_False(2) assms by simp
  ultimately show ?case by fastforce
next
  case (A4\<^sub>M \<Phi> \<Delta> \<Gamma>)
  moreover have \<open>\<forall>M. \<nabla>M \<longrightarrow> M \<Turnstile>\<^sub>M (B \<Phi> \<^bold>\<longrightarrow> \<^bold>\<not> (G \<Phi>))\<close> by simp
  ultimately show ?case using assms by blast
next
  case (A5\<^sub>M \<Phi> \<psi> \<Delta> \<Gamma>)
  then have \<open>\<Turnstile>\<^sub>P (\<Phi> \<^bold>\<longrightarrow> \<psi>) \<and> \<^bold>\<not> (B \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi> \<in>set \<Delta>\<close> by fastforce
  then have \<open>\<forall>M. \<nabla>M \<longrightarrow> M \<Turnstile>\<^sub>M (\<^bold>\<not> (B \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi>) \<and> \<^bold>\<not> (B \<psi>) \<^bold>\<longrightarrow> G \<Phi> \<^bold>\<longrightarrow> G \<psi> \<in>set \<Delta>\<close> by auto
  with assms show ?case by blast
qed

lemma soundness\<^sub>M':
  assumes \<open>\<nabla> M\<close>
  shows \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> R = Some gen\<^sub>M \<Longrightarrow> \<forall>\<gamma> \<in> set \<Gamma>. M \<Turnstile>\<^sub>M \<gamma> \<Longrightarrow> \<exists>\<Phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>M \<Phi>\<close>
proof (induct rule: gen_sc.induct)
  case (Gen R \<Gamma> \<Delta>)
  with soundness\<^sub>_gen\<^sub>M show ?case using assms by simp
qed auto

theorem soundness\<^sub>M: \<open>\<nabla> M \<Longrightarrow> \<turnstile>\<^sub>M \<Phi> \<Longrightarrow> M \<Turnstile>\<^sub>M \<Phi>\<close> using soundness\<^sub>M' by fastforce

end


(*  Title:      HOL/ex/Refute_Examples.thy
    Author:     Tjark Weber
    Copyright   2003-2007

See HOL/Refute.thy for help.
*)

section {* Examples for the 'refute' command *}

theory Refute_Examples
imports "~~/src/HOL/Library/Refute"
begin

refute_params [satsolver = "cdclite"]

lemma "P \<and> Q"
apply (rule conjI)
refute [expect = genuine] 1  -- {* refutes @{term "P"} *}
refute [expect = genuine] 2  -- {* refutes @{term "Q"} *}
refute [expect = genuine]    -- {* equivalent to 'refute 1' *}
  -- {* here 'refute 3' would cause an exception, since we only have 2 subgoals *}
refute [maxsize = 5, expect = genuine]   -- {* we can override parameters ... *}
refute [satsolver = "cdclite", expect = genuine] 2
  -- {* ... and specify a subgoal at the same time *}
oops

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

subsection {* Examples and Test Cases *}

subsubsection {* Propositional logic *}

lemma "True"
refute [expect = none]
by auto

lemma "False"
refute [expect = genuine]
oops

lemma "P"
refute [expect = genuine]
oops

lemma "~ P"
refute [expect = genuine]
oops

lemma "P & Q"
refute [expect = genuine]
oops

lemma "P | Q"
refute [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
refute [expect = genuine]
oops

lemma "(P::bool) = Q"
refute [expect = genuine]
oops

lemma "(P | Q) \<longrightarrow> (P & Q)"
refute [expect = genuine]
oops

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

subsubsection {* Predicate logic *}

lemma "P x y z"
refute [expect = genuine]
oops

lemma "P x y \<longrightarrow> P y x"
refute [expect = genuine]
oops

lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
refute [expect = genuine]
oops

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

subsubsection {* Equality *}

lemma "P = True"
refute [expect = genuine]
oops

lemma "P = False"
refute [expect = genuine]
oops

lemma "x = y"
refute [expect = genuine]
oops

lemma "f x = g x"
refute [expect = genuine]
oops

lemma "(f::'a\<Rightarrow>'b) = g"
refute [expect = genuine]
oops

lemma "(f::('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
refute [expect = genuine]
oops

lemma "distinct [a, b]"
(* refute *)
apply simp
refute [expect = genuine]
oops

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

subsubsection {* First-Order Logic *}

lemma "\<exists>x. P x"
refute [expect = genuine]
oops

lemma "\<forall>x. P x"
refute [expect = genuine]
oops

lemma "EX! x. P x"
refute [expect = genuine]
oops

lemma "Ex P"
refute [expect = genuine]
oops

lemma "All P"
refute [expect = genuine]
oops

lemma "Ex1 P"
refute [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
refute [expect = genuine]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
refute [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (EX! x. P x)"
refute [expect = genuine]
oops

text {* A true statement (also testing names of free and bound variables being identical) *}

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
refute [maxsize = 4, expect = none]
by fast

text {* "A type has at most 4 elements." *}

lemma "a=b | a=c | a=d | a=e | b=c | b=d | b=e | c=d | c=e | d=e"
refute [expect = genuine]
oops

lemma "\<forall>a b c d e. a=b | a=c | a=d | a=e | b=c | b=d | b=e | c=d | c=e | d=e"
refute [expect = genuine]
oops

text {* "Every reflexive and symmetric relation is transitive." *}

lemma "\<lbrakk> \<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x \<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
refute [expect = genuine]
oops

text {* The "Drinker's theorem" ... *}

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
refute [maxsize = 4, expect = none]
by (auto simp add: ext)

text {* ... and an incorrect version of it *}

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
refute [expect = genuine]
oops

text {* "Every function has a fixed point." *}

lemma "\<exists>x. f x = x"
refute [expect = genuine]
oops

text {* "Function composition is commutative." *}

lemma "f (g x) = g (f x)"
refute [expect = genuine]
oops

text {* "Two functions that are equivalent wrt.\ the same predicate 'P' are equal." *}

lemma "((P::('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
refute [expect = genuine]
oops

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

subsubsection {* Higher-Order Logic *}

lemma "\<exists>P. P"
refute [expect = none]
by auto

lemma "\<forall>P. P"
refute [expect = genuine]
oops

lemma "EX! P. P"
refute [expect = none]
by auto

lemma "EX! P. P x"
refute [expect = genuine]
oops

lemma "P Q | Q x"
refute [expect = genuine]
oops

lemma "x \<noteq> All"
refute [expect = genuine]
oops

lemma "x \<noteq> Ex"
refute [expect = genuine]
oops

lemma "x \<noteq> Ex1"
refute [expect = genuine]
oops

text {* "The transitive closure 'T' of an arbitrary relation 'P' is non-empty." *}

definition "trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans P == (ALL x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition "subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "subset P Q == (ALL x y. P x y \<longrightarrow> Q x y)"

definition "trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans_closure P Q == (subset Q P) & (trans P) & (ALL R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
refute [expect = genuine]
oops

text {* "The union of transitive closures is equal to the transitive closure of unions." *}

lemma "(\<forall>x y. (P x y | R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y | R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
        \<longrightarrow> trans_closure TP P
        \<longrightarrow> trans_closure TR R
        \<longrightarrow> (T x y = (TP x y | TR x y))"
refute [expect = genuine]
oops

text {* "Every surjective function is invertible." *}

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
refute [expect = genuine]
oops

text {* "Every invertible function is surjective." *}

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
refute [expect = genuine]
oops

text {* Every point is a fixed point of some function. *}

lemma "\<exists>f. f x = x"
refute [maxsize = 4, expect = none]
apply (rule_tac x="\<lambda>x. x" in exI)
by simp

text {* Axiom of Choice: first an incorrect version ... *}

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (EX!f. \<forall>x. P x (f x))"
refute [expect = genuine]
oops

text {* ... and now two correct ones *}

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
refute [maxsize = 4, expect = none]
by (simp add: choice)

lemma "(\<forall>x. EX!y. P x y) \<longrightarrow> (EX!f. \<forall>x. P x (f x))"
refute [maxsize = 2, expect = none]
apply auto
  apply (simp add: ex1_implies_ex choice)
by (fast intro: ext)

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

subsubsection {* Meta-logic *}

lemma "!!x. P x"
refute [expect = genuine]
oops

lemma "f x == g x"
refute [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
refute [expect = genuine]
oops

lemma "\<lbrakk> P; Q; R \<rbrakk> \<Longrightarrow> S"
refute [expect = genuine]
oops

lemma "(x == Pure.all) \<Longrightarrow> False"
refute [expect = genuine]
oops

lemma "(x == (op ==)) \<Longrightarrow> False"
refute [expect = genuine]
oops

lemma "(x == (op \<Longrightarrow>)) \<Longrightarrow> False"
refute [expect = genuine]
oops

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

subsubsection {* Schematic variables *}

schematic_lemma "?P"
refute [expect = none]
by auto

schematic_lemma "x = ?y"
refute [expect = none]
by auto

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

subsubsection {* Abstractions *}

lemma "(\<lambda>x. x) = (\<lambda>x. y)"
refute [expect = genuine]
oops

lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
refute [expect = genuine]
oops

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
refute
by simp

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

subsubsection {* Sets *}

lemma "P (A::'a set)"
refute
oops

lemma "P (A::'a set set)"
refute
oops

lemma "{x. P x} = {y. P y}"
refute
by simp

lemma "x : {x. P x}"
refute
oops

lemma "P op:"
refute
oops

lemma "P (op: x)"
refute
oops

lemma "P Collect"
refute
oops

lemma "A Un B = A Int B"
refute
oops

lemma "(A Int B) Un C = (A Un C) Int B"
refute
oops

lemma "Ball A P \<longrightarrow> Bex A P"
refute
oops

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

subsubsection {* undefined *}

lemma "undefined"
refute [expect = genuine]
oops

lemma "P undefined"
refute [expect = genuine]
oops

lemma "undefined x"
refute [expect = genuine]
oops

lemma "undefined undefined"
refute [expect = genuine]
oops

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

subsubsection {* The *}

lemma "The P"
refute [expect = genuine]
oops

lemma "P The"
refute [expect = genuine]
oops

lemma "P (The P)"
refute [expect = genuine]
oops

lemma "(THE x. x=y) = z"
refute [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (The P)"
refute [expect = genuine]
oops

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

subsubsection {* Eps *}

lemma "Eps P"
refute [expect = genuine]
oops

lemma "P Eps"
refute [expect = genuine]
oops

lemma "P (Eps P)"
refute [expect = genuine]
oops

lemma "(SOME x. x=y) = z"
refute [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
refute [maxsize = 3, expect = none]
by (auto simp add: someI)

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

subsubsection {* Subtypes (typedef), typedecl *}

text {* A completely unspecified non-empty subset of @{typ "'a"}: *}

definition "myTdef = insert (undefined::'a) (undefined::'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
  unfolding myTdef_def by auto

lemma "(x::'a myTdef) = y"
refute
oops

typedecl myTdecl

definition "T_bij = {(f::'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
  unfolding T_bij_def by auto

lemma "P (f::(myTdecl myTdef) T_bij)"
refute
oops

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

subsubsection {* Inductive datatypes *}

text {* unit *}

lemma "P (x::unit)"
refute [expect = genuine]
oops

lemma "\<forall>x::unit. P x"
refute [expect = genuine]
oops

lemma "P ()"
refute [expect = genuine]
oops

lemma "P (case x of () \<Rightarrow> u)"
refute [expect = genuine]
oops

text {* option *}

lemma "P (x::'a option)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a option. P x"
refute [expect = genuine]
oops

lemma "P None"
refute [expect = genuine]
oops

lemma "P (Some x)"
refute [expect = genuine]
oops

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
refute [expect = genuine]
oops

text {* * *}

lemma "P (x::'a*'b)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a*'b. P x"
refute [expect = genuine]
oops

lemma "P (x, y)"
refute [expect = genuine]
oops

lemma "P (fst x)"
refute [expect = genuine]
oops

lemma "P (snd x)"
refute [expect = genuine]
oops

lemma "P Pair"
refute [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> p a b)"
refute [expect = genuine]
oops

text {* + *}

lemma "P (x::'a+'b)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a+'b. P x"
refute [expect = genuine]
oops

lemma "P (Inl x)"
refute [expect = genuine]
oops

lemma "P (Inr x)"
refute [expect = genuine]
oops

lemma "P Inl"
refute [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
refute [expect = genuine]
oops

text {* Non-recursive datatypes *}

datatype T1 = A | B

lemma "P (x::T1)"
refute [expect = genuine]
oops

lemma "\<forall>x::T1. P x"
refute [expect = genuine]
oops

lemma "P A"
refute [expect = genuine]
oops

lemma "P B"
refute [expect = genuine]
oops

lemma "rec_T1 a b A = a"
refute [expect = none]
by simp

lemma "rec_T1 a b B = b"
refute [expect = none]
by simp

lemma "P (rec_T1 a b x)"
refute [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
refute [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x::'a T2)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a T2. P x"
refute [expect = genuine]
oops

lemma "P D"
refute [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
refute [maxsize = 4, expect = none]
by simp

lemma "rec_T2 c d (D x) = d x"
refute [maxsize = 4, expect = none]
by simp

lemma "P (rec_T2 c d x)"
refute [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
refute [expect = genuine]
oops

datatype ('a,'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x::('a,'b) T3)"
refute [expect = genuine]
oops

lemma "\<forall>x::('a,'b) T3. P x"
refute [expect = genuine]
oops

lemma "P E"
refute [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_T3 e x)"
refute [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
refute [expect = genuine]
oops

text {* Recursive datatypes *}

text {* nat *}

lemma "P (x::nat)"
refute [expect = potential]
oops

lemma "\<forall>x::nat. P x"
refute [expect = potential]
oops

lemma "P (Suc 0)"
refute [expect = potential]
oops

lemma "P Suc"
refute [maxsize = 3, expect = none]
-- {* @{term Suc} is a partial function (regardless of the size
      of the model), hence @{term "P Suc"} is undefined and no
      model will be found *}
oops

lemma "rec_nat zero suc 0 = zero"
refute [expect = none]
by simp

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_nat zero suc x)"
refute [expect = potential]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
refute [expect = potential]
oops

text {* 'a list *}

lemma "P (xs::'a list)"
refute [expect = potential]
oops

lemma "\<forall>xs::'a list. P xs"
refute [expect = potential]
oops

lemma "P [x, y]"
refute [expect = potential]
oops

lemma "rec_list nil cons [] = nil"
refute [maxsize = 3, expect = none]
by simp

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_list nil cons xs)"
refute [expect = potential]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
refute [expect = potential]
oops

lemma "(xs::'a list) = ys"
refute [expect = potential]
oops

lemma "a # xs = b # xs"
refute [expect = potential]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x::BitList)"
refute [expect = potential]
oops

lemma "\<forall>x::BitList. P x"
refute [expect = potential]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
refute [expect = potential]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
refute [maxsize = 4, expect = none]
by simp

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_BitList nil bit0 bit1 x)"
refute [expect = potential]
oops

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

subsubsection {* Examples involving special functions *}

lemma "card x = 0"
refute [expect = potential]
oops

lemma "finite x"
refute -- {* no finite countermodel exists *}
oops

lemma "(x::nat) + y = 0"
refute [expect = potential]
oops

lemma "(x::nat) = x + x"
refute [expect = potential]
oops

lemma "(x::nat) - y + y = x"
refute [expect = potential]
oops

lemma "(x::nat) = x * x"
refute [expect = potential]
oops

lemma "(x::nat) < x + y"
refute [expect = potential]
oops

lemma "xs @ [] = ys @ []"
refute [expect = potential]
oops

lemma "xs @ ys = ys @ xs"
refute [expect = potential]
oops

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

subsubsection {* Type classes and overloading *}

text {* A type class without axioms: *}

class classA

lemma "P (x::'a::classA)"
refute [expect = genuine]
oops

text {* An axiom with a type variable (denoting types which have at least two elements): *}

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x::'a::classC)"
refute [expect = genuine]
oops

lemma "\<exists>x y. (x::'a::classC) \<noteq> y"
(* refute [expect = none] FIXME *)
oops

text {* A type class for which a constant is defined: *}

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x::'a::classD)"
refute [expect = genuine]
oops

text {* A type class with multiple superclasses: *}

class classE = classC + classD

lemma "P (x::'a::classE)"
refute [expect = genuine]
oops

text {* OFCLASS: *}

lemma "OFCLASS('a::type, type_class)"
refute [expect = none]
by intro_classes

lemma "OFCLASS('a::classC, type_class)"
refute [expect = none]
by intro_classes

lemma "OFCLASS('a::type, classC_class)"
refute [expect = genuine]
oops

text {* Overloading: *}

consts inverse :: "'a \<Rightarrow> 'a"

defs (overloaded)
  inverse_bool: "inverse (b::bool)   == ~ b"
  inverse_set : "inverse (S::'a set) == -S"
  inverse_pair: "inverse p           == (inverse (fst p), inverse (snd p))"

lemma "inverse b"
refute [expect = genuine]
oops

lemma "P (inverse (S::'a set))"
refute [expect = genuine]
oops

lemma "P (inverse (p::'a\<times>'b))"
refute [expect = genuine]
oops

text {* Structured proofs *}

lemma "x = y"
proof cases
  assume "x = y"
  show ?thesis
  refute [expect = none]
  refute [no_assms, expect = genuine]
  refute [no_assms = false, expect = none]
oops

refute_params [satsolver = "auto"]

end


theory  Correspondence_theory  imports DDLE
begin
abbreviation limitedness  where "limitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation Dstar_valid  where "Dstar_valid \<equiv> (\<forall>\<phi> \<psi>. \<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>>  \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<rfloor>)"
abbreviation transitivity where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation Sp_valid     where "Sp_valid \<equiv> (\<forall>\<phi> \<psi> \<chi>. \<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>> \<^bold>\<and> \<circle><\<psi>\<^bold>\<rightarrow>\<chi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>)"

lemma "limitedness \<longleftrightarrow> Dstar_valid"
 unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddevalid_def by auto

lemma "(limitedness \<and> transitivity) \<longrightarrow> (Sp_valid \<and> Dstar_valid)"
 unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
 sledgehammer by smt (*This direction is provable*)

lemma "(Sp_valid \<and> Dstar_valid) \<longrightarrow> (limitedness \<and> transitivity)"
 unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def oops
 (*This direction unfortunately not yet, but we also do not get a countermodel*)

lemma "(Sp_valid \<and> Dstar_valid) \<longrightarrow> limitedness"
 unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
 sledgehammer by auto (*Splitting the conjunction, limitednedd is easy for the ATPs*)

lemma "(Sp_valid \<and> Dstar_valid) \<longrightarrow> transitivity"
 unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def oops
 (*Splitting the conjunction, transitivity is too hard for the ATPs*)
 (*This direction unfortunately not yet, but we also do not get a countermodel*)
end